Télécharger msche1.eso

Retour à la liste

Numérotation des lignes :

  1. C MSCHE1 SOURCE PV 20/04/28 21:15:15 10593
  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.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC SMCHAML
  36. -INC SMLREEL
  37. -INC SMCOORD
  38. *
  39. CHARACTER*4 MOK
  40. CHARACTER*16 CONCH1,CONCH2,CONCH3
  41. CHARACTER*72 TIT1,TIT2,TIT3,TITC
  42. PARAMETER (NINF=3)
  43. INTEGER INFOS(NINF)
  44. *
  45. SEGMENT MTRAA
  46. INTEGER ITRAA(LX)
  47. ENDSEGMENT
  48. SEGMENT MTRAA2
  49. INTEGER ITRAA2(LX)
  50. ENDSEGMENT
  51. *
  52. IKOK=IKO
  53. IF (IKOK.EQ.0.AND.IPCHE3.LE.0) IKOK=-1
  54. *
  55. IRET = 0
  56. *
  57. * POUR INFERIEUR ,IDEM SUPERIEUR EN INVERSANT IPCHE1 ET IPCHE2
  58. *
  59. IF (ICLE.EQ.4.OR.ICLE.EQ.5) THEN
  60. IKKK=IPCHE2
  61. IPCHE2=IPCHE1
  62. IPCHE1=IKKK
  63. IF (ICLE.EQ.4) ICLE=2
  64. IF (ICLE.EQ.5) ICLE=1
  65. ENDIF
  66. *
  67. JPCHE1=IPCHE1
  68. JPCHE2=IPCHE2
  69. JPCHE3=IPCHE3
  70. *
  71. * ==========================================================
  72. * ON TESTE D'ABORD LA COMPATIBILITE ENTRE LES MCHAML FOURNIS
  73. * ==========================================================
  74.  
  75. MCHEL1 = IPCHE1
  76. MCHEL2 = IPCHE2
  77.  
  78. IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
  79. CALL ERREUR(103)
  80. GOTO 666
  81. ENDIF
  82.  
  83. CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,iretou)
  84. IF (iretou.EQ.0) GOTO 666
  85. *
  86. * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  87. IPCHE1=JPCHE1
  88. IPCHE2=JPCHE2
  89. *
  90. IF (K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN
  91. CALL ERREUR(488)
  92. GOTO 666
  93. ENDIF
  94.  
  95. MCHEL1 = IPCHE1
  96. MCHEL2 = IPCHE2
  97. TIT1 = MCHEL1.TITCHE
  98. TIT2 = MCHEL2.TITCHE
  99. IF (K.EQ.5.AND.(TIT1.NE.TIT2) ) THEN
  100. CALL ERREUR(21)
  101. GOTO 666
  102. ENDIF
  103. NSOUS1 = MCHEL1.ICHAML(/1)
  104. NSOUS2 = MCHEL2.ICHAML(/1)
  105. IF (NSOUS1.NE.NSOUS2) THEN
  106. CALL ERREUR(103)
  107. GOTO 666
  108. ENDIF
  109. *
  110. * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2
  111. *
  112. LX=NSOUS1
  113. SEGINI MTRAA
  114. *
  115. DO 110 ISOUS1=1,NSOUS1
  116. IPMAI1=MCHEL1.IMACHE(ISOUS1)
  117. CONCH1=MCHEL1.CONCHE(ISOUS1)
  118. DO 120 ISOUS2=1,NSOUS2
  119. IPMAI2=MCHEL2.IMACHE(ISOUS2)
  120. CONCH2=MCHEL2.CONCHE(ISOUS2)
  121. IF (IPMAI1.NE.IPMAI2.OR.CONCH1.NE.CONCH2) GOTO 120
  122. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  123. IF (IRTD.EQ.0) GOTO 120
  124. *
  125. IMINT1=0
  126. IMINT2=0
  127. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  128. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  129. IF (IMINT1.EQ.IMINT2) GOTO 121
  130. *
  131. IMINT1=1
  132. IMINT2=1
  133. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  134. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  135. IF (IMINT1.EQ.0) IMINT1=1
  136. IF (IMINT2.EQ.0) IMINT2=1
  137. IF (IMINT1.EQ.IMINT2) GOTO 121
  138. *
  139. SEGSUP MTRAA
  140. *
  141. * ERREUR PAS DE CORRESPONDANCE 2 A 2
  142. *
  143. CALL ERREUR(103)
  144. GOTO 666
  145. *
  146. 120 CONTINUE
  147. *
  148. 121 CONTINUE
  149. ITRAA(ISOUS1)=ISOUS2
  150. GOTO 110
  151. 110 CONTINUE
  152.  
  153.  
  154. * SI BESOIN ON FAIT LES MEMES TESTS AVEC LE TROISIEME MCHAML
  155. * (OPTION "COMP")
  156. IF (IKOK.EQ.0) THEN
  157. MCHEL3 = IPCHE3
  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.  
  258. IF (IKOK.EQ.0) THEN
  259. ISOUS3=ITRAA2(ISOUS)
  260. MCHAM3=MCHEL3.ICHAML(ISOUS3)
  261. ENDIF
  262. *
  263. NCOMP=MCHAM1.IELVAL(/1)
  264. N2=NCOMP
  265. SEGINI MCHAML
  266. ICHAML(ISOUS)=MCHAML
  267. DO 300 ICOMP=1,NCOMP
  268. CALL PLACE ( MCHAM2.NOMCHE,MCHAM2.IELVAL(/1),IPLAC,
  269. & MCHAM1.NOMCHE(ICOMP) )
  270. *
  271. IF (IPLAC.EQ.0) THEN
  272. MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  273. MOTERR(5:8)=TIT1(1:4)
  274. CALL ERREUR(77)
  275. SEGSUP MCHAML,MCHELM,MTRAA
  276. GOTO 666
  277. ENDIF
  278.  
  279. NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP)
  280. TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP)
  281. *
  282. MELVA1=MCHAM1.IELVAL(ICOMP)
  283. MELVA2=MCHAM2.IELVAL(IPLAC)
  284. *
  285. IF (IKOK.EQ.0) THEN
  286. CALL PLACE ( MCHAM3.NOMCHE,MCHAM3.IELVAL(/1),IPLAC2,
  287. & MCHAM1.NOMCHE(ICOMP) )
  288. *
  289. IF (IPLAC2.EQ.0) THEN
  290. MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  291. MOTERR(5:8)=TIT1(1:4)
  292. CALL ERREUR(77)
  293. SEGSUP MCHAML,MCHELM,MTRAA
  294. GOTO 666
  295. ENDIF
  296. *
  297. MELVA3=MCHAM3.IELVAL(IPLAC2)
  298. ENDIF
  299. *
  300. IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8') THEN
  301. NBPTE1=MELVA1.VELCHE(/1)
  302. NEL1 =MELVA1.VELCHE(/2)
  303. NBPTE2=MELVA2.VELCHE(/1)
  304. NEL2 =MELVA2.VELCHE(/2)
  305. NBPGAU=MAX(NBPTE1,NBPTE2)
  306. NBELEM=MAX(NEL1,NEL2)
  307. IF (IKOK.EQ.0) THEN
  308. NBPTE3=MELVA3.VELCHE(/1)
  309. NEL3 =MELVA3.VELCHE(/2)
  310. NBPGAU=MAX(NBPTE1,NBPTE3)
  311. NBELEM=MAX(NEL1,NEL3)
  312. ENDIF
  313. *
  314. N2PTEL=0
  315. N2EL =0
  316. N1PTEL=NBPGAU
  317. N1EL =NBELEM
  318. *
  319. IML=0
  320. ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  321. NBPTE1=MELVA1.IELCHE(/1)
  322. NEL1 =MELVA1.IELCHE(/2)
  323. NBPTE2=MELVA2.IELCHE(/1)
  324. NEL2 =MELVA2.IELCHE(/2)
  325. NBPGAU=MAX(NBPTE1,NBPTE2)
  326. NBELEM=MAX(NEL1,NEL2)
  327. IF (IKOK.EQ.0) THEN
  328. NBPTE3=MELVA3.VELCHE(/1)
  329. NEL3 =MELVA3.VELCHE(/2)
  330. NBPGAU=MAX(NBPTE1,NBPTE3)
  331. NBELEM=MAX(NEL1,NEL3)
  332. ENDIF
  333. *
  334. N1PTEL=0
  335. N1EL =0
  336. N2PTEL=NBPGAU
  337. N2EL =NBELEM
  338. *
  339. IML=1
  340. ELSE
  341. *
  342. * COMPOSANTE NON RECONNUE
  343. *
  344. MOTERR (1:4)=MCHAM1.NOMCHE(ICOMP)
  345. CALL ERREUR (197)
  346. SEGSUP MCHAML,MCHELM,MTRAA
  347. GOTO 666
  348. ENDIF
  349. SEGINI MELVAL
  350. IELVAL(ICOMP)=MELVAL
  351. *
  352. * MOT-CLE "SUPE" OU "INFE"
  353. IF (ICLE.EQ.1) THEN
  354. DO 331 IGAU=1,NBPGAU
  355. IGMN1=MIN(IGAU,NBPTE1)
  356. IGMN2=MIN(IGAU,NBPTE2)
  357. DO 331 IB=1,NBELEM
  358. IBMN1=MIN(IB,NEL1)
  359. IBMN2=MIN(IB,NEL2)
  360. IF (IML.EQ.0) THEN
  361. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  362. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  363. IF (XTT1.GT.XTT2) THEN
  364. VELCHE(IGAU,IB)=1.D0
  365. KSOM=KSOM+1
  366. ENDIF
  367. ELSE
  368. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  369. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  370. IPRO1=MLREE1.PROG(/1)
  371. IPRO2=MLREE2.PROG(/1)
  372. JG=MAX(IPRO1,IPRO2)
  373. *
  374. SEGINI MLREEL
  375. *
  376. DO 302 IPROG=1,JG
  377. IPMN1=MIN(IPRO1,IPROG)
  378. IPMN2=MIN(IPRO2,IPROG)
  379. XTT1=MLREE1.PROG(IPMN1)
  380. XTT2=MLREE2.PROG(IPMN2)
  381. IF (XTT1.GT.XTT2) THEN
  382. PROG(IPROG)=1.D0
  383. KSOM=KSOM+1
  384. ENDIF
  385. 302 CONTINUE
  386. IELCHE(IGAU,IB)=MLREEL
  387. ENDIF
  388. 331 CONTINUE
  389. *
  390. * MOT-CLE "EGSU" OU "EGIN"
  391. ELSEIF (ICLE.EQ.2) THEN
  392. DO 332 IGAU=1,NBPGAU
  393. IGMN1=MIN(IGAU,NBPTE1)
  394. IGMN2=MIN(IGAU,NBPTE2)
  395. DO 332 IB=1,NBELEM
  396. IBMN1=MIN(IB,NEL1)
  397. IBMN2=MIN(IB,NEL2)
  398. IF (IML.EQ.0) THEN
  399. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  400. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  401. IF (XTT1.GE.XTT2) THEN
  402. VELCHE(IGAU,IB)=1.D0
  403. KSOM=KSOM+1
  404. ENDIF
  405. ELSE
  406. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  407. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  408. IPRO1=MLREE1.PROG(/1)
  409. IPRO2=MLREE2.PROG(/1)
  410. JG=MAX(IPRO1,IPRO2)
  411. *
  412. SEGINI MLREEL
  413. *
  414. DO 303 IPROG=1,JG
  415. IPMN1=MIN(IPRO1,IPROG)
  416. IPMN2=MIN(IPRO2,IPROG)
  417. XTT1=MLREE1.PROG(IPMN1)
  418. XTT2=MLREE2.PROG(IPMN2)
  419. IF (XTT1.GE.XTT2) THEN
  420. PROG(IPROG)=1.D0
  421. KSOM=KSOM+1
  422. ENDIF
  423. 303 CONTINUE
  424. IELCHE(IGAU,IB)=MLREEL
  425. ENDIF
  426. 332 CONTINUE
  427. *
  428. * MOT-CLE "EGAL"
  429. ELSEIF (ICLE.EQ.3) THEN
  430. DO 333 IGAU=1,NBPGAU
  431. IGMN1=MIN(IGAU,NBPTE1)
  432. IGMN2=MIN(IGAU,NBPTE2)
  433. DO 333 IB=1,NBELEM
  434. IBMN1=MIN(IB,NEL1)
  435. IBMN2=MIN(IB,NEL2)
  436. IF (IML.EQ.0) THEN
  437. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  438. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  439. IF (XTT1.EQ.XTT2) THEN
  440. VELCHE(IGAU,IB)=1.D0
  441. KSOM=KSOM+1
  442. ENDIF
  443. ELSE
  444. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  445. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  446. IPRO1=MLREE1.PROG(/1)
  447. IPRO2=MLREE2.PROG(/1)
  448. JG=MAX(IPRO1,IPRO2)
  449. *
  450. SEGINI MLREEL
  451. *
  452. DO 304 IPROG=1,JG
  453. IPMN1=MIN(IPRO1,IPROG)
  454. IPMN2=MIN(IPRO2,IPROG)
  455. XTT1=MLREE1.PROG(IPMN1)
  456. XTT2=MLREE2.PROG(IPMN2)
  457. IF (XTT1.EQ.XTT2) THEN
  458. PROG(IPROG)=1.D0
  459. KSOM=KSOM+1
  460. ENDIF
  461. 304 CONTINUE
  462. IELCHE(IGAU,IB)=MLREEL
  463. ENDIF
  464. 333 CONTINUE
  465. *
  466. * MOT-CLE "DIFF"
  467. ELSEIF (ICLE.EQ.6) THEN
  468. DO 336 IGAU=1,NBPGAU
  469. IGMN1=MIN(IGAU,NBPTE1)
  470. IGMN2=MIN(IGAU,NBPTE2)
  471. DO 336 IB=1,NBELEM
  472. IBMN1=MIN(IB,NEL1)
  473. IBMN2=MIN(IB,NEL2)
  474. IF (IML.EQ.0) THEN
  475. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  476. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  477. IF (XTT1.NE.XTT2) THEN
  478. VELCHE(IGAU,IB)=1.D0
  479. KSOM=KSOM+1
  480. ENDIF
  481. ELSE
  482. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  483. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  484. IPRO1=MLREE1.PROG(/1)
  485. IPRO2=MLREE2.PROG(/1)
  486. JG=MAX(IPRO1,IPRO2)
  487. *
  488. SEGINI MLREEL
  489. *
  490. DO 305 IPROG=1,JG
  491. IPMN1=MIN(IPRO1,IPROG)
  492. IPMN2=MIN(IPRO2,IPROG)
  493. XTT1=MLREE1.PROG(IPMN1)
  494. XTT2=MLREE2.PROG(IPMN2)
  495. IF (XTT1.NE.XTT2) THEN
  496. PROG(IPROG)=1.D0
  497. KSOM=KSOM+1
  498. ENDIF
  499. 305 CONTINUE
  500. IELCHE(IGAU,IB)=MLREEL
  501. ENDIF
  502. 336 CONTINUE
  503. *
  504. * MOT-CLE "COMP"
  505. ELSEIF (ICLE.EQ.7) THEN
  506. IF (IKOK.EQ.0) THEN
  507. DO 337 IGAU=1,NBPGAU
  508. IGMN1=MIN(IGAU,NBPTE1)
  509. IGMN2=MIN(IGAU,NBPTE2)
  510. IGMN3=MIN(IGAU,NBPTE3)
  511. DO 337 IB=1,NBELEM
  512. IBMN1=MIN(IB,NEL1)
  513. IBMN2=MIN(IB,NEL2)
  514. IBMN3=MIN(IB,NEL3)
  515. IF (IML.EQ.0) THEN
  516. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  517. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  518. XTT3 =MELVA3.VELCHE(IGMN3,IBMN3)
  519. IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  520. VELCHE(IGAU,IB)=1.D0
  521. KSOM=KSOM+1
  522. ENDIF
  523. ELSE
  524. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  525. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  526. MLREE3=MELVA3.IELCHE(IGMN3,IBMN3)
  527. IPRO1=MLREE1.PROG(/1)
  528. IPRO2=MLREE2.PROG(/1)
  529. IPRO3=MLREE3.PROG(/1)
  530. JG=MAX(IPRO1,IPRO2,IPRO3)
  531. *
  532. SEGINI MLREEL
  533. *
  534. DO 306 IPROG=1,JG
  535. IPMN1=MIN(IPRO1,IPROG)
  536. IPMN2=MIN(IPRO2,IPROG)
  537. IPMN3=MIN(IPRO3,IPROG)
  538. XTT1=MLREE1.PROG(IPMN1)
  539. XTT2=MLREE2.PROG(IPMN2)
  540. XTT3=MLREE3.PROG(IPMN3)
  541. IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  542. PROG(IPROG)=1.D0
  543. KSOM=KSOM+1
  544. ENDIF
  545. 306 CONTINUE
  546. IELCHE(IGAU,IB)=MLREEL
  547. ENDIF
  548. 337 CONTINUE
  549. ELSEIF (IKOK.GT.0) THEN
  550. DO 338 IGAU=1,NBPGAU
  551. IGMN1=MIN(IGAU,NBPTE1)
  552. IGMN2=MIN(IGAU,NBPTE2)
  553. DO 338 IB=1,NBELEM
  554. IBMN1=MIN(IB,NEL1)
  555. IBMN2=MIN(IB,NEL2)
  556. IF (IML.EQ.0) THEN
  557. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  558. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  559. IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  560. VELCHE(IGAU,IB)=1.D0
  561. KSOM=KSOM+1
  562. ENDIF
  563. ELSE
  564. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  565. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  566. IPRO1=MLREE1.PROG(/1)
  567. IPRO2=MLREE2.PROG(/1)
  568. JG=MAX(IPRO1,IPRO2)
  569. *
  570. SEGINI MLREEL
  571. *
  572. DO 307 IPROG=1,JG
  573. IPMN1=MIN(IPRO1,IPROG)
  574. IPMN2=MIN(IPRO2,IPROG)
  575. XTT1=MLREE1.PROG(IPMN1)
  576. XTT2=MLREE2.PROG(IPMN2)
  577. IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  578. PROG(IPROG)=1.D0
  579. KSOM=KSOM+1
  580. ENDIF
  581. 307 CONTINUE
  582. IELCHE(IGAU,IB)=MLREEL
  583. ENDIF
  584. 338 CONTINUE
  585. ELSE
  586. DO 339 IGAU=1,NBPGAU
  587. IGMN1=MIN(IGAU,NBPTE1)
  588. IGMN2=MIN(IGAU,NBPTE2)
  589. DO 339 IB=1,NBELEM
  590. IBMN1=MIN(IB,NEL1)
  591. IBMN2=MIN(IB,NEL2)
  592. IF (IML.EQ.0) THEN
  593. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  594. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  595. IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  596. VELCHE(IGAU,IB)=1.D0
  597. KSOM=KSOM+1
  598. ENDIF
  599. ELSE
  600. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  601. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  602. IPRO1=MLREE1.PROG(/1)
  603. IPRO2=MLREE2.PROG(/1)
  604. JG=MAX(IPRO1,IPRO2)
  605. *
  606. SEGINI MLREEL
  607. *
  608. DO 308 IPROG=1,JG
  609. IPMN1=MIN(IPRO1,IPROG)
  610. IPMN2=MIN(IPRO2,IPROG)
  611. XTT1=MLREE1.PROG(IPMN1)
  612. XTT2=MLREE2.PROG(IPMN2)
  613. IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  614. PROG(IPROG)=1.D0
  615. KSOM=KSOM+1
  616. ENDIF
  617. 308 CONTINUE
  618. IELCHE(IGAU,IB)=MLREEL
  619. ENDIF
  620. 339 CONTINUE
  621. ENDIF
  622.  
  623. ENDIF
  624. 300 CONTINUE
  625. 200 CONTINUE
  626. *
  627. * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1
  628. * DESACTIVATON DES SEGMENTS
  629. *
  630. SEGSUP MTRAA
  631. IF (IKOK.EQ.0) SEGSUP MTRAA2
  632. IF (ISOM.EQ.1) THEN
  633. CALL DTCHAM(IPCHMA)
  634. IPCHMA=KSOM
  635. ENDIF
  636. IRET = 1
  637.  
  638. 666 CONTINUE
  639. END
  640.  
  641.  

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