Télécharger provcc.eso

Retour à la liste

Numérotation des lignes :

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

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