Télécharger expil.eso

Retour à la liste

Numérotation des lignes :

  1. C EXPIL SOURCE PV 18/11/16 21:15:12 9994
  2. SUBROUTINE EXPIL (IFILE,ICOLAC,M1,M2,IIICHA)
  3. C----------------------------------------------------------------------
  4. C
  5. C BUT: REMPLIT LES PILES A PARTIR DE L EXAMEN DE LA PILE
  6. C SI IIICHA =1 ON CHANGE LES POINTEURS----
  7. C
  8. C ENTREE IFILE NUMERO DE LA PILE EXAMINEE
  9. C ICOLAC POINTEUR SUR LE CHAPEAU DES PILES
  10. C M1 PREMIER INDICE D EXAMEN DANS LA PILE
  11. C M2 DERNIER INDICE
  12. C IIICHA =1 ON CHANGE LES POINTEURS
  13. C-----------------------------------------------------------------------
  14. C REMARQUE : ICOLAC EST UN SEGMENT ACTIF EN ENTREE ET EN SORTIE
  15. C PAS DE CHANGEMENT DE STATUT AU COURS DU SP
  16. C-----------------------------------------------------------------------
  17. C PROGRAMME PAR FARVACQUE- REPRIS PAR LENA
  18. C APPELE PAR FILLPI
  19. C APPELLE AJOUN TYPFIL
  20. C=======================================================================
  21. C TABLEAU KCOLA : VOIR LE SOUS-PROGRAMME TYPFIL
  22. C=======================================================================
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25. -INC CCOPTIO
  26. -INC CCASSIS
  27.  
  28. *INC SMELEME
  29. -INC SMBASEM
  30. *INC SMCHPOI
  31. *INC SMRIGID
  32. -INC SMMATRI
  33. -INC SMCLSTR
  34. -INC SMELSTR
  35. -INC SMSOLUT
  36. -INC SMDEFOR
  37. -INC SMSTRUC
  38. -INC SMATTAC
  39. -INC SMCHARG
  40. -INC SMMODEL
  41. -INC SMEVOLL
  42. -INC SMTABLE
  43. -INC SMSUPER
  44. -INC SMTEXTE
  45. -INC SMVECTE
  46. -INC SMLCHPO
  47. -INC SMINTE
  48. -INC SMNUAGE
  49. -INC SMBLOC
  50. -INC CCNOYAU
  51. -INC TMCOLAC
  52.  
  53. SEGMENT ITRAVV(NITLAC)
  54. CHARACTER*(8) ITYP1
  55. CHARACTER*(1) CHAVAL
  56. CHARACTER*(16) MOTYP
  57. C=======================================================================
  58. C ICOLAC : KCOLA : POINTEUR SUR LA PILE ITLACC
  59. C MCOLA : NOMBRE D'OBJETS INSPECTES DANS LA PILE
  60. C ICOLA : POINTEUR SUR ISGTR ( NOM-NOM-RANG DANS ITLACC)
  61. C KCOLAC: CONTIENT POUR CHAQUE PILE LE NOMBRE D'OBJETS A SORT
  62. C=======================================================================
  63. IF (M1.GT.M2) RETURN
  64. IF (IIMPI.EQ.5) WRITE (IOIMP,8877) IFILE,M1,M2
  65. 8877 FORMAT (' EXAMEN DE LA PILE ',I5,' DE',I5,' A',I5)
  66. SEGACT ICOLAC
  67. ILISSE=ILISSF
  68. SEGACT ILISSE*MOD
  69. ILISSE=ILISSG
  70. SEGACT ILISSE*MOD
  71. ITLACC=KCOLA(IFILE)
  72. GO TO(501,502,503,599,599,506,507,508,509,510,
  73. 1 599,512,599,514,515,516,517,599,599,520,
  74. 1 599,522,523,524,525,526,527,528,529,530,
  75. 1 531,532,533,534,535,536,599,538,539,540,
  76. 1 541,542,543,510,545,546,547,548),IFILE
  77. CALL TYPFIL(MOTERR,IFILE)
  78. CALL ERREUR (336)
  79. CALL GINT2
  80. GO TO 599
  81. C ******************************* MELEME****************************
  82. 501 CONTINUE
  83. CALL EXAMEL (ICOLAC,ITLACC,M1,M2,IIICHA)
  84. GO TO 599
  85. C **************************** MCHPOI ******************************
  86. 502 CONTINUE
  87. CALL EXACHP (ICOLAC,ITLACC,M1,M2,IIICHA)
  88. GO TO 599
  89. C **************************** MRIGID ******************************
  90. 503 CONTINUE
  91. CALL EXARIG (ICOLAC,ITLACC,M1,M2,IIICHA)
  92. GO TO 599
  93. C *************************** *******************************
  94. 504 CONTINUE
  95. GO TO 599
  96. C *************************** *******************************
  97. 505 CONTINUE
  98. GO TO 599
  99. C **************************** MCLSTR ******************************
  100. 506 CONTINUE
  101. ICO1=KCOLA(12)
  102. ICO2=KCOLA(3)
  103. DO 614 IEL=M1,M2
  104. MCLSTR=ITLAC(IEL)
  105. IF (MCLSTR.EQ.0) GO TO 614
  106. SEGACT MCLSTR*MOD
  107. DO 615 I=1,ISOSTR(/1)
  108. IVA=ISOSTR(I)
  109. IF(IVA.NE.0)CALL AJOUN(ICO1,IVA,ILISSE,1)
  110. IF(IIICHA.EQ.1)ISOSTR(I)=IVA
  111. IVA=IRIGCL(I)
  112. IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,1)
  113. IF(IIICHA.EQ.1)IRIGCL(I)=IVA
  114. 615 CONTINUE
  115. SEGDES MCLSTR
  116. 614 CONTINUE
  117. GO TO 599
  118. C **************************** MELSTR ******************************
  119. 507 CONTINUE
  120. ICO1=KCOLA(12)
  121. ICO2=KCOLA(1)
  122. DO 616 IEL=M1,M2
  123. MELSTR=ITLAC(IEL)
  124. IF (MELSTR.EQ.0) GO TO 616
  125. SEGACT MELSTR*MOD
  126. DO 617 I=1,ISOSTU(/1)
  127. IVA=ISOSTU(I)
  128. IF(IVA.NE.0)CALL AJOUN(ICO1,IVA,ILISSE,1)
  129. IF(IIICHA.EQ.1)ISOSTU(I)=IVA
  130. IVA=IMELEM(I)
  131. IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,1)
  132. IF(IIICHA.EQ.1)IMELEM(I)=IVA
  133. 617 CONTINUE
  134. SEGDES MELSTR
  135. 616 CONTINUE
  136. GO TO 599
  137. C *************************** MSOLUT *******************************
  138. 508 CONTINUE
  139. ICO1=KCOLA(1)
  140. DO 618 IEL=M1,M2
  141. MSOLUT=ITLAC(IEL)
  142. IF (MSOLUT.EQ.0) GO TO 618
  143. SEGACT MSOLUT*MOD
  144. NIPO=MSOLIS(/1)
  145. DO 620 II=1,NIPO
  146. IF(MSOLIS(II).EQ.0) GOTO 620
  147. IF(II.EQ.3) THEN
  148. IVA=MSOLIS(3)
  149. CALL AJOUN(ICO1,IVA,ILISSE,1)
  150. CCC IF (IONIVE.LT.3) GO TO 620
  151. IF(IIICHA.EQ.1) MSOLIS(3)=IVA
  152. GOTO 620
  153. ENDIF
  154. IF(II.LE.4) GOTO 620
  155. ICO2=KCOLA(MSOLIT(II))
  156. MSOLEN=MSOLIS(II)
  157. SEGACT MSOLEN*MOD
  158. LTAB=ISOLEN(/1)
  159. DO 619 I=1,LTAB
  160. IVA=ISOLEN(I)
  161. IF(IVA.EQ.0)GOTO 619
  162. CALL AJOUN(ICO2,IVA,ILISSE,1)
  163. IF (IONIVE.LT.3) GO TO 619
  164. IF(IIICHA.EQ.1) ISOLEN(I)=IVA
  165. 619 CONTINUE
  166. SEGDES MSOLEN
  167. 620 CONTINUE
  168. SEGDES MSOLUT
  169. 618 CONTINUE
  170. GOTO 599
  171. C ************************** MSTRUC ********************************
  172. 509 CONTINUE
  173. ICO1=KCOLA(12)
  174. DO 621 IEL=M1,M2
  175. MSTRUC=ITLAC(IEL)
  176. IF (MSTRUC.EQ.0) GO TO 621
  177. SEGACT MSTRUC*MOD
  178. DO 622 I=1,LISTRU(/1)
  179. IVA=LISTRU(I)
  180. IF(IVA.EQ.0) GO TO 622
  181. IF(IVA.GT.0) THEN
  182. CALL AJOUN(ICO1,IVA,ILISSE,1)
  183. IF(IIICHA.EQ.1) LISTRU(I)=-IVA
  184. ENDIF
  185. 622 CONTINUE
  186. SEGDES MSTRUC
  187. 621 CONTINUE
  188. GOTO 599
  189. C ******************************* MTABLE **************************
  190. * POUR LES TABLES ON COMMENCE PAR METTRE DANS LA PILE DES REELS
  191. * LES VALEURS REELLES ON ON PREND LEUR INDICE
  192. * CECI NOUS PERMET D'ETRE COMPATIBLE AVEC LES VERSIONS ANTERIEURES
  193. * PV 28 DECEMBRE 1988
  194. * a partir du niveau 21 on n'utilise plus la pile d'entiers. On les sauve directement
  195. *
  196. 510 CONTINUE
  197. DO 710 IEL=M1,M2
  198.  
  199. MTABLE=ITLAC(IEL)
  200. IF (MTABLE.EQ.0) GO TO 710
  201. SEGACT MTABLE*MOD
  202. L6=MLOTAB
  203. IF (L6.EQ.0) GO TO 713
  204. DO 711 K=1,L6
  205.  
  206. ITYP1=MTABTI(K)
  207. IF (IIICHA.NE.1.AND.ITYP1.EQ.'FLOTTANT') THEN
  208. XVA=RMTABI(K)
  209. CALL QUERAN(IVA,'FLOTTANT',0,XVA,' ',.TRUE.,0)
  210. MTABII(K)=IVA
  211. ENDIF
  212. IVA=MTABII(K)
  213. J=0
  214. CALL TYPFIL (ITYP1,J)
  215. IF(J.LE.0) GO TO 711
  216. ICO2=KCOLA(J)
  217. NUMLIS=1
  218. ilissd=ilissg
  219. IF(J.EQ.24) NUMLIS=6
  220. IF(J.EQ.25) then
  221. NUMLIS=3
  222. ilissd=ilissf
  223. ENDIF
  224. IF(J.EQ.26) then
  225. if (ionive.le.20) then
  226. NUMLIS=2
  227. else
  228. goto 716
  229. endif
  230. ENDIF
  231. IF(J.EQ.27) NUMLIS=5
  232. IF(J.EQ.32) then
  233. NUMLIS=3
  234. ilissd=ilissp
  235. endif
  236. IF(J.EQ.36) NUMLIS=7
  237. IF(J.EQ.45) NUMLIS=5
  238. CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS)
  239. IF(IIICHA.EQ.1) MTABII(K)=IVA
  240. 716 CONTINUE
  241. ITYP1=MTABTV(K)
  242. IF (IIICHA.NE.1.AND.ITYP1.EQ.'FLOTTANT') THEN
  243. XVA=RMTABV(K)
  244. CALL QUERAN(IVA,'FLOTTANT',0,XVA,' ',.TRUE.,0)
  245. MTABIV(K)=IVA
  246. ENDIF
  247. IVA=MTABIV(K)
  248. CALL TYPFIL (ITYP1,J)
  249. IF(J.LE.0) GO TO 711
  250. IF (J.EQ.47) GO TO 711
  251. ICO2=KCOLA(J)
  252. NUMLIS=1
  253. ilissd=ilissg
  254. IF(J.EQ.24) NUMLIS=6
  255. IF(J.EQ.25) then
  256. NUMLIS=3
  257. ilissd=ilissf
  258. ENDIF
  259. IF(J.EQ.26) then
  260. if (ionive.le.20) then
  261. NUMLIS=2
  262. else
  263. goto 711
  264. endif
  265. ENDIF
  266. IF(J.EQ.27) NUMLIS=5
  267. IF(J.EQ.32) then
  268. NUMLIS=3
  269. ilissd=ilissp
  270. endif
  271. IF(J.EQ.36) NUMLIS=7
  272. IF(J.EQ.45) NUMLIS=5
  273. CALL AJOUN (ICO2,IVA,ILISSD,NUMLIS)
  274. IF(IIICHA.EQ.1) MTABIV(K)=IVA
  275. 711 CONTINUE
  276. 713 SEGDES MTABLE
  277. 710 CONTINUE
  278. GO TO 599
  279. 715 CONTINUE
  280. MOTERR(1:8)=ITYP1
  281. CALL ERREUR (336)
  282. GO TO 599
  283. C ******************************* *************************
  284. 511 CONTINUE
  285. GO TO 599
  286. C ******************************** MSOSTU **************************
  287. 512 CONTINUE
  288. ICO5=KCOLA(5)
  289. ICO3=KCOLA(3)
  290. DO 630 IEL=M1,M2
  291. MSOSTU=ITLAC(IEL)
  292. IF (MSOSTU.EQ.0) GO TO 630
  293. SEGACT MSOSTU*MOD
  294. IVA=ISRAID
  295. IF (IVA.NE.0)CALL AJOUN(ICO3,IVA,ILISSE,1)
  296. IF(IIICHA.EQ.1)ISRAID=IVA
  297. IVA=ISMASS
  298. IF (IVA.NE.0)CALL AJOUN(ICO3,IVA,ILISSE,1)
  299. IF(IIICHA.EQ.1)ISMASS=IVA
  300. NS=ISCHAM(/1)
  301. IF (NS.EQ.0) GO TO 122
  302. DO 121 I=1,NS
  303. IVA= ISCHAM(I)
  304. IF (IVA.NE.0)CALL AJOUN (ICO5,IVA,ILISSE,1)
  305. IF(IIICHA.EQ.1) ISCHAM(I)=IVA
  306. 121 CONTINUE
  307. 122 SEGDES MSOSTU
  308. 630 CONTINUE
  309. GO TO 599
  310. C ***************************** IMATRI *****************************
  311. 513 CONTINUE
  312. GO TO 599
  313. C ***************************** MJONCT *****************************
  314. 514 CONTINUE
  315. ICO1=KCOLA(1)
  316. ICO12=KCOLA(12)
  317. ICO2=KCOLA(2)
  318. DO 631 IEL=M1,M2
  319. MJONCT=ITLAC(IEL)
  320. IF (MJONCT.EQ.0) GO TO 631
  321. SEGACT MJONCT*MOD
  322. IVA=MJOPOI
  323. IF(MJOTYP.EQ.'CHOC')THEN
  324. IF(IVA.NE.0) CALL AJOUN(ICO2,IVA,ILISSE,1)
  325. ELSE
  326. IF(IVA.NE.0) CALL AJOUN(ICO1,IVA,ILISSE,1)
  327. ENDIF
  328. CCC CALL AJOUN(ICO1,IVA)
  329. IF(IIICHA.EQ.1)MJOPOI=IVA
  330. DO 632 I=1,ISTRJO(/1)
  331. IVA=ISTRJO(I)
  332. IF (IVA.NE.0)CALL AJOUN(ICO12,IVA,ILISSE,1)
  333. IF(IIICHA.EQ.1)ISTRJO(I)=IVA
  334. IVA=IPCHJO(I)
  335. IF (IVA.NE.0)CALL AJOUN(ICO2,IVA,ILISSE,1)
  336. IF(IIICHA.EQ.1)IPCHJO(I)=IVA
  337. IVA=IPOSJO(I)
  338. IF (IVA.NE.0) CALL AJOUN(ICO1,IVA,ILISSE,1)
  339. IF(IIICHA.EQ.1)IPOSJO(I)=IVA
  340. 632 CONTINUE
  341. SEGDES MJONCT
  342. 631 CONTINUE
  343. GO TO 599
  344. C ************************ MATTAC **********************************
  345. 515 CONTINUE
  346. ICO1=KCOLA(1)
  347. ICO3=KCOLA(3)
  348. ICO14=KCOLA(14)
  349. DO 150 IEL=M1,M2
  350. MATTAC =ITLAC(IEL)
  351. IF (MATTAC.EQ.0) GO TO 150
  352. SEGACT MATTAC*MOD
  353. NN=LISATT(/1)
  354. DO 151 I=1,NN
  355. MSOUMA=LISATT(I)
  356. IF (MSOUMA.EQ.0) GO TO 151
  357. SEGACT MSOUMA*MOD
  358. M=IPMATK(/1)
  359. DO 152 J=1,M
  360. IVA=IPMATK(J)
  361. IF (IVA.NE.0)CALL AJOUN (ICO3,IVA,ILISSE,1)
  362. IF(IIICHA.EQ.1) IPMATK(J)=IVA
  363. 152 CONTINUE
  364. N=IATREL(/1)
  365. DO 153 J=1,N
  366. IVA=IATREL(J)
  367. IF (IVA.NE.0)CALL AJOUN (ICO14,IVA,ILISSE,1)
  368. IF(IIICHA.EQ.1) IATREL(J)=IVA
  369. 153 CONTINUE
  370. IF(IGEOCH.EQ.0) GO TO 156
  371. MGEOCH=IGEOCH
  372. SEGACT MGEOCH*MOD
  373. NI=INORCH(/1)
  374. DO 154 J=1,NI
  375. IVA=INORCH(J)
  376. IF (IVA.NE.0)CALL AJOUN (ICO1 ,IVA,ILISSE,1)
  377. IF(IIICHA.EQ.1) INORCH(J)=IVA
  378. 154 CONTINUE
  379. N1=IMAPRO(/1)
  380. DO 155 J=1,N1
  381. IVA=IMAPRO(J)
  382. IF (IVA.NE.0)CALL AJOUN (ICO1 ,IVA,ILISSE,1)
  383. IF(IIICHA.EQ.1) IMAPRO(J)=IVA
  384. 155 CONTINUE
  385. SEGDES MGEOCH
  386. 156 CONTINUE
  387. SEGDES MSOUMA
  388. 151 CONTINUE
  389. SEGDES MATTAC
  390. 150 CONTINUE
  391. GO TO 599
  392. C ************************ MMATRI **********************************
  393. 516 CONTINUE
  394. ICO1=KCOLA(1)
  395. DO 633 IEL=M1,M2
  396. MMATRI=ITLAC(IEL)
  397. IF (MMATRI.EQ.0) GO TO 633
  398. SEGACT MMATRI*MOD
  399. IVA=IGEOMA
  400. CALL AJOUN(ICO1,IVA,ILISSE,1)
  401. IF(IIICHA.EQ.1)IGEOMA=IVA
  402. SEGDES MMATRI
  403. 633 CONTINUE
  404. GOTO 599
  405. C *************************MDEFOR***********************************
  406. 517 CONTINUE
  407. ICO1=KCOLA(1)
  408. ICO2=KCOLA(2)
  409. ICO30=KCOLA(30)
  410. ICO38=KCOLA(38)
  411. ICO39=KCOLA(39)
  412. DO 634 IEL=M1,M2
  413. MDEFOR=ITLAC(IEL)
  414. IF (MDEFOR.EQ.0) GO TO 634
  415. SEGACT MDEFOR*MOD
  416. NDEF=IELDEF(/1)
  417. DO 635 I=1,NDEF
  418. IVA=IELDEF(I)
  419. CALL AJOUN(ICO1,IVA,ILISSE,1)
  420. IF(IIICHA.EQ.1)IELDEF(I)=IVA
  421. IVA=ICHDEF(I)
  422. CALL AJOUN(ICO2,IVA,ILISSE,1)
  423. IF(IIICHA.EQ.1)ICHDEF(I)=IVA
  424. IVA=MTVECT(I)
  425. IF (IVA.NE.0) THEN
  426. CALL AJOUN(ICO30,IVA,ILISSE,1)
  427. IF(IIICHA.EQ.1)MTVECT(I)=IVA
  428. ENDIF
  429. IVA=MDCHP(I)
  430. IF (IVA.NE.0) THEN
  431. CALL AJOUN(ICO2,IVA,ILISSE,1)
  432. IF(IIICHA.EQ.1)MDCHP(I)=IVA
  433. ENDIF
  434. IVA=MDCHEL(I)
  435. IF (IVA.NE.0) THEN
  436. CALL AJOUN(ICO39,IVA,ILISSE,1)
  437. IF(IIICHA.EQ.1)MDCHEL(I)=IVA
  438. ENDIF
  439. IVA=MDMODE(I)
  440. IF (IVA.NE.0) THEN
  441. CALL AJOUN(ICO38,IVA,ILISSE,1)
  442. IF(IIICHA.EQ.1)MDMODE(I)=IVA
  443. ENDIF
  444. 635 CONTINUE
  445. SEGDES MDEFOR
  446. 634 CONTINUE
  447. GOTO 599
  448. C ****************************MLREEL*******************************
  449. 518 CONTINUE
  450. GOTO 599
  451. C ****************************MLENTI******************************
  452. 519 CONTINUE
  453. GOTO 599
  454. C ****************************MCHARG*****************************
  455. 520 CONTINUE
  456. ICO1=KCOLA(2)
  457. ICO2=KCOLA(18)
  458. ICO3=KCOLA(39)
  459. ICO4=KCOLA(10)
  460. ICO5=KCOLA(1)
  461. DO 650 IEL=M1,M2
  462. MCHARG=ITLAC(IEL)
  463. IF (MCHARG.EQ.0) GO TO 650
  464. SEGACT MCHARG
  465. DO 651 I=1,KCHARG(/1)
  466. ICHARG=KCHARG(I)
  467. SEGACT ICHARG*MOD
  468. IF(CHATYP.EQ.'CHPOINT ') THEN
  469. IVA=ICHPO1
  470. IF(IVA.GT.0) THEN
  471. CALL AJOUN(ICO1,IVA,ILISSE,1)
  472. IF(IIICHA.EQ.1) ICHPO1=-IVA
  473. ENDIF
  474. IVA=ICHPO2
  475. IF(IVA.GT.0) THEN
  476. CALL AJOUN(ICO2,IVA,ILISSE,1)
  477. IF(IIICHA.EQ.1) ICHPO2=-IVA
  478. ENDIF
  479. IVA=ICHPO3
  480. IF(IVA.GT.0) THEN
  481. CALL AJOUN(ICO2,IVA,ILISSE,1)
  482. IF(IIICHA.EQ.1) ICHPO3=-IVA
  483. ENDIF
  484. ELSEIF(CHATYP.EQ.'MCHAML ') THEN
  485. IVA=ICHPO1
  486. IF(IVA.GT.0) THEN
  487. CALL AJOUN(ICO3,IVA,ILISSE,1)
  488. IF(IIICHA.EQ.1) ICHPO1=-IVA
  489. ENDIF
  490. IVA=ICHPO2
  491. IF(IVA.GT.0) THEN
  492. CALL AJOUN(ICO2,IVA,ILISSE,1)
  493. IF(IIICHA.EQ.1) ICHPO2=-IVA
  494. ENDIF
  495. IVA=ICHPO3
  496. IF(IVA.GT.0) THEN
  497. CALL AJOUN(ICO2,IVA,ILISSE,1)
  498. IF(IIICHA.EQ.1) ICHPO3=-IVA
  499. ENDIF
  500. ELSEIF(CHATYP.EQ.'TABLE ') THEN
  501. IVA=ICHPO1
  502. IF(IVA.GT.0) THEN
  503. CALL AJOUN(ICO4,IVA,ILISSE,1)
  504. IF(IIICHA.EQ.1) ICHPO1=-IVA
  505. ENDIF
  506. IVA=ICHPO2
  507. IF(IVA.GT.0) THEN
  508. CALL AJOUN(ICO4,IVA,ILISSE,1)
  509. IF(IIICHA.EQ.1) ICHPO2=-IVA
  510. ENDIF
  511. ENDIF
  512. IF(CHAMOB(I).EQ.'TRAN') THEN
  513. IVA=ICHPO4
  514. IF(IVA.GT.0) THEN
  515. CALL AJOUN(ICO5,IVA,ILISSE,1)
  516. IF(IIICHA.EQ.1) ICHPO4=-IVA
  517. ENDIF
  518. IVA=ICHPO6
  519. IF(IVA.GT.0) THEN
  520. CALL AJOUN(ICO2,IVA,ILISSE,1)
  521. IF(IIICHA.EQ.1) ICHPO6=-IVA
  522. ENDIF
  523. IVA=ICHPO7
  524. IF(IVA.GT.0) THEN
  525. CALL AJOUN(ICO2,IVA,ILISSE,1)
  526. IF(IIICHA.EQ.1) ICHPO7=-IVA
  527. ENDIF
  528. ELSEIF(CHAMOB(I).EQ.'ROTA') THEN
  529. IVA=ICHPO4
  530. IF(IVA.GT.0) THEN
  531. CALL AJOUN(ICO5,IVA,ILISSE,1)
  532. IF(IIICHA.EQ.1) ICHPO4=-IVA
  533. ENDIF
  534. IVA=ICHPO5
  535. IF(IVA.GT.0.AND.IDIM.GT.2) THEN
  536. CALL AJOUN(ICO5,IVA,ILISSE,1)
  537. IF(IIICHA.EQ.1) ICHPO5=-IVA
  538. ENDIF
  539. IVA=ICHPO6
  540. IF(IVA.GT.0) THEN
  541. CALL AJOUN(ICO2,IVA,ILISSE,1)
  542. IF(IIICHA.EQ.1) ICHPO6=-IVA
  543. ENDIF
  544. IVA=ICHPO7
  545. IF(IVA.GT.0) THEN
  546. CALL AJOUN(ICO2,IVA,ILISSE,1)
  547. IF(IIICHA.EQ.1) ICHPO7=-IVA
  548. ENDIF
  549. ELSEIF(CHAMOB(I).EQ.'TRAJ') THEN
  550. IVA=ICHPO4
  551. IF(IVA.GT.0) THEN
  552. CALL AJOUN(ICO1,IVA,ILISSE,1)
  553. IF(IIICHA.EQ.1) ICHPO4=-IVA
  554. ENDIF
  555. IVA=ICHPO5
  556. IF(IVA.GT.0) THEN
  557. CALL AJOUN(ICO5,IVA,ILISSE,1)
  558. IF(IIICHA.EQ.1) ICHPO5=-IVA
  559. ENDIF
  560. IVA=ICHPO6
  561. IF(IVA.GT.0) THEN
  562. CALL AJOUN(ICO2,IVA,ILISSE,1)
  563. IF(IIICHA.EQ.1) ICHPO6=-IVA
  564. ENDIF
  565. ENDIF
  566. SEGDES ICHARG
  567. 651 CONTINUE
  568. SEGDES MCHARG
  569. 650 CONTINUE
  570. GOTO 599
  571. C *************************** *****************************
  572. 521 CONTINUE
  573. GOTO 599
  574. C ****************************MEVOLL******************************
  575. 522 CONTINUE
  576. ICOR=KCOLA(18)
  577. ICOM=KCOLA(29)
  578. DO 660 IEL=M1,M2
  579. MEVOLL=ITLAC(IEL)
  580. IF (MEVOLL.EQ.0) GO TO 660
  581. SEGACT MEVOLL
  582. DO 661 I=1,IEVOLL(/1)
  583. KEVOLL=IEVOLL(I)
  584. SEGACT KEVOLL*MOD
  585. IVA=IPROGX
  586. ICO2=ICOR
  587. IF(IONIVE.GE.3) THEN
  588. IF(TYPX.EQ.'LISTMOTS') THEN
  589. ICO2=ICOM
  590. ELSEIF(TYPX.EQ.'LISTREEL')THEN
  591. ICO2=ICOR
  592. ENDIF
  593. ENDIF
  594. IF(IVA.GT.0) THEN
  595. CALL AJOUN(ICO2,IVA,ILISSE,1)
  596. IF(IIICHA.EQ.1) IPROGX=-IVA
  597. ENDIF
  598. IVA=IPROGY
  599. IF(IONIVE.GE.3) THEN
  600. IF(TYPY.EQ.'LISTMOTS') THEN
  601. ICO2=ICOM
  602. ELSEIF(TYPY.EQ.'LISTREEL')THEN
  603. ICO2=ICOR
  604. ENDIF
  605. ENDIF
  606. IF(IVA.GT.0) THEN
  607. CALL AJOUN(ICO2,IVA,ILISSE,1)
  608. IF(IIICHA.EQ.1) IPROGY=-IVA
  609. ENDIF
  610. SEGDES KEVOLL
  611. 661 CONTINUE
  612. SEGDES MEVOLL
  613. 660 CONTINUE
  614. GOTO 599
  615. C **********************SUPERELE************************************
  616. 523 CONTINUE
  617. ICO1=KCOLA(1)
  618. ICO3=KCOLA(3)
  619. ICO2=KCOLA( 2)
  620. ICO16=KCOLA(16)
  621. DO 5230 IEL=M1,M2
  622. MSUPER=ITLAC(IEL)
  623. IF (MSUPER.EQ.0) GO TO 5230
  624. SEGACT MSUPER*MOD
  625. IVA=MRIGTO
  626. CALL AJOUN(ICO3,IVA,ILISSE,1)
  627. IF(IIICHA.EQ.1)MRIGTO=IVA
  628. IVA=MSUPEL
  629. CALL AJOUN(ICO1,IVA,ILISSE,1)
  630. IF(IIICHA.EQ.1)MSUPEL=IVA
  631. IVA=MSURAI
  632. CALL AJOUN(ICO3,IVA,ILISSE,1)
  633. IF(IIICHA.EQ.1)MSURAI=IVA
  634. IVA=MSUMAS
  635. IF(IVA.NE.0) CALL AJOUN(ICO3,IVA,ILISSE,1)
  636. IF(IIICHA.EQ.1)MSUMAS=IVA
  637. IVA=MCROUT
  638. CALL AJOUN(ICO16,IVA,ILISSE,1)
  639. IF(IIICHA.EQ.1)MCROUT=IVA
  640. c NBINMA=MSUPCH(/1)
  641. c DO 5231 I=1,NBINMA
  642. c IVA=MSUPCH(I)
  643. c CALL AJOUN(ICO2,IVA)
  644. c IF(IIICHA.EQ.1)MSUPCH(I)=IVA
  645. c 5231 CONTINUE
  646. SEGDES MSUPER
  647. 5230 CONTINUE
  648. GOTO 599
  649. C **********************LOGIQUE***********************************
  650. 524 CONTINUE
  651. GOTO 599
  652. C **********************FLOTTANT**********************************
  653. 525 CONTINUE
  654. GOTO 599
  655. C ********************** ENTIER **********************************
  656. 526 CONTINUE
  657. GOTO 599
  658. C ********************** MOT ***********************************
  659. 527 CONTINUE
  660. GOTO 599
  661. C ********************** TEXTE ***********************************
  662. 528 CONTINUE
  663. GOTO 599
  664. C ********************** LISTMOTS*********************************
  665. 529 CONTINUE
  666. GOTO 599
  667. C ********************** VECTEUR**********************************
  668. 530 CONTINUE
  669. ICO1=KCOLA(1)
  670. ICO2=KCOLA( 2)
  671. DO 5300 IEL=M1,M2
  672. MVECTE=ITLAC(IEL)
  673. IF (MVECTE.EQ.0) GO TO 5300
  674. SEGACT MVECTE*MOD
  675. NVEC=ICHPO(/1)
  676. DO 5301 I=1,NVEC
  677. * CE POINTEUR N'EST PAS ACTUELLEMENT REMPLI
  678. * IVA=IGEOV(I)
  679. * CALL AJOUN(ICO1,IVA)
  680. * IF(IIICHA.EQ.1)IGEOV(I)=IVA
  681. IVA=ICHPO(I)
  682. CALL AJOUN(ICO2,IVA,ILISSE,1)
  683. IF(IIICHA.EQ.1)ICHPO(I)=IVA
  684. 5301 CONTINUE
  685. SEGDES MVECTE
  686. 5300 CONTINUE
  687. GOTO 599
  688. C ********************** VECTDOUB*********************************
  689. 531 CONTINUE
  690. GOTO 599
  691. C ********************** POINT *********************************
  692. 532 CONTINUE
  693. GOTO 599
  694. C ********************** CONFIG *********************************
  695. 533 CONTINUE
  696. GOTO 599
  697. C *********************** LISTCHPO ******************************
  698. 534 CONTINUE
  699. ICO2=KCOLA(2)
  700. DO 340 IEL=M1,M2
  701. MLCHPO =ITLAC(IEL)
  702. IF (MLCHPO.EQ.0) GO TO 340
  703. SEGACT MLCHPO*MOD
  704. N1=ICHPOI(/1)
  705. DO 341 I=1,N1
  706. IVA=ICHPOI(I)
  707. CALL AJOUN(ICO2,IVA,ILISSE,1)
  708. IF(IIICHA.EQ.1)ICHPOI(I)=IVA
  709. 341 CONTINUE
  710. SEGDES MLCHPO
  711. 340 CONTINUE
  712. GO TO 599
  713. C ************************** BASEM ********************************
  714. 535 CONTINUE
  715. ICO12=KCOLA(12)
  716. ICO8=KCOLA(8 )
  717. ICO15=KCOLA(15)
  718. DO 350 IEL=M1,M2
  719. MBASEM=ITLAC(IEL)
  720. IF (MBASEM.EQ.0) GO TO 350
  721. SEGACT MBASEM
  722. DO 351 I=1,LISBAS(/1)
  723. MSOBAS=LISBAS(I)
  724. SEGACT MSOBAS*MOD
  725. IVA=IBSTRM(1)
  726. IF(IVA.GT.0) THEN
  727. CALL AJOUN(ICO12,IVA,ILISSE,1)
  728. IF(IIICHA.EQ.1) IBSTRM(1)=-IVA
  729. ENDIF
  730. IVA=IBSTRM(2)
  731. IF(IVA.GT.0) THEN
  732. CALL AJOUN(ICO8,IVA,ILISSE,1)
  733. IF(IIICHA.EQ.1) IBSTRM(2)=-IVA
  734. ENDIF
  735. IVA=IBSTRM(3)
  736. IF (IVA.EQ.0) GOTO 352
  737. IF(IVA.GT.0) THEN
  738. CALL AJOUN(ICO8,IVA,ILISSE,1)
  739. IF(IIICHA.EQ.1) IBSTRM(3)=-IVA
  740. ENDIF
  741. 352 CONTINUE
  742. IVA=IBSTRM(4)
  743. IF (IVA.EQ.0) GOTO 353
  744. IF(IVA.GT.0) THEN
  745. CALL AJOUN(ICO15,IVA,ILISSE,1)
  746. IF(IIICHA.EQ.1) IBSTRM(4)=-IVA
  747. ENDIF
  748. 353 CONTINUE
  749. IVA=IBSTRM(5)
  750. IF (IVA.EQ.0) GOTO 354
  751. IF(IVA.GT.0) THEN
  752. CALL AJOUN(ICO8,IVA,ILISSE,1)
  753. IF(IIICHA.EQ.1) IBSTRM(5)=-IVA
  754. ENDIF
  755. 354 CONTINUE
  756. SEGDES MSOBAS
  757. 351 CONTINUE
  758. SEGDES MBASEM
  759. 350 CONTINUE
  760. GOTO 599
  761. C ************************* PROCEDURE ****************************
  762. * On ajoute les objets en cours de retour (entre respro et finpro)
  763. * on va les chercher dans les segments de resultats du bloc
  764. * sous jacent a la procedure
  765. *
  766. 536 CONTINUE
  767. ** write(6,*) ' exploration bloc ',m1,m2
  768. MTTRY=MTXBL
  769. ITLACC=KCOLA(36)
  770. ITLAC1=KCOLA(37)
  771. IF (ITLAC(/1).EQ.0) GOTO 599
  772. DO 5270 IEL=M1,M2
  773. MBLA1=ITLAC(IEL)
  774. MBLO1=IPIPR1(MBLA1)
  775.  
  776. IF (MBLO1.LE.0) GO TO 5270
  777. SEGACT MBLO1
  778. iargum=mblo1.margum
  779. segact iargum
  780. mtresu=itresu
  781. mvresu=ivresu
  782. if (mtresu.eq.0.or.mvresu.eq.0) goto 5270
  783. segact mtresu,mvresu
  784. nres=ivares(/1)
  785. do 5271 ires=1,nres
  786. ityp1=mtyres(ires)
  787. iva=ivares(ires)
  788. call typfil(ityp1,j)
  789. if (j.le.0) goto 5271
  790. ICO2=KCOLA(J)
  791. NUMLIS=1
  792. ilissd=ilissg
  793. IF(J.EQ.24) NUMLIS=6
  794. IF(J.EQ.25) then
  795. NUMLIS=3
  796. ilissd=ilissf
  797. ENDIF
  798. IF(J.EQ.26) then
  799. if (ionive.le.20) then
  800. NUMLIS=2
  801. else
  802. goto 5271
  803. endif
  804. ENDIF
  805. IF(J.EQ.27) NUMLIS=5
  806. IF(J.EQ.32) then
  807. NUMLIS=3
  808. ilissd=ilissp
  809. endif
  810. IF(J.EQ.36) NUMLIS=7
  811. IF(J.EQ.45) NUMLIS=5
  812. CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS)
  813. 5271 CONTINUE
  814. 5270 CONTINUE
  815. GO TO 599
  816.  
  817. C ************************ MMODEL ********************************
  818. 538 CONTINUE
  819. ICO1 = KCOLA( 1)
  820. ICO10 = KCOLA(10)
  821. ICO29 = KCOLA(29)
  822. ICO40 = kcola(40)
  823. DO 5380 IEL=M1,M2
  824. MMODEL = ITLAC(IEL)
  825. IF (MMODEL.EQ.0) GOTO 5380
  826. SEGACT,MMODEL
  827. DO 5385 I=1,KMODEL(/1)
  828. IMODEL = KMODEL(I)
  829. SEGACT,IMODEL*MOD
  830. IVA = IMAMOD
  831. IF(IVA.GT.0) THEN
  832. CALL AJOUN(ICO1,IVA,ILISSE,1)
  833. IF (IIICHA.EQ.1) IMAMOD =-IVA
  834. ENDIF
  835. IVA = IPDPGE
  836. IF(IVA.GT.0) THEN
  837. CALL AJOUN(ICO1,IVA,ILISSE,1)
  838. IF (IIICHA.EQ.1) IPDPGE =-IVA
  839. ENDIF
  840. C cas 'NAVIER_STOKES' : INFMOD(2) contient une table
  841. NFOR=FORMOD(/2)
  842. IF (NFOR.GT.0) THEN
  843. IF ((FORMOD(1).EQ.'NAVIER_STOKES').OR.
  844. * (FORMOD(1).EQ.'DARCY').OR.
  845. * (FORMOD(1).EQ.'EULER')) THEN
  846. MN3=INFMOD(/1)
  847. IF (MN3.GT.1) THEN
  848. IVA=INFMOD(2)
  849. IF(IVA.GT.0) THEN
  850. CALL AJOUN(ICO10,IVA,ILISSE,1)
  851. IF (IIICHA.EQ.1) INFMOD(2) =-IVA
  852. ENDIF
  853. ENDIF
  854. ENDIF
  855. ENDIF
  856. NM3=INFMOD(/1)
  857. DO IOU=3,NM3
  858. IVA=INFMOD(IOU)
  859. IF(IVA.gt.0) then
  860. IF(IOU.EQ.14) THEN
  861. CALL AJOUN(ICO29,IVA,ilisse,1)
  862. ELSE
  863. CALL AJOUN(ICO40,IVA,ilisse,1)
  864. ENDIF
  865. IF(IIICHA.EQ.1) INFMOD(IOU)=-IVA
  866. ENDIF
  867. ENDDO
  868. IF(tymode(/2). ne . 0) then
  869. do 5387 ihy=1,tymode(/2)
  870. ITYP1=tymode(ihy)
  871. IVA=IVAMOD(ihy)
  872. J=0
  873. if( iva.lt.0) go to 5387
  874. CALL TYPFIL (ITYP1,J)
  875. IF(J.LE.0.or.j.eq.32) GO TO 5387
  876. ICO2=KCOLA(J)
  877. NUMLIS=1
  878. ilissd=ilissg
  879. IF(J.EQ.24) NUMLIS=6
  880. IF(J.EQ.25) then
  881. NUMLIS=3
  882. ilissd=ilissf
  883. ENDIF
  884. IF(J.EQ.26) NUMLIS=2
  885. IF(J.EQ.27) NUMLIS=5
  886. IF(J.EQ.32) then
  887. NUMLIS=3
  888. ilissd=ilissp
  889. endif
  890. IF(J.EQ.36) NUMLIS=7
  891. IF(J.EQ.45) NUMLIS=5
  892. CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS)
  893. IF(IIICHA.EQ.1)IVAMOD(ihy) =-IVA
  894. 5387 continue
  895. endif
  896. SEGDES,IMODEL
  897. 5385 CONTINUE
  898. SEGDES,MMODEL
  899. 5380 CONTINUE
  900. GOTO 599
  901. C ************************ MCHAML ********************************
  902. 539 CONTINUE
  903. CALL EXCHAM(ICOLAC,ITLACC,M1,M2,IIICHA)
  904. GOTO 599
  905. C ************************ MINTE ********************************
  906. 540 CONTINUE
  907. GOTO 599
  908. C ************************ NUAGE ********************************
  909. 541 CONTINUE
  910. DO 810 IEL=M1,M2
  911. MNUAGE=ITLAC(IEL)
  912. IF (MNUAGE.EQ.0) GO TO 810
  913. SEGACT MNUAGE
  914. L6=NUAPOI(/1)
  915. IF (L6.EQ.0) GO TO 813
  916. DO 811 K=1,L6
  917. ITYP1=NUATYP(K)
  918. ISIN=NUAPOI(K)
  919. J=0
  920. IF(ITYP1.EQ.'FLOTTANT'.OR.ITYP1.EQ.'ENTIER '.OR.
  921. $ ITYP1.EQ.'MOT '.OR.ITYP1.EQ.'LOGIQUE ') GO TO 811
  922. CALL TYPFIL (ITYP1,J)
  923. IF(J.LE.0) GO TO 811
  924. ICO2=KCOLA(J)
  925. NUMLIS=1
  926. ilissd=ilissg
  927. IF(J.EQ.32) then
  928. NUMLIS=3
  929. ilissd=ilissp
  930. endif
  931. IF(J.EQ.36) NUMLIS=7
  932. IF(J.EQ.45) NUMLIS=5
  933. NUAVIN=ISIN
  934. SEGACT NUAVIN*MOD
  935. DO 816 LL =1,NUAINT(/1)
  936. IVA=NUAINT(LL)
  937. CALL AJOUN (ICO2,IVA,ILISSd,NUMLIS)
  938. IF(IIICHA.EQ.1) NUAINT(LL)=IVA
  939. 816 CONTINUE
  940. SEGDES NUAVIN
  941. 811 CONTINUE
  942. 813 SEGDES MNUAGE
  943. 810 CONTINUE
  944. GO TO 599
  945. C **************************** MATRAK ******************************
  946. 542 CONTINUE
  947. C ICO1=KCOLA(1)
  948. CALL EXAMTK (ICOLAC,ITLACC,M1,M2,IIICHA)
  949. GO TO 599
  950. C **************************** MATRIK ******************************
  951. 543 CONTINUE
  952. C ICO1=KCOLA(1)
  953. CALL EXANTK (ICOLAC,ITLACC,M1,M2,IIICHA)
  954. GO TO 599
  955. C ****************************** METHODE ***************************
  956. 545 CONTINUE
  957. ICO1=KCOLA(27)
  958. DO 5450 IEL=M1,M2
  959. IVA = ITLAC(IEL)
  960. CALL AJOUN(ICO1,IVA,ILISSE,5)
  961. IF(IIICHA.EQ.1) ITLAC (IEL) = IVA
  962. 5450 CONTINUE
  963. GO TO 599
  964. C ****************************** ESCLAVE ***************************
  965. 546 CONTINUE
  966. DO 5460 IEL=M1,M2
  967. mesres=itlac(iel)
  968. segact mesres
  969. nesres=iesres
  970. segact nesres
  971. if (.not.loremp) goto 5460
  972. ityp1=esrety
  973. k=0
  974. call typfil(ityp1,k)
  975. if (k.le.0) goto 5460
  976. if (k.eq.24) goto 5460
  977. if (k.eq.25) goto 5460
  978. if (k.eq.26) goto 5460
  979. if (k.eq.27) goto 5460
  980. ico1=kcola(k)
  981. iva=esreva
  982. NUMLIS=1
  983. ilissd=ilissg
  984. IF(J.EQ.32) then
  985. NUMLIS=3
  986. ilissd=ilissp
  987. endif
  988. IF(k.EQ.36) NUMLIS=7
  989. IF(K.EQ.45) NUMLIS=5
  990. * write (6,*) ' expill esclave renvoie sur ',ityp1,iva
  991. call ajoun(ico1,iva,ilissd,numlis)
  992. segdes nesres
  993. segdes mesres
  994. 5460 continue
  995. C JYY print*, ' passage ESCLAVE dans expil'
  996. GO TO 599
  997. C ***************************** FANTOME ****************************
  998. 547 CONTINUE
  999. GO TO 599
  1000. C ***************************** IELVAL *****************************
  1001. 548 CONTINUE
  1002. GO TO 599
  1003.  
  1004. 599 CONTINUE
  1005. SEGDES ICOLAC
  1006. RETURN
  1007. END
  1008.  
  1009.  
  1010.  
  1011.  
  1012.  
  1013.  
  1014.  
  1015.  
  1016.  
  1017.  
  1018.  
  1019.  
  1020.  
  1021.  

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