Télécharger mschp1.eso

Retour à la liste

Numérotation des lignes :

  1. C MSCHP1 SOURCE JC220346 16/12/14 21:15:35 9262
  2. SUBROUTINE MSCHP1(IPO2,IPO3,X1,IKO,IPO1,ICLE,IRET,ISOM)
  3. C=======================================================================
  4. C ENTREE
  5. C IPO1 = POINTEUR SUR LE PREMIER CHPO
  6. C IPO2 = POINTEUR SUR LE SECOND CHPO
  7. C IPO3 = POINTEUR SUR LE TROISIEME CHPO (OPTION "COMP")
  8. C X1 = VALEUR MIN OU MAX (OPTION "COMP")
  9. C IKO = 0 SI IPO2 PUIS IPO3, 1 SI X1 PUIS IPO2, -1 SI IPO2 PUIS X1
  10. C ICLE = ENTIER CARACTERISANT LE TYPE DE COMPARAISON
  11. C ISOM = 1 SI ON VEUT LA SOMME, 0 SINON
  12. C SORTIE
  13. C IRET = POINTEUR SUR LE CHAMP RESULTAT SI ISOM=0
  14. C IRET = SOMME DES 1 ET DES 0 SI ISOM=1
  15. C=======================================================================
  16. IMPLICIT INTEGER(I-N)
  17. IMPLICIT REAL*8(A-H,O-Z)
  18. -INC SMCHPOI
  19. -INC CCOPTIO
  20. -INC SMELEME
  21. -INC SMCOORD
  22.  
  23. SEGMENT/MTRA/(NOPOIN(XCOOR(/1)/(IDIM+1)))
  24. SEGMENT MTR1
  25. CHARACTER*4 IPCOM(0)
  26. ENDSEGMENT
  27. SEGMENT/MTR4/(IPHAR(0))
  28. SEGMENT/MTR2/(IC2CC(NC2))
  29. SEGMENT MTR3
  30. REAL*8 BB2(NNIN,NNNOE)
  31. ENDSEGMENT
  32. SEGMENT MTR5
  33. REAL*8 BB3(NNIN,NNNOE)
  34. ENDSEGMENT
  35. C
  36. IKOK=IKO
  37. IF (IKOK.EQ.0.AND.IPO3.LE.0) IKOK=-1
  38. C
  39. C ======================================================================
  40. C REMPLISSAGE DE NOPOIN, IPCOM et BB2
  41. C ======================================================================
  42. C
  43. C ----------------------------------
  44. C ON RECUPERE LES INFOS DU CHPOINT 2
  45. C ----------------------------------
  46. MCHPOI=IPO2
  47. SEGACT MCHPOI
  48. NSOUPO=IPCHP(/1)
  49.  
  50. c PREDIMENSIONNEMENT DE IC2CC AU MAX POSSIBLE
  51. NC2=0
  52. DO IA=1,NSOUPO
  53. MSOUPO=IPCHP(IA)
  54. SEGACT MSOUPO
  55. NC2=NC2+NOCOMP(/2)
  56. SEGDES MSOUPO
  57. ENDDO
  58. SEGINI,MTR2
  59.  
  60. c AUTRES INITIALISATIONS
  61. IK=0
  62. KSOM=0
  63. SEGINI,MTRA,MTR1,MTR4
  64.  
  65.  
  66. C BOUCLE SUR LES ZONES DU CHPO 2
  67. C
  68. DO 20 IA=1,NSOUPO
  69.  
  70. MSOUPO=IPCHP(IA)
  71. SEGACT,MSOUPO
  72.  
  73. * composantes + harmoniques --> liste locale
  74. NC=NOCOMP(/2)
  75. * boucle sur les composantes de cette zone du chpoint
  76. DO 40 IC=1,NC
  77. NCC=IPCOM(/2)
  78. * boucle sur les composantes deja enregistrees
  79. DO 50 ICC=1,NCC
  80. IF(IPCOM(ICC).NE.NOCOMP(IC)) GO TO 50
  81. IF(IPHAR(ICC).EQ.NOHARM(IC)) GO TO 40
  82. 50 CONTINUE
  83. * nouvelle composante -> on l'enregistre dans la liste complete
  84. IPCOM(**)=NOCOMP(IC)
  85. IPHAR(**)=NOHARM(IC)
  86. NCC=NCC+1
  87. ICC=NCC
  88. IC2CC(IC)=ICC
  89. NC2=MAX(IC,NC2)
  90. 40 CONTINUE
  91.  
  92. * maillage --> numerotation locale NOPOIN
  93. MELEME=IGEOC
  94. SEGACT,MELEME
  95. NBNN=NUM(/1)
  96. NBELEM=NUM(/2)
  97. DO 30 IB=1,NBELEM
  98. K=NUM(1,IB)
  99. IF(NOPOIN(K).NE.0) GOTO 30
  100. IK=IK+1
  101. NOPOIN(K)=IK
  102. 30 CONTINUE
  103. SEGDES,MELEME
  104.  
  105. SEGDES,MSOUPO
  106. 20 CONTINUE
  107. SEGADJ,MTR2
  108.  
  109. C ----------------------------------------------
  110. C ON RECUPERE LES INFOS DU CHPOINT 3 (SI BESOIN)
  111. C ----------------------------------------------
  112. IF (IKOK.EQ.0) THEN
  113. MCHPOI=IPO3
  114. SEGACT MCHPOI
  115. NSOUPO=IPCHP(/1)
  116.  
  117. c PREDIMENSIONNEMENT DE IC2CC AU MAX POSSIBLE
  118. DO IA=1,NSOUPO
  119. MSOUPO=IPCHP(IA)
  120. SEGACT MSOUPO
  121. NC2=NC2+NOCOMP(/2)
  122. SEGDES MSOUPO
  123. ENDDO
  124. SEGADJ,MTR2
  125.  
  126. C BOUCLE SUR LES ZONES DU CHPO 2
  127. C
  128. DO 120 IA=1,NSOUPO
  129.  
  130. MSOUPO=IPCHP(IA)
  131. SEGACT,MSOUPO
  132.  
  133. * composantes + harmoniques --> liste locale
  134. NC=NOCOMP(/2)
  135. * boucle sur les composantes de cette zone du chpoint
  136. DO 140 IC=1,NC
  137. NCC=IPCOM(/2)
  138. * boucle sur les composantes deja enregistrees
  139. DO 150 ICC=1,NCC
  140. IF(IPCOM(ICC).NE.NOCOMP(IC)) GOTO 150
  141. IF(IPHAR(ICC).EQ.NOHARM(IC)) GOTO 140
  142. 150 CONTINUE
  143. * nouvelle composante -> on l'enregistre dans la liste complete
  144. IPCOM(**)=NOCOMP(IC)
  145. IPHAR(**)=NOHARM(IC)
  146. NCC=NCC+1
  147. ICC=NCC
  148. IC2CC(IC)=ICC
  149. NC2=MAX(IC,NC2)
  150. 140 CONTINUE
  151.  
  152. * maillage --> numerotation locale NOPOIN
  153. MELEME=IGEOC
  154. SEGACT,MELEME
  155. NBNN=NUM(/1)
  156. NBELEM=NUM(/2)
  157. DO 130 IB=1,NBELEM
  158. K=NUM(1,IB)
  159. IF(NOPOIN(K).NE.0) GOTO 130
  160. IK=IK+1
  161. NOPOIN(K)=IK
  162. 130 CONTINUE
  163. SEGDES,MELEME
  164.  
  165. SEGDES,MSOUPO
  166. 120 CONTINUE
  167. SEGADJ,MTR2
  168. ENDIF
  169.  
  170. C -----------------------------------------------------
  171. C CREATION ET REMPLISSAGE DE BB2 = VALEURS DU CHPOINT 2
  172. C -----------------------------------------------------
  173.  
  174. MCHPOI=IPO2
  175. NSOUPO=IPCHP(/1)
  176. NNIN=NC2
  177. NNNOE=IK
  178. SEGINI,MTR3
  179. DO 21 IA=1,NSOUPO
  180.  
  181. MSOUPO=IPCHP(IA)
  182. SEGACT,MSOUPO
  183.  
  184. * maillage ET valeur
  185. MPOVA2=IPOVAL
  186. MELEME=IGEOC
  187. SEGACT,MELEME,MPOVA2
  188. NBNN=NUM(/1)
  189. NBELEM=NUM(/2)
  190. DO 31 IB=1,NBELEM
  191. K=NUM(1,IB)
  192. IK=NOPOIN(K)
  193. * on en profite pour enregistrer les valeurs du chpo 2
  194. * --> stockee dans tableau local BB2
  195. DO 32 IC=1,NC
  196. ICC=IC2CC(IC)
  197. BB2(ICC,IK)=MPOVA2.VPOCHA(IB,IC)
  198. 32 CONTINUE
  199. 31 CONTINUE
  200. SEGDES,MELEME,MPOVA2
  201.  
  202. SEGDES,MSOUPO
  203.  
  204. 21 CONTINUE
  205.  
  206. SEGDES MCHPOI
  207.  
  208.  
  209. C -----------------------------------------------------------------
  210. C CREATION ET REMPLISSAGE DE BB3 = VALEURS DU CHPOINT 3 (SI BESOIN)
  211. C -----------------------------------------------------------------
  212.  
  213. IF (IKOK.EQ.0) THEN
  214. MCHPOI=IPO3
  215. NSOUPO=IPCHP(/1)
  216. NNIN=NC2
  217. NNNOE=IK
  218. SEGINI,MTR5
  219. DO 121 IA=1,NSOUPO
  220.  
  221. MSOUPO=IPCHP(IA)
  222. SEGACT,MSOUPO
  223.  
  224. * maillage ET valeur
  225. MPOVA2=IPOVAL
  226. MELEME=IGEOC
  227. SEGACT,MELEME,MPOVA2
  228. NBNN=NUM(/1)
  229. NBELEM=NUM(/2)
  230. DO 131 IB=1,NBELEM
  231. K=NUM(1,IB)
  232. IK=NOPOIN(K)
  233. * on en profite pour enregistrer les valeurs du chpo 2
  234. * --> stockee dans tableau local BB2
  235. DO 132 IC=1,NC
  236. ICC=IC2CC(IC)
  237. BB3(ICC,IK)=MPOVA2.VPOCHA(IB,IC)
  238. 132 CONTINUE
  239. 131 CONTINUE
  240. SEGDES,MELEME,MPOVA2
  241.  
  242. SEGDES,MSOUPO
  243.  
  244. 121 CONTINUE
  245. ENDIF
  246.  
  247.  
  248. C ======================================================================
  249. C CREATION DU CHPOINT RESULTAT DEPUIS LE 1ER CHPOINT
  250. C ======================================================================
  251. C
  252. MCHPO1=IPO1
  253. SEGINI,MCHPOI=MCHPO1
  254. ICHPOI=MCHPOI
  255. MOCHDE='CHPOINT CREE PAR MASQ'
  256.  
  257. NSOUPO=IPCHP(/1)
  258. C BOUCLE SUR LES ZONES
  259. DO 60 IA=1,NSOUPO
  260.  
  261. MSOUP1=IPCHP(IA)
  262. SEGINI,MSOUPO=MSOUP1
  263. IPCHP(IA)=MSOUPO
  264. NC=NOCOMP(/2)
  265. MPOVA1=IPOVAL
  266. SEGINI,MPOVAL=MPOVA1
  267. IPOVAL=MPOVAL
  268. MELEME=IGEOC
  269. SEGACT,MELEME
  270. NBELEM=NUM(/2)
  271.  
  272. C BOUCLE SUR LES COMPOSANTES
  273. DO 70 IC=1,NC
  274.  
  275. C recherche dans la liste cree depuis le 2eme chpoint
  276. DO 71 ICC=1,IPCOM(/2)
  277. IF(IPCOM(ICC).NE.NOCOMP(IC)) GOTO 71
  278. IF(IPHAR(ICC).EQ.NOHARM(IC)) GOTO 72
  279. 71 CONTINUE
  280. c on n'a pas trouve de composantes adequates <=> ICC=0
  281. ICC=0
  282. 72 CONTINUE
  283. c on a trouve ICC
  284.  
  285. c BOUCLE SUR LES NOEUDS (le maillage reste le meme que 1er CHPOINT)
  286. DO 80 IB=1,NBELEM
  287.  
  288. K=NUM(1,IB)
  289. IK=NOPOIN(K)
  290. c si ik=0 OU ICC=0, le point OU la composante n'existe pas
  291. c dans les autres chpoints ==> x2=x3=0 par convention
  292. IF (ICC.EQ.0.OR.IK.EQ.0) THEN
  293. IF (IKOK.EQ.0) THEN
  294. X2=0.D0
  295. X3=0.D0
  296. ELSEIF (IKOK.GT.0) THEN
  297. X2=X1
  298. X3=0.D0
  299. ELSE
  300. X2=0.D0
  301. X3=X1
  302. ENDIF
  303. ELSE
  304. IF (IKOK.EQ.0) THEN
  305. X2=BB2(ICC,IK)
  306. X3=BB3(ICC,IK)
  307. ELSEIF (IKOK.GT.0) THEN
  308. X2=X1
  309. X3=BB2(ICC,IK)
  310. ELSE
  311. X2=BB2(ICC,IK)
  312. X3=X1
  313. ENDIF
  314. ENDIF
  315. *
  316. C COMPARAISON PROPREMENT DITE
  317. *
  318. * -----------------------------------------
  319. * SOIT ON VEUT UN MASQUE POINT PAR POINT...
  320. * -----------------------------------------
  321. *
  322. IF (ISOM.EQ.0) THEN
  323. *
  324. * MOT-CLE "SUPE"
  325. IF (ICLE.EQ.1) THEN
  326. IF (VPOCHA(IB,IC).GT.X2) THEN
  327. VPOCHA(IB,IC)=1.D0
  328. ELSE
  329. VPOCHA(IB,IC)=0.D0
  330. ENDIF
  331. *
  332. * MOT-CLE "EGSU"
  333. ELSEIF (ICLE.EQ.2) THEN
  334. IF (VPOCHA(IB,IC).GE.X2) THEN
  335. VPOCHA(IB,IC)=1.D0
  336. ELSE
  337. VPOCHA(IB,IC)=0.D0
  338. ENDIF
  339. *
  340. * MOT-CLE "EGAL"
  341. ELSEIF (ICLE.EQ.3) THEN
  342. IF (VPOCHA(IB,IC).EQ.X2) THEN
  343. VPOCHA(IB,IC)=1.D0
  344. ELSE
  345. VPOCHA(IB,IC)=0.D0
  346. ENDIF
  347. *
  348. * MOT-CLE "EGIN"
  349. ELSEIF (ICLE.EQ.4) THEN
  350. IF (VPOCHA(IB,IC).LE.X2) THEN
  351. VPOCHA(IB,IC)=1.D0
  352. ELSE
  353. VPOCHA(IB,IC)=0.D0
  354. ENDIF
  355. *
  356. * MOT-CLE "INFE"
  357. ELSEIF (ICLE.EQ.5) THEN
  358. IF (VPOCHA(IB,IC).LT.X2) THEN
  359. VPOCHA(IB,IC)=1.D0
  360. ELSE
  361. VPOCHA(IB,IC)=0.D0
  362. ENDIF
  363. *
  364. * MOT-CLE "DIFF"
  365. ELSEIF (ICLE.EQ.6) THEN
  366. IF (VPOCHA(IB,IC).NE.X2) THEN
  367. VPOCHA(IB,IC)=1.D0
  368. ELSE
  369. VPOCHA(IB,IC)=0.D0
  370. ENDIF
  371. *
  372. * MOT-CLE "COMP"
  373. ELSEIF (ICLE.EQ.7) THEN
  374. IF (VPOCHA(IB,IC).GE.X2.AND.VPOCHA(IB,IC).LE.X3) THEN
  375. VPOCHA(IB,IC)=1.D0
  376. ELSE
  377. VPOCHA(IB,IC)=0.D0
  378. ENDIF
  379. ENDIF
  380. *
  381. * -----------------------------------------
  382. * SOIT ON CHERCHE SEULEMENT LA SOMME...
  383. * -----------------------------------------
  384. ELSEIF(ISOM.EQ.1) THEN
  385. *
  386. * MOT-CLE "SUPE"
  387. IF (ICLE.EQ.1) THEN
  388. IF (VPOCHA(IB,IC).GT.X2) KSOM=KSOM+1
  389. *
  390. * MOT-CLE "EGSU"
  391. ELSEIF(ICLE.EQ.2) THEN
  392. IF (VPOCHA(IB,IC).GE.X2) KSOM=KSOM+1
  393. *
  394. * MOT-CLE "EGAL"
  395. ELSEIF(ICLE.EQ.3) THEN
  396. IF (VPOCHA(IB,IC).EQ.X2) KSOM=KSOM+1
  397. *
  398. * MOT-CLE "EGIN"
  399. ELSEIF(ICLE.EQ.4) THEN
  400. IF (VPOCHA(IB,IC).LE.X2) KSOM=KSOM+1
  401. *
  402. * MOT-CLE "INFE"
  403. ELSEIF(ICLE.EQ.5) THEN
  404. IF (VPOCHA(IB,IC).LT.X2) KSOM=KSOM+1
  405. *
  406. * MOT-CLE "DIFF"
  407. ELSEIF(ICLE.EQ.6) THEN
  408. IF (VPOCHA(IB,IC).NE.X2) KSOM=KSOM+1
  409. *
  410. * MOT-CLE "COMP"
  411. ELSEIF(ICLE.EQ.7) THEN
  412. IF (VPOCHA(IB,IC).GE.X2.AND.VPOCHA(IB,IC).LE.X3)
  413. & KSOM=KSOM+1
  414. ENDIF
  415. ENDIF
  416.  
  417. 80 CONTINUE
  418.  
  419. 70 CONTINUE
  420. SEGDES,MSOUPO,MPOVAL,MELEME
  421.  
  422. 60 CONTINUE
  423.  
  424. SEGDES,MCHPOI
  425.  
  426.  
  427. C-----------------------------------------------------------------------
  428. C NETTOYAGE ET FIN DE PROGRAMME
  429. C-----------------------------------------------------------------------
  430. C
  431.  
  432. SEGSUP MTRA,MTR1,MTR4,MTR2,MTR3
  433. IF (IKOK.EQ.0) SEGSUP,MTR5
  434.  
  435. IF (ISOM.EQ.1) THEN
  436. SEGSUP,MCHPOI
  437. IRET=KSOM
  438. ELSE
  439. IRET=ICHPOI
  440. ENDIF
  441.  
  442.  
  443. RETURN
  444. END
  445.  
  446.  
  447.  
  448.  
  449.  
  450.  
  451.  

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