Télécharger msche1.eso

Retour à la liste

Numérotation des lignes :

  1. C MSCHE1 SOURCE JC220346 16/12/15 21:15:04 9264
  2. SUBROUTINE MSCHE1(IPCHE2,IPCHE3,X1,IKO,IPCHE1,ICLE,IPCHMA,ISOM,
  3. & IRET)
  4. *****************************************************************
  5. * OPERATEUR MASQ
  6. *
  7. * ENTREES :
  8. * ---------
  9. * IPCHE1 :POINTEUR SUR LE PREMIER CHAMELEM
  10. * IPCHE2 :POINTEUR SUR UN SECOND CHAMELEM
  11. * IPCHE3 :POINTEUR SUR UN TROISIEME CHAMELEM (OPTION "COMP")
  12. * X1 :VALEUR MIN OU MAX (OPTION "COMP")
  13. * IKO :0 SI IPCHE2 PUIS IPCHE3
  14. * 1 SI X1 PUIS IPCHE2
  15. * -1 SI IPCHE2 PUIS X1
  16. * ICLE :ENTIER CARACTERISANT LE TYPE DE COMPARAISON
  17. * ISOM =1 SI ON VEUT LA SOMME
  18. * =0 SINON
  19. *
  20. * SORTIE :
  21. * --------
  22. * IPCHMA :- POINTEUR SUR LE CHAMELEM RESULTAT SI ISOM=0
  23. * - SOMME DES 1 ET DES 0 SI OPTION ISOM=1
  24. * IRET =1 OU 0 SUIVANT SUCCES OU PAS
  25. *
  26. * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 01/91
  27. *
  28. *****************************************************************
  29. IMPLICIT INTEGER(I-N)
  30. IMPLICIT REAL*8(A-H,O-Z)
  31.  
  32. -INC CCOPTIO
  33. -INC SMCHAML
  34. -INC SMLREEL
  35. -INC SMCOORD
  36. *
  37. CHARACTER*4 MOK
  38. CHARACTER*16 CONCH1,CONCH2,CONCH3
  39. CHARACTER*72 TIT1,TIT2,TIT3,TITC
  40. PARAMETER (NINF=3)
  41. INTEGER INFOS(NINF)
  42. *
  43. SEGMENT MTRAA
  44. INTEGER ITRAA(LX)
  45. ENDSEGMENT
  46. SEGMENT MTRAA2
  47. INTEGER ITRAA2(LX)
  48. ENDSEGMENT
  49. *
  50. IKOK=IKO
  51. IF (IKOK.EQ.0.AND.IPCHE3.LE.0) IKOK=-1
  52. *
  53. IRET = 0
  54. *
  55. * POUR INFERIEUR ,IDEM SUPERIEUR EN INVERSANT IPCHE1 ET IPCHE2
  56. *
  57. IF (ICLE.EQ.4.OR.ICLE.EQ.5) THEN
  58. IKKK=IPCHE2
  59. IPCHE2=IPCHE1
  60. IPCHE1=IKKK
  61. IF (ICLE.EQ.4) ICLE=2
  62. IF (ICLE.EQ.5) ICLE=1
  63. ENDIF
  64. *
  65. JPCHE1=IPCHE1
  66. JPCHE2=IPCHE2
  67. JPCHE3=IPCHE3
  68. *
  69. * ==========================================================
  70. * ON TESTE D'ABORD LA COMPATIBILITE ENTRE LES MCHAML FOURNIS
  71. * ==========================================================
  72.  
  73. MCHEL1 = IPCHE1
  74. MCHEL2 = IPCHE2
  75. SEGACT,MCHEL1,MCHEL2
  76.  
  77. IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
  78. CALL ERREUR(103)
  79. GOTO 666
  80. ENDIF
  81.  
  82. CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,iretou)
  83. IF (iretou.EQ.0) GOTO 666
  84. *
  85. * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  86. IPCHE1=JPCHE1
  87. IPCHE2=JPCHE2
  88. *
  89. IF (K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN
  90. CALL ERREUR(488)
  91. GOTO 666
  92. ENDIF
  93.  
  94. MCHEL1 = IPCHE1
  95. MCHEL2 = IPCHE2
  96. TIT1 = MCHEL1.TITCHE
  97. TIT2 = MCHEL2.TITCHE
  98. IF (K.EQ.5.AND.(TIT1.NE.TIT2) ) THEN
  99. CALL ERREUR(21)
  100. GOTO 666
  101. ENDIF
  102. NSOUS1 = MCHEL1.ICHAML(/1)
  103. NSOUS2 = MCHEL2.ICHAML(/1)
  104. IF (NSOUS1.NE.NSOUS2) THEN
  105. CALL ERREUR(103)
  106. GOTO 666
  107. ENDIF
  108. *
  109. * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2
  110. *
  111. LX=NSOUS1
  112. SEGINI MTRAA
  113. *
  114. DO 110 ISOUS1=1,NSOUS1
  115. IPMAI1=MCHEL1.IMACHE(ISOUS1)
  116. CONCH1=MCHEL1.CONCHE(ISOUS1)
  117. DO 120 ISOUS2=1,NSOUS2
  118. IPMAI2=MCHEL2.IMACHE(ISOUS2)
  119. CONCH2=MCHEL2.CONCHE(ISOUS2)
  120. IF (IPMAI1.NE.IPMAI2.OR.CONCH1.NE.CONCH2) GOTO 120
  121. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  122. IF (IRTD.EQ.0) GOTO 120
  123. *
  124. IMINT1=0
  125. IMINT2=0
  126. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  127. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  128. IF (IMINT1.EQ.IMINT2) GOTO 121
  129. *
  130. IMINT1=1
  131. IMINT2=1
  132. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  133. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  134. IF (IMINT1.EQ.0) IMINT1=1
  135. IF (IMINT2.EQ.0) IMINT2=1
  136. IF (IMINT1.EQ.IMINT2) GOTO 121
  137. *
  138. SEGSUP MTRAA
  139. *
  140. * ERREUR PAS DE CORRESPONDANCE 2 A 2
  141. *
  142. CALL ERREUR(103)
  143. GOTO 666
  144. *
  145. 120 CONTINUE
  146. *
  147. 121 CONTINUE
  148. ITRAA(ISOUS1)=ISOUS2
  149. GOTO 110
  150. 110 CONTINUE
  151.  
  152.  
  153. * SI BESOIN ON FAIT LES MEMES TESTS AVEC LE TROISIEME MCHAML
  154. * (OPTION "COMP")
  155. IF (IKOK.EQ.0) THEN
  156. MCHEL3 = IPCHE3
  157. SEGACT,MCHEL3
  158.  
  159. IF (MCHEL1.IFOCHE.NE.MCHEL3.IFOCHE) THEN
  160. CALL ERREUR(103)
  161. GOTO 666
  162. ENDIF
  163.  
  164. CALL CALPAQ(IPCHE1,IPCHE3,K,TITC,NUMCHA,iretou)
  165. IF (iretou.EQ.0) GOTO 666
  166. *
  167. * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  168. IPCHE1=JPCHE3
  169. IPCHE3=JPCHE3
  170. *
  171. IF (K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN
  172. CALL ERREUR(488)
  173. GOTO 666
  174. ENDIF
  175.  
  176. MCHEL3 = IPCHE3
  177. TIT3 = MCHEL3.TITCHE
  178. IF (K.EQ.5.AND.(TIT1.NE.TIT3) ) THEN
  179. CALL ERREUR(21)
  180. GOTO 666
  181. ENDIF
  182. NSOUS3 = MCHEL3.ICHAML(/1)
  183. IF (NSOUS1.NE.NSOUS3) THEN
  184. CALL ERREUR(103)
  185. GOTO 666
  186. ENDIF
  187.  
  188. LX=NSOUS1
  189. SEGINI MTRAA2
  190. DO 150 ISOUS1=1,NSOUS1
  191. IPMAI1=MCHEL1.IMACHE(ISOUS1)
  192. CONCH1=MCHEL1.CONCHE(ISOUS1)
  193. DO 160 ISOUS3=1,NSOUS3
  194. IPMAI3=MCHEL3.IMACHE(ISOUS3)
  195. CONCH3=MCHEL3.CONCHE(ISOUS3)
  196. IF (IPMAI1.NE.IPMAI3.OR.CONCH1.NE.CONCH3) GOTO 160
  197. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE3,INFOS,IRTD)
  198. IF (IRTD.EQ.0) GOTO 160
  199. *
  200. IMINT1=0
  201. IMINT3=0
  202. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  203. IF (MCHEL3.INFCHE(/2).GE.4) IMINT3=MCHEL3.INFCHE(ISOUS3,4)
  204. IF (IMINT1.EQ.IMINT3) GOTO 151
  205. *
  206. IMINT1=1
  207. IMINT3=1
  208. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  209. IF (MCHEL3.INFCHE(/2).GE.6) IMINT3=MCHEL3.INFCHE(ISOUS3,6)
  210. IF (IMINT1.EQ.0) IMINT1=1
  211. IF (IMINT3.EQ.0) IMINT3=1
  212. IF (IMINT1.EQ.IMINT3) GOTO 151
  213. *
  214. SEGSUP MTRAA2
  215. *
  216. * ERREUR PAS DE CORRESPONDANCE 2 A 2
  217. *
  218. CALL ERREUR(103)
  219. GOTO 666
  220. *
  221. 160 CONTINUE
  222. *
  223. 151 CONTINUE
  224. ITRAA2(ISOUS1)=ISOUS3
  225. GOTO 150
  226. 150 CONTINUE
  227.  
  228. ENDIF
  229.  
  230. * ======================================
  231. * ON FAIT LA COMPARAISON PROPREMENT DITE
  232. * ======================================
  233.  
  234. KSOM=0
  235. NSOUS=NSOUS1
  236. N1=NSOUS
  237. N3=MCHEL1.INFCHE(/2)
  238. L1=MCHEL1.TITCHE(/1)
  239. SEGINI MCHELM
  240. IPCHMA=MCHELM
  241. IFOCHE=MCHEL1.IFOCHE
  242. TITCHE=TIT1
  243. *
  244. * BOUCLE SUR LES SOUS PAQUETS DE MCHELM
  245. *
  246. DO 200 ISOUS=1,NSOUS
  247. DO 201 N33=1,N3
  248. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  249. 201 CONTINUE
  250. IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  251. CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  252. *
  253. ISOUS2=ITRAA(ISOUS)
  254. *
  255. MCHAM1=MCHEL1.ICHAML(ISOUS )
  256. MCHAM2=MCHEL2.ICHAML(ISOUS2)
  257. SEGACT MCHAM1,MCHAM2
  258.  
  259. IF (IKOK.EQ.0) THEN
  260. ISOUS3=ITRAA2(ISOUS)
  261. MCHAM3=MCHEL3.ICHAML(ISOUS3)
  262. SEGACT MCHAM3
  263. ENDIF
  264. *
  265. NCOMP=MCHAM1.IELVAL(/1)
  266. N2=NCOMP
  267. SEGINI MCHAML
  268. ICHAML(ISOUS)=MCHAML
  269. DO 300 ICOMP=1,NCOMP
  270. CALL PLACE ( MCHAM2.NOMCHE,MCHAM2.IELVAL(/1),IPLAC,
  271. & MCHAM1.NOMCHE(ICOMP) )
  272. *
  273. IF (IPLAC.EQ.0) THEN
  274. MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  275. MOTERR(5:8)=TIT1(1:4)
  276. CALL ERREUR(77)
  277. SEGSUP MCHAML,MCHELM,MTRAA
  278. SEGDES MCHAM1,MCHAM2
  279. GOTO 666
  280. ENDIF
  281.  
  282. NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP)
  283. TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP)
  284. *
  285. MELVA1=MCHAM1.IELVAL(ICOMP)
  286. MELVA2=MCHAM2.IELVAL(IPLAC)
  287. SEGACT MELVA1,MELVA2
  288. *
  289. IF (IKOK.EQ.0) THEN
  290. CALL PLACE ( MCHAM3.NOMCHE,MCHAM3.IELVAL(/1),IPLAC2,
  291. & MCHAM1.NOMCHE(ICOMP) )
  292. *
  293. IF (IPLAC2.EQ.0) THEN
  294. MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  295. MOTERR(5:8)=TIT1(1:4)
  296. CALL ERREUR(77)
  297. SEGSUP MCHAML,MCHELM,MTRAA
  298. SEGDES MCHAM1,MCHAM2,MCHAM3
  299. GOTO 666
  300. ENDIF
  301. *
  302. MELVA3=MCHAM3.IELVAL(IPLAC2)
  303. SEGACT MELVA3
  304. ENDIF
  305. *
  306. IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8') THEN
  307. NBPTE1=MELVA1.VELCHE(/1)
  308. NEL1 =MELVA1.VELCHE(/2)
  309. NBPTE2=MELVA2.VELCHE(/1)
  310. NEL2 =MELVA2.VELCHE(/2)
  311. NBPGAU=MAX(NBPTE1,NBPTE2)
  312. NBELEM=MAX(NEL1,NEL2)
  313. IF (IKOK.EQ.0) THEN
  314. NBPTE3=MELVA3.VELCHE(/1)
  315. NEL3 =MELVA3.VELCHE(/2)
  316. NBPGAU=MAX(NBPTE1,NBPTE3)
  317. NBELEM=MAX(NEL1,NEL3)
  318. ENDIF
  319. *
  320. N2PTEL=0
  321. N2EL =0
  322. N1PTEL=NBPGAU
  323. N1EL =NBELEM
  324. *
  325. IML=0
  326. ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  327. NBPTE1=MELVA1.IELCHE(/1)
  328. NEL1 =MELVA1.IELCHE(/2)
  329. NBPTE2=MELVA2.IELCHE(/1)
  330. NEL2 =MELVA2.IELCHE(/2)
  331. NBPGAU=MAX(NBPTE1,NBPTE2)
  332. NBELEM=MAX(NEL1,NEL2)
  333. IF (IKOK.EQ.0) THEN
  334. NBPTE3=MELVA3.VELCHE(/1)
  335. NEL3 =MELVA3.VELCHE(/2)
  336. NBPGAU=MAX(NBPTE1,NBPTE3)
  337. NBELEM=MAX(NEL1,NEL3)
  338. ENDIF
  339. *
  340. N1PTEL=0
  341. N1EL =0
  342. N2PTEL=NBPGAU
  343. N2EL =NBELEM
  344. *
  345. IML=1
  346. ELSE
  347. *
  348. * COMPOSANTE NON RECONNUE
  349. *
  350. MOTERR (1:4)=MCHAM1.NOMCHE(ICOMP)
  351. CALL ERREUR (197)
  352. SEGSUP MCHAML,MCHELM,MTRAA
  353. SEGDES MCHAM1,MCHAM2
  354. GOTO 666
  355. ENDIF
  356. SEGINI MELVAL
  357. IELVAL(ICOMP)=MELVAL
  358. *
  359. * MOT-CLE "SUPE" OU "INFE"
  360. IF (ICLE.EQ.1) THEN
  361. DO 331 IGAU=1,NBPGAU
  362. IGMN1=MIN(IGAU,NBPTE1)
  363. IGMN2=MIN(IGAU,NBPTE2)
  364. DO 331 IB=1,NBELEM
  365. IBMN1=MIN(IB,NEL1)
  366. IBMN2=MIN(IB,NEL2)
  367. IF (IML.EQ.0) THEN
  368. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  369. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  370. IF (XTT1.GT.XTT2) THEN
  371. VELCHE(IGAU,IB)=1.D0
  372. KSOM=KSOM+1
  373. ENDIF
  374. ELSE
  375. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  376. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  377. SEGACT MLREE1,MLREE2
  378. IPRO1=MLREE1.PROG(/1)
  379. IPRO2=MLREE2.PROG(/1)
  380. JG=MAX(IPRO1,IPRO2)
  381. *
  382. SEGINI MLREEL
  383. *
  384. DO 302 IPROG=1,JG
  385. IPMN1=MIN(IPRO1,IPROG)
  386. IPMN2=MIN(IPRO2,IPROG)
  387. XTT1=MLREE1.PROG(IPMN1)
  388. XTT2=MLREE2.PROG(IPMN2)
  389. IF (XTT1.GT.XTT2) THEN
  390. PROG(IPROG)=1.D0
  391. KSOM=KSOM+1
  392. ENDIF
  393. 302 CONTINUE
  394. IELCHE(IGAU,IB)=MLREEL
  395. SEGDES MLREEL
  396. SEGDES MLREE1,MLREE2
  397. ENDIF
  398. 331 CONTINUE
  399. *
  400. * MOT-CLE "EGSU" OU "EGIN"
  401. ELSEIF (ICLE.EQ.2) THEN
  402. DO 332 IGAU=1,NBPGAU
  403. IGMN1=MIN(IGAU,NBPTE1)
  404. IGMN2=MIN(IGAU,NBPTE2)
  405. DO 332 IB=1,NBELEM
  406. IBMN1=MIN(IB,NEL1)
  407. IBMN2=MIN(IB,NEL2)
  408. IF (IML.EQ.0) THEN
  409. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  410. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  411. IF (XTT1.GE.XTT2) THEN
  412. VELCHE(IGAU,IB)=1.D0
  413. KSOM=KSOM+1
  414. ENDIF
  415. ELSE
  416. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  417. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  418. SEGACT MLREE1,MLREE2
  419. IPRO1=MLREE1.PROG(/1)
  420. IPRO2=MLREE2.PROG(/1)
  421. JG=MAX(IPRO1,IPRO2)
  422. *
  423. SEGINI MLREEL
  424. *
  425. DO 303 IPROG=1,JG
  426. IPMN1=MIN(IPRO1,IPROG)
  427. IPMN2=MIN(IPRO2,IPROG)
  428. XTT1=MLREE1.PROG(IPMN1)
  429. XTT2=MLREE2.PROG(IPMN2)
  430. IF (XTT1.GE.XTT2) THEN
  431. PROG(IPROG)=1.D0
  432. KSOM=KSOM+1
  433. ENDIF
  434. 303 CONTINUE
  435. IELCHE(IGAU,IB)=MLREEL
  436. SEGDES MLREEL
  437. SEGDES MLREE1,MLREE2
  438. ENDIF
  439. 332 CONTINUE
  440. *
  441. * MOT-CLE "EGAL"
  442. ELSEIF (ICLE.EQ.3) THEN
  443. DO 333 IGAU=1,NBPGAU
  444. IGMN1=MIN(IGAU,NBPTE1)
  445. IGMN2=MIN(IGAU,NBPTE2)
  446. DO 333 IB=1,NBELEM
  447. IBMN1=MIN(IB,NEL1)
  448. IBMN2=MIN(IB,NEL2)
  449. IF (IML.EQ.0) THEN
  450. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  451. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  452. IF (XTT1.EQ.XTT2) THEN
  453. VELCHE(IGAU,IB)=1.D0
  454. KSOM=KSOM+1
  455. ENDIF
  456. ELSE
  457. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  458. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  459. SEGACT MLREE1,MLREE2
  460. IPRO1=MLREE1.PROG(/1)
  461. IPRO2=MLREE2.PROG(/1)
  462. JG=MAX(IPRO1,IPRO2)
  463. *
  464. SEGINI MLREEL
  465. *
  466. DO 304 IPROG=1,JG
  467. IPMN1=MIN(IPRO1,IPROG)
  468. IPMN2=MIN(IPRO2,IPROG)
  469. XTT1=MLREE1.PROG(IPMN1)
  470. XTT2=MLREE2.PROG(IPMN2)
  471. IF (XTT1.EQ.XTT2) THEN
  472. PROG(IPROG)=1.D0
  473. KSOM=KSOM+1
  474. ENDIF
  475. 304 CONTINUE
  476. IELCHE(IGAU,IB)=MLREEL
  477. SEGDES MLREEL
  478. SEGDES MLREE1,MLREE2
  479. ENDIF
  480. 333 CONTINUE
  481. *
  482. * MOT-CLE "DIFF"
  483. ELSEIF (ICLE.EQ.6) THEN
  484. DO 336 IGAU=1,NBPGAU
  485. IGMN1=MIN(IGAU,NBPTE1)
  486. IGMN2=MIN(IGAU,NBPTE2)
  487. DO 336 IB=1,NBELEM
  488. IBMN1=MIN(IB,NEL1)
  489. IBMN2=MIN(IB,NEL2)
  490. IF (IML.EQ.0) THEN
  491. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  492. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  493. IF (XTT1.NE.XTT2) THEN
  494. VELCHE(IGAU,IB)=1.D0
  495. KSOM=KSOM+1
  496. ENDIF
  497. ELSE
  498. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  499. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  500. SEGACT MLREE1,MLREE2
  501. IPRO1=MLREE1.PROG(/1)
  502. IPRO2=MLREE2.PROG(/1)
  503. JG=MAX(IPRO1,IPRO2)
  504. *
  505. SEGINI MLREEL
  506. *
  507. DO 305 IPROG=1,JG
  508. IPMN1=MIN(IPRO1,IPROG)
  509. IPMN2=MIN(IPRO2,IPROG)
  510. XTT1=MLREE1.PROG(IPMN1)
  511. XTT2=MLREE2.PROG(IPMN2)
  512. IF (XTT1.NE.XTT2) THEN
  513. PROG(IPROG)=1.D0
  514. KSOM=KSOM+1
  515. ENDIF
  516. 305 CONTINUE
  517. IELCHE(IGAU,IB)=MLREEL
  518. SEGDES MLREEL
  519. SEGDES MLREE1,MLREE2
  520. ENDIF
  521. 336 CONTINUE
  522. *
  523. * MOT-CLE "COMP"
  524. ELSEIF (ICLE.EQ.7) THEN
  525. IF (IKOK.EQ.0) THEN
  526. DO 337 IGAU=1,NBPGAU
  527. IGMN1=MIN(IGAU,NBPTE1)
  528. IGMN2=MIN(IGAU,NBPTE2)
  529. IGMN3=MIN(IGAU,NBPTE3)
  530. DO 337 IB=1,NBELEM
  531. IBMN1=MIN(IB,NEL1)
  532. IBMN2=MIN(IB,NEL2)
  533. IBMN3=MIN(IB,NEL3)
  534. IF (IML.EQ.0) THEN
  535. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  536. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  537. XTT3 =MELVA3.VELCHE(IGMN3,IBMN3)
  538. IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  539. VELCHE(IGAU,IB)=1.D0
  540. KSOM=KSOM+1
  541. ENDIF
  542. ELSE
  543. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  544. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  545. MLREE3=MELVA3.IELCHE(IGMN3,IBMN3)
  546. SEGACT MLREE1,MLREE2,MLREE3
  547. IPRO1=MLREE1.PROG(/1)
  548. IPRO2=MLREE2.PROG(/1)
  549. IPRO3=MLREE3.PROG(/1)
  550. JG=MAX(IPRO1,IPRO2,IPRO3)
  551. *
  552. SEGINI MLREEL
  553. *
  554. DO 306 IPROG=1,JG
  555. IPMN1=MIN(IPRO1,IPROG)
  556. IPMN2=MIN(IPRO2,IPROG)
  557. IPMN3=MIN(IPRO3,IPROG)
  558. XTT1=MLREE1.PROG(IPMN1)
  559. XTT2=MLREE2.PROG(IPMN2)
  560. XTT3=MLREE3.PROG(IPMN3)
  561. IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  562. PROG(IPROG)=1.D0
  563. KSOM=KSOM+1
  564. ENDIF
  565. 306 CONTINUE
  566. IELCHE(IGAU,IB)=MLREEL
  567. SEGDES MLREEL
  568. SEGDES MLREE1,MLREE2,MLREE3
  569. ENDIF
  570. 337 CONTINUE
  571. ELSEIF (IKOK.GT.0) THEN
  572. DO 338 IGAU=1,NBPGAU
  573. IGMN1=MIN(IGAU,NBPTE1)
  574. IGMN2=MIN(IGAU,NBPTE2)
  575. DO 338 IB=1,NBELEM
  576. IBMN1=MIN(IB,NEL1)
  577. IBMN2=MIN(IB,NEL2)
  578. IF (IML.EQ.0) THEN
  579. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  580. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  581. IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  582. VELCHE(IGAU,IB)=1.D0
  583. KSOM=KSOM+1
  584. ENDIF
  585. ELSE
  586. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  587. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  588. SEGACT MLREE1,MLREE2
  589. IPRO1=MLREE1.PROG(/1)
  590. IPRO2=MLREE2.PROG(/1)
  591. JG=MAX(IPRO1,IPRO2)
  592. *
  593. SEGINI MLREEL
  594. *
  595. DO 307 IPROG=1,JG
  596. IPMN1=MIN(IPRO1,IPROG)
  597. IPMN2=MIN(IPRO2,IPROG)
  598. XTT1=MLREE1.PROG(IPMN1)
  599. XTT2=MLREE2.PROG(IPMN2)
  600. IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  601. PROG(IPROG)=1.D0
  602. KSOM=KSOM+1
  603. ENDIF
  604. 307 CONTINUE
  605. IELCHE(IGAU,IB)=MLREEL
  606. SEGDES MLREEL
  607. SEGDES MLREE1,MLREE2
  608. ENDIF
  609. 338 CONTINUE
  610. ELSE
  611. DO 339 IGAU=1,NBPGAU
  612. IGMN1=MIN(IGAU,NBPTE1)
  613. IGMN2=MIN(IGAU,NBPTE2)
  614. DO 339 IB=1,NBELEM
  615. IBMN1=MIN(IB,NEL1)
  616. IBMN2=MIN(IB,NEL2)
  617. IF (IML.EQ.0) THEN
  618. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  619. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  620. IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  621. VELCHE(IGAU,IB)=1.D0
  622. KSOM=KSOM+1
  623. ENDIF
  624. ELSE
  625. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  626. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  627. SEGACT MLREE1,MLREE2
  628. IPRO1=MLREE1.PROG(/1)
  629. IPRO2=MLREE2.PROG(/1)
  630. JG=MAX(IPRO1,IPRO2)
  631. *
  632. SEGINI MLREEL
  633. *
  634. DO 308 IPROG=1,JG
  635. IPMN1=MIN(IPRO1,IPROG)
  636. IPMN2=MIN(IPRO2,IPROG)
  637. XTT1=MLREE1.PROG(IPMN1)
  638. XTT2=MLREE2.PROG(IPMN2)
  639. IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  640. PROG(IPROG)=1.D0
  641. KSOM=KSOM+1
  642. ENDIF
  643. 308 CONTINUE
  644. IELCHE(IGAU,IB)=MLREEL
  645. SEGDES MLREEL
  646. SEGDES MLREE1,MLREE2
  647. ENDIF
  648. 339 CONTINUE
  649. ENDIF
  650.  
  651. ENDIF
  652.  
  653. SEGDES MELVA1,MELVA2
  654. IF (IKOK.EQ.0) SEGDES MELVA3
  655. SEGDES MELVAL
  656. 300 CONTINUE
  657. SEGDES MCHAM1,MCHAM2
  658. IF (IKOK.EQ.0) SEGDES MCHAM3
  659. SEGDES MCHAML
  660. 200 CONTINUE
  661. SEGDES MCHELM
  662. *
  663. * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1
  664. * DESACTIVATON DES SEGMENTS
  665. *
  666. SEGSUP MTRAA
  667. IF (IKOK.EQ.0) SEGSUP MTRAA2
  668. IF (ISOM.EQ.1) THEN
  669. CALL DTCHAM(IPCHMA)
  670. IPCHMA=KSOM
  671. ENDIF
  672. IRET = 1
  673.  
  674. 666 CONTINUE
  675. SEGDES,MCHEL1,MCHEL2
  676. IF (IKOK.EQ.0) SEGDES,MCHEL3
  677.  
  678. RETURN
  679. END
  680.  
  681.  
  682.  
  683.  
  684.  

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