Télécharger lirabj.eso

Retour à la liste

Numérotation des lignes :

lirabj
  1. C LIRABJ SOURCE CB215821 24/07/17 21:15:08 11961
  2. SUBROUTINE LIRABJ( ITYPE , IRET , ICODE , IRETOU )
  3.  
  4. IMPLICIT INTEGER(I-N)
  5.  
  6. -INC PPARAM
  7. -INC CCNOYAU
  8. -INC CCOPTIO
  9. -INC SMBLOC
  10. -INC CCASSIS
  11. -INC SMCOORD
  12. -INC SMLOBJE
  13. LOGICAL JTYP
  14. CHARACTER*(*) ITYPE
  15. CHARACTER*(8) ITYP,INTERM,MOVID8
  16. CHARACTER*8 JTYOBI
  17. * SAVE IPLAC
  18. LOGICAL LOMISA,ILOREMP
  19. integer desrev
  20. character*(8) desret
  21.  
  22. MOVID8=' '
  23.  
  24. IF(LEN(ITYPE).LT.8) THEN
  25. CALL ERREUR(5)
  26. RETURN
  27. ENDIF
  28.  
  29. iextab=0
  30. * initialisation de lotesc
  31. lotesc=.false.
  32. ith=0
  33. if (nbesc.ne.0) ith = oothrd
  34. if (ith .ne.0) lotesc=.true.
  35. * write (6,*) ' dans lirabj ',ith
  36. if (lotesc) then
  37. call liresc(itype,iret,icode,iretou)
  38. return
  39. endif
  40. IF (NOMLU.EQ.0) CALL LIRNOM
  41. IRETOU=0
  42. IF (IERR.GT.1) RETURN
  43. INSTAB=0
  44. IF (ITYPE(1:5).EQ.'TEXTE') INTEXT=1
  45. ITYP=' '
  46. JTYP=.FALSE.
  47. C DANS LE CAS DE LECTURE D'UN FLOTTANT ON ADMET DE LIRE UN ENTIER
  48. IF (ITYPE(1:8).EQ.'FLOTTANT') THEN
  49. ITYP='ENTIER'
  50. JTYP=.TRUE.
  51. ENDIF
  52. C DANS LE CAS DE LECTURE D'UN MOT ON ADMET DE LIRE UNE PROCEDURE
  53. IF (ITYPE(1:4).EQ.'MOT ') THEN
  54. ITYP='PROCEDUR'
  55. JTYP=.TRUE.
  56. ENDIF
  57. * if ( iimpi.eq.1876) THEN
  58. * write(6,*) ' lirabj on demande ',itype
  59. * write(6,*) ' ibpile,ihpile ',ibpile,ihpile
  60. * write(6,*) ' instab,lectab,iextab' ,instab,lectab,iextab
  61. * endif
  62. 5 L = IHPILE-IBPILE
  63. ILTTA = 0
  64. INSTAB= 0
  65. IF (L .lt. 0) goto 2
  66. C********************** ON CHERCHE SI UN OBJET DU TYPE DESIRE EST
  67. C********************** DEJA DANS LA PILE
  68. 1 IBPILN=0
  69. * write(6,*) ' apres 1 lectab instab iextab ibpile ihpile'
  70. * write(6,*) lectab ,instab, iextab, ibpile,ihpile
  71. DO 10 I=IBPILE,IHPILE
  72. * write(6,*) 'bcl 10 i jpoob1(i) iva' ,i,JPOOB1(I),jpoob4(i)
  73. IF(.NOT.JPOOB1(I)) THEN
  74. * ON MET A 0 INSTAB CAR LA SPECIFICATION PRECISE QUE LA DONNEE INDICE
  75. * DOIT IMMEDIATEMENT SUIVRE LA DONNEE DE LA TABLE
  76. INSTAB=0
  77. GO TO 10
  78. ENDIF
  79. IF (IBPILN.EQ.0) IBPILN=I
  80. IF (INSTAB.NE.0.AND.LECTAB.EQ.0 ) THEN
  81. * LA DONNEE QUI PRECEDE EST UNE TABLE ou un objet ON REGARDE SI
  82. * CELLE CI EST UN SEPARATEUR SUIVI D'UN INDICE
  83. * DANS CE CAS ON SE CONTENTE DE REMPLACER CE NOUVEL OBJET PAR CELUI
  84. * CONTENU DANS LA TABLE SINON ON REND CE NOUVEL OBJET
  85. * DANS TOUS LES CAS ON POSITIONNE INSTAB A 0
  86. ISUCC=INSTAB
  87. * write (6,*) ' lirabj appel a rempil '
  88. CALL REMPIL(I-1,ISUCC)
  89. * write(6,*) ' apres rempil i isucc',i,isucc
  90. iextab=0
  91. if (i+1.le.ihpile) then
  92. if (jtyobj(i+1).eq.'TABLE '.and.isucc.eq.1) iextab=1
  93. endif
  94. * if( iimpi.eq.1876) call ecpil ('lirabj boucle')
  95. INSTAB=0
  96. IF(IERR.NE.0) RETURN
  97. IF(ISUCC.EQ.1.AND.ILTTA.EQ.I-1) ILTTA=0
  98. IF(ISUCC.EQ.1) GO TO 1
  99. ENDIF
  100.  
  101. C----------------------------
  102. C VECTORIZATION avec LISTOBJE
  103. C----------------------------
  104. C
  105. C Si LISTOBJE de contenu 'ESCLAVE' en sequentiel, remplace par les
  106. C objets resultat lorsqu'ils sont disponibles et on met MLOBJE.TYPOBJ
  107. C a jour
  108. C
  109. IF ( jtyobj(I) .eq. 'LISTOBJE' .and. LUPARA .eq. 0) THEN
  110. MLOBJE = JPOOB4(I)
  111. segact, MLOBJE
  112. NOBJ1 =MLOBJE.LISOBJ(/1)
  113.  
  114. if (MLOBJE.TYPOBJ .eq. 'ESCLAVE ' .and. NOBJ1 .GT. 0) then
  115. if (iimpi .eq. 1234) write(ioimp,*)
  116. & 'Liste d''objets esclaves utilisee en sequentiel !!',MLOBJE
  117. LOMISA = .FALSE.
  118. if (.not.lodesl.or.ith.ne.0) lomisa = .true.
  119.  
  120. IF ( LOMISA ) THEN
  121. call oooeta(mcoord,ieta,imod)
  122. if (ieta.eq.1) segdes mcoord
  123.  
  124. C On attend que les NOBJ1 objets soient disponibles en partant du dernier
  125. DO 13 IOB1=NOBJ1,1,-1
  126. MESRES =MLOBJE.LISOBJ(IOB1)
  127. SEGACT MESRES
  128. if (.not.loremp) then
  129. 130 continue
  130. segdes mesres*record
  131. SEGACT MESRES*(ECR=1,MOD)
  132. if (.not.loremp) then
  133. write(6,*) ' loremp pas vrai dans lirabj '
  134. goto 130
  135. endif
  136. endif
  137. if (ieta.eq.1) segact mcoord
  138. if (iimpi .eq. 1234)
  139. & write(ioimp,*) 'le segment a ete mis a jour ',MESRES
  140. call decesc(mesres,desret,desrev)
  141.  
  142. C Remplacement de l'objet et placement du type
  143. segact, MLOBJE*MOD
  144. MLOBJE.LISOBJ(IOB1) = desrev
  145. if(MLOBJE.TYPOBJ .eq.'ESCLAVE ') MLOBJE.TYPOBJ = desret
  146.  
  147. SEGDES, MESRES
  148. 13 continue
  149. ENDIF
  150. endif
  151.  
  152. SEGACT, MLOBJE
  153. IF (LISOBJ(/1).NE.0) THEN
  154. CALL PLAMO8(LTYPOB,NTYPOB,IPLA,MLOBJE.TYPOBJ)
  155. ** IF (IPLA.EQ.0) THEN
  156. ** CALL ERREUR(1138)
  157. ** RETURN
  158. ** ENDIF
  159. ENDIF
  160. ENDIF
  161.  
  162. C----------------------------
  163. C Actualisation objet ESCLAVE
  164. C----------------------------
  165. C
  166. C JYY
  167. IF ( jtyobj(I) .eq. 'ESCLAVE ' ) then
  168. MESRES = JPOOB4(I)
  169. if (iimpi .eq. 1234)
  170. & write(ioimp,*) ' un objet esclave utilise !!!',mesres
  171. LOMISA = .FALSE.
  172. if (.not.lodesl.or.ith.ne.0) lomisa =.true.
  173. C * il faut faire la mise a jour pour continuer le travail
  174. C * mise a jour eventuelle et menage eventuel
  175. IF ( LOMISA ) THEN
  176. * on essaye de recuperer un travail d'assistant. A priori mcoord est
  177. * actif et le pauvre assistant risque d'etre bloque dessus
  178. * on va donc desactiver mcoord puis le reactiver son etat
  179. * de même pour la tétralogie ipflo...
  180. *
  181. call oooeta(mcoord,ieta,imod)
  182. if (ieta.eq.1) segdes mcoord
  183. SEGACT MESRES
  184. if (.not. loremp) then
  185. 15 continue
  186. segdes mesres*record
  187. SEGACT MESRES*(ECR=1,MOD)
  188. if (.not. loremp) then
  189. write(6,*) ' loremp pas vrai dans lirabj '
  190. goto 15
  191. endif
  192. endif
  193. if (ieta.eq.1) segact,mcoord
  194. if (iimpi .eq. 1234)
  195. & write(ioimp,*) 'le segment a ete mis a jour ',MESRES
  196.  
  197. call decesc(mesres,desret,desrev)
  198. JPOOB4(I) = desrev
  199. JTYOBJ(I) = desret
  200. * c'est un element d'une table on ne fais pas de mise a jour de celle ci
  201. indic1 = JPOOB2(I)
  202. if (indic1.eq.0) then
  203. * write (6,*) 'lirabj esclave mais pas de nom '
  204. else
  205. iouep2(indic1)=desrev
  206. inoob2(indic1)=desret
  207. endif
  208. SEGDES MESRES
  209. ENDIF
  210. ENDIF
  211. C JYYY
  212.  
  213. JTYOBI=JTYOBJ(I)
  214. * write(6,*) ' jtyobi itype iextab ',jtyobi,itype ,iextab
  215. IF(ITYPE(1:8).EQ.JTYOBI.and.iextab.eq.0) GO TO 11
  216. IF(JTYP) THEN
  217. IF(ITYP.EQ.JTYOBI.and.iextab.eq.0) GO TO 11
  218. ENDIF
  219. IF(INTEXT.EQ.0.AND.JTYOBI.EQ.'TEXTE ') THEN
  220. C ON VIENT DE TOMBER SUR UN OBJET DE TYPE TEXTE
  221. IIO=JPOOB4(I)
  222. CALL INSPIL(IIO,I)
  223. GO TO 5
  224. ENDIF
  225. IF(ITYPE(1:8).EQ.MOVID8) THEN
  226. IF(JTYOBI.NE.'SEPARATE'.AND.JTYOBI.NE.'TABLE '.AND.
  227. $ JTYOBI.NE.'METHODOL' ) GO TO 11
  228. ENDIF
  229. * write(6,*) ' iblqm ' , iblqm
  230. if (iblqm.eq.1) then
  231. IF (JTYOBI.EQ.'MOT ') GOTO 20
  232. IF (JTYOBI.EQ.'PROCEDUR') GOTO 20
  233. endif
  234. IF(JTYOBI.EQ.'TABLE '.OR.JTYOBI.EQ.'OBJET ') THEN
  235. INSTAB=1
  236. * write(6,*) ' on positionne instab à 1'
  237. IF(ILTTA.EQ.0) ILTTA=I
  238. ENDIF
  239. IF(JTYOBI.EQ.'METHODOL') THEN
  240. IF(MOBJCO.NE.0) THEN
  241. IF(ITYPE(1:6).EQ.'OBJET ') THEN
  242. JPOOB4(I) =MOBJCO
  243. GO TO 11
  244. ENDIF
  245. INSTAB=2
  246. IF(ILTTA.EQ.0) ILTTA=I
  247. ELSE
  248. IF(ITYPE(1:8).EQ.MOVID8) GO TO 11
  249. ENDIF
  250. ENDIF
  251. 10 CONTINUE
  252. 2 CONTINUE
  253. C********************** IL N'EN EXISTE PAS
  254. C********************** ON VA LIRE DANS LA TABLE INTERMEDIAIRE
  255. IF(ISTOP.EQ.1) GO TO 20
  256. IPLAC=ITINTE(IINTPO)
  257. * write (6,*) ' iplac dans lirabj apres 2 ',iplac
  258. IRAZ=IPLAC
  259. IF(IRAZ.LE.0) GO TO 28
  260. N= JTYOBJ(/2)
  261. IF( IHPILE.GE.N) THEN
  262. N=N+1
  263. SEGADJ JPOOB
  264. JTYOBJ(N)=' '
  265. ENDIF
  266. IIP=IOUEP2(IPLAC)
  267. IF(INOOB2(IPLAC).EQ.MOVID8) THEN
  268. * ON MET INSTAB A ZERO
  269. INSTAB=0
  270. IINTPO=IINTPO+1
  271. GO TO 2
  272. ENDIF
  273. IHPILE=IHPILE+1
  274. interm=inoob2(iplac)
  275. JTYOBJ(IHPILE)=interm
  276. JPOOB1(IHPILE)=.TRUE.
  277. JPOOB2(IHPILE)=IPLAC
  278. JPOOB4(IHPILE)=IIP
  279. I=IHPILE
  280. IINTPO=IINTPO+1
  281. C************************** ON VIENT DE LIRE UN OBJET
  282. INSTAB=0
  283. * write (6,*) ' lirabj iintpo itinte interm ',iintpo,itinte(iintpo),
  284. * > interm
  285. if( interm.eq.ITYPE(1:8)) go to 1
  286. if (itinte(iintpo).gt.0.and.
  287. > (interm.eq.'TABLE '.or.interm.eq.'SEPARATE')) goto 2
  288. if (jtyobj(ihpile-2).eq.'TABLE '.AND.
  289. > jtyobj(ihpile-1).eq.'SEPARATE') iextab=1
  290. * write (6,*) ' jtyobj instab ',jtyobj(ihpile-2),
  291. * > jtyobj(ihpile-1),jtyobj(ihpile),instab
  292. GO TO 1
  293. 11 CONTINUE
  294. C**************************** ON A TROUVE L'INFORMATION DEMANDE
  295. * write (6,*) ' ancien ibpile ',ibpile,' nouveau ',ibpiln
  296. IPLAC=JPOOB2(I)
  297. * write (6,*) ' iplac dans lirabj apres 11 ',iplac,jtyobj(i)
  298. IF (IBPILN.NE.0) IBPILE=IBPILN
  299. IRETOU=1
  300. IF(ITYPE(1:8).EQ.MOVID8.AND.ILTTA.NE.0) THEN
  301. I = ILTTA
  302. ENDIF
  303. * write(6,*) ' i ' , i
  304. JPOOB1(I)=.FALSE.
  305. IF(ITYPE(1:8).EQ.'FLOTTANT'.AND.JTYOBJ(I).EQ.'ENTIER ') THEN
  306. ITYPE='ENTIER '
  307. ENDIF
  308. IRET=JPOOB4(I)
  309. MESERR=0
  310. IF(JTYOBJ(I).EQ.'PROCEDUR'.AND.ITYPE(1:4).EQ.'MOT ') THEN
  311. C FAIRE ATTENTION POUR REMPLACEMENT D'UNE PROCEDURE PAR SON NOM
  312. C DE TYPE MOT
  313. * IF(iimpi.eq.1754.OR.iimpi.eq.1876)
  314. * $ write (6,fmt='('' remplacement ''
  315. * $ ,'' d une procedure par son nom'')')
  316. IRET=INOOB1(IPLAC)
  317.  
  318. ITYPE='MOT '
  319. IMOTLU=I
  320. if(iimpi.eq.1876) write(6,*) ' imotlu ', imotlu
  321. * IF(IIMPI.EQ.1876)THEN
  322. * do 255 IK=IBPILE,IHPILE
  323. * write(6,*) 'lirabj IK JTYOBj JPOOB1 JPOOB2 JPOOB4',
  324. * $ ik, JTYOBJ(IK),JPOOB1(IK),JPOOB2(IK),JPOOB4(IK)
  325. * 255 continue
  326. * write(6,*) 'on a trouver type valeur',itype,iret
  327. * ENDIF
  328. RETURN
  329. ENDIF
  330. IMOTLU=I
  331. IF(ITYPE(1:8).EQ.'TEXTE ') INTEXT=0
  332. IF(ITYPE(1:8).NE.MOVID8) RETURN
  333. ITYPE=JTYOBJ(I)
  334. * IF(IIMPI.EQ.1876)THEN
  335. * do 254 IK=IBPILE,IHPILE
  336. * write(6,*) 'lirabj IK JTYOBj JPOOB1 JPOOB2 JPOOB4',
  337. * $ ik, JTYOBJ(IK),JPOOB1(IK),JPOOB2(IK),JPOOB4(IK)
  338. * 254 continue
  339. * write(6,*) 'on a trouver type valeur',itype,iret
  340. * ENDIF
  341. RETURN
  342. C******************************** LECTURE DU POINT VIRGULE
  343. 28 ISTOP=1
  344.  
  345. C******************************** ON N'A PAS TROUVEE L'INFORMATION
  346. 20 CONTINUE
  347. C DANS LE CAS DE LECTURE BLANCHE ET DE LA SEULE PRESENCE D'UNE TABLE
  348. C ON ARRIVE ICI AVEC ILTTA NE 0
  349. IF(ILTTA.NE.0) THEN
  350. IF(ITYPE(1:8).EQ.MOVID8) THEN
  351. ISTOP=0
  352. ITYPE = 'TABLE '
  353. IMOTLU= ILTTA
  354. IRETOU=1
  355. JPOOB1(IMOTLU)=.FALSE.
  356. IRET=JPOOB4(IMOTLU)
  357. MESERR=0
  358. RETURN
  359. ENDIF
  360. ENDIF
  361. IRETOU=0
  362. IF(ICODE.gt.0) goto 31
  363. 30 IF (ITYPE(1:8).EQ.'TEXTE ') INTEXT=0
  364. RETURN
  365. 31 CONTINUE
  366. MOTERR(1:8)=ITYPE
  367. CALL ERREUR(37)
  368. IF (ITYPE(1:8).EQ.'TEXTE ') INTEXT=0
  369. MESERR=0
  370.  
  371. END
  372.  
  373.  
  374.  
  375.  
  376.  
  377.  
  378.  
  379.  
  380.  
  381.  

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