Télécharger provcc.eso

Retour à la liste

Numérotation des lignes :

  1. C PROVCC SOURCE PV 17/06/16 14:33:52 9460
  2. SUBROUTINE PROVCC(MCHPO1,MCHPO2,MLMOT1,MLMOT2,MLMOT3,MCHPO3)
  3. C-----------------------------------------------------------------------
  4. C PRODUIT VECTORIEL DE 2 CHPOINTS
  5. C-----------------------------------------------------------------------
  6. C EN STANDARD LE CHPOINT RESULTAT A POUR NUMERO D'HARMONIQUE 0
  7. C EN SERIE DE FOURIER , IL EST TYPE NOHARM
  8. C-----------------------------------------------------------------------
  9. C ENTREE
  10. C MCHPO1 CHPOINT
  11. C MLMOT1 LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT MCHPO1
  12. C Si 3D :
  13. C MCHPO2 CHPOINT
  14. C MLMOT2 LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT MCHPO2
  15. C MLMOT3 LISTMOTS DE COMPOSANTES ASSOCIEES AU CHPOINT RESULTAT
  16. C SORTIE
  17. C MCHPO3 POINTEUR SUR LE CHPOINT RESULTAT
  18. C-----------------------------------------------------------------------
  19. IMPLICIT INTEGER(I-N)
  20. IMPLICIT REAL*8(A-H,O-Z)
  21. -INC CCOPTIO
  22. -INC SMCHPOI
  23. -INC SMLMOTS
  24. -INC SMELEME
  25. -INC SMCOORD
  26. -INC TMTRAV
  27. CHARACTER*4 NOIN,NOMIL
  28. integer*4 iOMIL
  29. equivalence (nomil,iomil)
  30. LOGICAL LDOUB
  31. SEGMENT ITRAV
  32. REAL*8 IVAA(NINC,NPOI),IVAB(NINC,NPOI)
  33. INTEGER IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI)
  34. CHARACTER*4 INCA(NINC),INCB(NINC)
  35. ENDSEGMENT
  36. DATA NOMIL/'NOHA'/
  37. *
  38. * On vérifie qu'il n'y a pas de doublons dans les LISTMOTS
  39. * donnés en entrée
  40. *
  41. LDOUB=.FALSE.
  42. CALL CUNIQ2(MLMOT1,MLMOT4)
  43. CALL CUNIQ2(MLMOT3,MLMOT6)
  44. IF (IDIM.EQ.3) CALL CUNIQ2(MLMOT2,MLMOT5)
  45. SEGACT,MLMOT1,MLMOT3,MLMOT4,MLMOT6
  46. IF (IDIM.EQ.3) SEGACT,MLMOT2,MLMOT5
  47. NINC1=MLMOT1.MOTS(/2)
  48. NINC3=MLMOT3.MOTS(/2)
  49. NINC4=MLMOT4.MOTS(/2)
  50. NINC6=MLMOT6.MOTS(/2)
  51. IF (IDIM.EQ.3) THEN
  52. NINC2=MLMOT2.MOTS(/2)
  53. NINC5=MLMOT5.MOTS(/2)
  54. ELSE
  55. NINC2=IDIM
  56. NINC5=IDIM
  57. ENDIF
  58. LDOUB=LDOUB.OR.(NINC1.NE.NINC4)
  59. LDOUB=LDOUB.OR.(NINC2.NE.NINC5)
  60. LDOUB=LDOUB.OR.(NINC3.NE.NINC6)
  61. SEGSUP,MLMOT4,MLMOT6
  62. IF (IDIM.EQ.3) SEGSUP,MLMOT5
  63. IF (LDOUB) THEN
  64. * 1019 2
  65. * Une donnée de type %m1:8 contient des doublons
  66. MOTERR(1:8)='LISTMOTS'
  67. CALL ERREUR(1019)
  68. RETURN
  69. ENDIF
  70. IF (NINC1.NE.IDIM.OR.NINC2.NE.IDIM.OR.NINC3.NE.IDIM) THEN
  71. * 1018 2
  72. * On attend un objet de type %m1:8 de dimension %i1
  73. MOTERR(1:8)='LISTMOTS'
  74. INTERR(1)=IDIM
  75. CALL ERREUR(1018)
  76. RETURN
  77. ENDIF
  78. IF (IDIM.EQ.3) GOTO 1000
  79. *
  80. * Cas simple (2D)
  81. *
  82. SEGINI,MCHPO3=MCHPO1
  83. NSOUPO=0
  84. SEGACT MCHPO1
  85. NSOUP1=MCHPO1.IPCHP(/1)
  86. DO 30 ISOUP1=1,NSOUP1
  87. MSOUP1=MCHPO1.IPCHP(ISOUP1)
  88. SEGACT MSOUP1
  89. NC1=MSOUP1.NOHARM(/1)
  90. NX=0
  91. NY=0
  92. * WRITE(IOIMP,*) 'MOTS1=',MLMOT1.MOTS(1)(1:4)
  93. * WRITE(IOIMP,*) 'MOTS2=',MLMOT1.MOTS(2)(1:4)
  94. DO IC1=1,NC1
  95. * WRITE(IOIMP,*) 'NOCOMP1=',MSOUP1.NOCOMP(IC1)
  96. IF (MSOUP1.NOCOMP(IC1).EQ.MLMOT1.MOTS(1)(1:4)) NX=IC1
  97. IF (MSOUP1.NOCOMP(IC1).EQ.MLMOT1.MOTS(2)(1:4)) NY=IC1
  98. ENDDO
  99. NC=0
  100. IF (NX.NE.0) NC=NC+1
  101. IF (NY.NE.0) NC=NC+1
  102. * WRITE(IOIMP,*) 'NX=',NX
  103. * WRITE(IOIMP,*) 'NY=',NY
  104. IF (NC.EQ.0) GOTO 29
  105. SEGINI MSOUP3
  106. MPOVA1=MSOUP1.IPOVAL
  107. SEGACT MPOVA1
  108. N=MPOVA1.VPOCHA(/1)
  109. SEGINI MPOVA3
  110. IC=0
  111. IF (NY.NE.0) THEN
  112. IC=IC+1
  113. * WRITE(IOIMP,*) 'IC=',IC,' ',MLMOT3.MOTS(1)(1:4)
  114. MSOUP3.NOCOMP(IC)=MLMOT3.MOTS(1)(1:4)
  115. MSOUP3.NOCONS(IC)=MSOUP1.NOCONS(NY)
  116. MSOUP3.NOHARM(IC)=MSOUP1.NOHARM(NY)
  117. DO I=1,N
  118. MPOVA3.VPOCHA(I,IC)=-1*MPOVA1.VPOCHA(I,NY)
  119. ENDDO
  120. ENDIF
  121. IF (NX.NE.0) THEN
  122. IC=IC+1
  123. * WRITE(IOIMP,*) 'IC=',IC,' ',MLMOT3.MOTS(2)(1:4)
  124. MSOUP3.NOCOMP(IC)=MLMOT3.MOTS(2)(1:4)
  125. MSOUP3.NOCONS(IC)=MSOUP1.NOCONS(NX)
  126. MSOUP3.NOHARM(IC)=MSOUP1.NOHARM(NX)
  127. DO I=1,N
  128. MPOVA3.VPOCHA(I,IC)=MPOVA1.VPOCHA(I,NX)
  129. ENDDO
  130. ENDIF
  131. SEGDES MPOVA3
  132. SEGDES MPOVA1
  133. MSOUP3.IGEOC=MSOUP1.IGEOC
  134. MSOUP3.IPOVAL=MPOVA3
  135. SEGDES MSOUP3
  136. NSOUPO=NSOUPO+1
  137. MCHPO3.IPCHP(NSOUPO)=MSOUP3
  138. 29 CONTINUE
  139. SEGDES MSOUP1
  140. 30 CONTINUE
  141. SEGDES MCHPO1
  142. NAT=MCHPO3.JATTRI(/1)
  143. SEGADJ MCHPO3
  144. SEGDES MCHPO3
  145. SEGDES MLMOT1,MLMOT3
  146. RETURN
  147. *
  148. * Cas dimension 3 repris de la subroutine PROSCAL
  149. *
  150. 1000 CONTINUE
  151. NPOI=XCOOR(/1)/(IDIM+1)
  152. MLMOTS=MLMOT1
  153. SEGACT MLMOTS
  154. NINC= MOTS(/2)
  155. SEGINI ITRAV
  156. DO 1 I = 1, NINC
  157. INCA(I)=MOTS(I)
  158. 1 CONTINUE
  159. SEGDES MLMOTS
  160. MLMOTS=MLMOT2
  161. SEGACT MLMOTS
  162. IF(MOTS(/2).NE.NINC) THEN
  163. SEGDES MLMOTS
  164. SEGSUP ITRAV
  165. MOTERR(1:4)='PVEC'
  166. MOTERR(5:12)='LISTMOTS'
  167. CALL ERREUR(125)
  168. RETURN
  169. ENDIF
  170. DO 21 I = 1, NINC
  171. INCB(I)=MOTS(I)
  172. 21 CONTINUE
  173. SEGDES MLMOTS
  174. C
  175. C ********* IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB
  176. C ********* CREATION D'ABORD DE IVAA PUIS DE IVAB
  177. C
  178. MCHPOI=MCHPO1
  179. SEGACT MCHPOI
  180. NSOUPO = IPCHP(/1)
  181. DO 2 M = 1,NSOUPO
  182. MSOUPO = IPCHP(M)
  183. SEGACT MSOUPO
  184. NC=NOCOMP(/2)
  185. DO 10 I = 1,NINC
  186. IPOS(I)=0
  187. 10 CONTINUE
  188. DO 4 K = 1, NINC
  189. DO 3 J = 1, NC
  190. NOIN= NOCOMP (J)
  191. IF(INCA(K). EQ . NOIN) THEN
  192. IPOS(K)=J
  193. GO TO 4
  194. ENDIF
  195. 3 CONTINUE
  196. 4 CONTINUE
  197. DO 5 I = 1,NINC
  198. IF(IPOS(I). NE . 0) GO TO 6
  199. 5 CONTINUE
  200. GO TO 8
  201. 6 CONTINUE
  202. MELEME=IGEOC
  203. SEGACT MELEME
  204. NBELEM=NUM(/2)
  205. MPOVAL=IPOVAL
  206. SEGACT MPOVAL
  207. DO 9 LI = 1,NINC
  208. KL = IPOS(LI)
  209. IF(KL.EQ.0) GO TO 9
  210. DO 7 I = 1,NBELEM
  211. I1 = NUM(1,I)
  212. IVAA(LI,I1)=VPOCHA(I,KL)
  213. ICPRA(I1)=1
  214. 7 CONTINUE
  215. 9 CONTINUE
  216. SEGDES MELEME,MPOVAL
  217. 8 CONTINUE
  218. SEGDES MSOUPO
  219. 2 CONTINUE
  220. SEGDES MCHPOI
  221. C
  222. C TRAITEMENT DU 2-EME CHPOINT
  223. C
  224. IA=0
  225. MCHPOI=MCHPO2
  226. SEGACT MCHPOI
  227. NSOUPO = IPCHP(/1)
  228. DO 12 M = 1,NSOUPO
  229. MSOUPO = IPCHP(M)
  230. SEGACT MSOUPO
  231. NC=NOCOMP(/2)
  232. DO 11 I = 1,NINC
  233. IPOS(I)=0
  234. 11 CONTINUE
  235. DO 14 K= 1,NINC
  236. DO 13 J = 1, NC
  237. NOIN= NOCOMP (J)
  238. IF(INCB(K). EQ . NOIN) THEN
  239. IPOS(K)=J
  240. GO TO 14
  241. ENDIF
  242. 13 CONTINUE
  243. 14 CONTINUE
  244. DO 15 I = 1,NINC
  245. IF(IPOS(I). NE . 0) GO TO 16
  246. 15 CONTINUE
  247. GO TO 18
  248. 16 CONTINUE
  249. MELEME=IGEOC
  250. SEGACT MELEME
  251. NBELEM=NUM(/2)
  252. MPOVAL=IPOVAL
  253. SEGACT MPOVAL
  254. DO 19 LI = 1,NINC
  255. KL = IPOS(LI)
  256. IF(KL.EQ.0) GO TO 19
  257. DO 17 I = 1,NBELEM
  258. I1 = NUM(1,I)
  259. IVAB(LI,I1)=VPOCHA(I,KL)
  260. IF(ICPRA(I1).NE.0) THEN
  261. IA=IA+1
  262. ICPRB(I1)=IA
  263. ENDIF
  264. 17 CONTINUE
  265. 19 CONTINUE
  266. SEGDES MELEME,MPOVAL
  267. 18 CONTINUE
  268. SEGDES MSOUPO
  269. 12 CONTINUE
  270. IF(IA.EQ.0) THEN
  271. C
  272. C CHPOINT VIDE
  273. C
  274. SEGSUP ITRAV
  275. SEGDES MCHPOI
  276. NSOUPO=0
  277. NAT=1
  278. SEGINI MCHPOI
  279. IFOPOI=IFOUR
  280. SEGDES MCHPOI
  281. MCHPO3=MCHPOI
  282. RETURN
  283. ENDIF
  284. C
  285. C ON EFFECTUE LE CALCUL
  286. C
  287. NNIN=3
  288. NNNOE=IA
  289. SEGINI MTRAV
  290. SEGACT MLMOT3
  291. DO I=1,3
  292. INCO(I)=MLMOT3.MOTS(I)
  293. ENDDO
  294. SEGDES MLMOT3
  295. *
  296. * MODIF MILL LE 18 / 7 / 90
  297. * REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON
  298. *
  299. IF(IFOPOI.EQ.1) THEN
  300. NHMIL=iomil
  301. DO I=1,3
  302. NHAR(1)=NHMIL
  303. ENDDO
  304. ENDIF
  305. *
  306. MCHPOI=MCHPO1
  307. SEGACT MCHPOI
  308. NSOUPO=IPCHP(/1)
  309. DO 22 M=1,NSOUPO
  310. MSOUPO=IPCHP(M)
  311. SEGACT MSOUPO
  312. MELEME=IGEOC
  313. SEGACT MELEME
  314. DO 27 J=1,NUM(/2)
  315. I1=NUM(1,J)
  316. IB=ICPRB(I1)
  317. IF(IB.EQ.0) GO TO 27
  318. IF(IGEO(IB).NE.0) GO TO 27
  319. IGEO(IB)=I1
  320. DO 28 LI=1,NINC
  321. IBIN(LI,IB)=1
  322. 28 CONTINUE
  323. BB(1,IB)=BB(1,IB)+IVAA(2,I1)*IVAB(3,I1)
  324. $ -IVAA(3,I1)*IVAB(2,I1)
  325. BB(2,IB)=BB(2,IB)+IVAA(3,I1)*IVAB(1,I1)
  326. $ -IVAA(1,I1)*IVAB(3,I1)
  327. BB(3,IB)=BB(3,IB)+IVAA(1,I1)*IVAB(2,I1)
  328. $ -IVAA(2,I1)*IVAB(1,I1)
  329. 27 CONTINUE
  330. SEGDES MELEME,MSOUPO
  331. 22 CONTINUE
  332. SEGDES MCHPOI
  333. SEGSUP ITRAV
  334. CALL CRECHP(MTRAV,MCHPO3)
  335. SEGSUP MTRAV
  336. RETURN
  337. END
  338.  
  339.  
  340.  
  341.  
  342.  
  343.  
  344.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales