Télécharger provcc.eso

Retour à la liste

Numérotation des lignes :

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

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