Télécharger lirabj.eso

Retour à la liste

Numérotation des lignes :

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

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