C LIRABJ SOURCE JC220346 14/02/19 21:15:02 7941 SUBROUTINE LIRABJ( ITYPE , IRET , ICODE , IRETOU ) IMPLICIT INTEGER(I-N) -INC CCNOYAU -INC CCOPTIO -INC SMBLOC -INC CCASSIS -INC SMCOORD LOGICAL JTYP CHARACTER*(*)ITYPE CHARACTER*(8) ITYP,INTERM CHARACTER*8 JTYOBI * SAVE IPLAC LOGICAL LOMISA,ILOREMP integer desrev character*(8) desret IF(LEN(ITYPE).LT.8) THEN CALL ERREUR(5) RETURN ENDIF iextab=0 * initialisation de lotesc lotesc=.false. ith=0 if (nbesc.ne.0) call ooonth(ith) if (ith.ne.0) lotesc=.true. * write (6,*) ' dans lirabj ',ith if (lotesc) then call liresc(itype,iret,icode,iretou) return endif IF (NOMLU.EQ.0) CALL LIRNOM IRETOU=0 IF (IERR.GT.1) RETURN INSTAB=0 IF (ITYPE.EQ.'TEXTE ') INTEXT=1 ITYP=' ' JTYP=.FALSE. C DANS LE CAS DE LECTURE D'UN FLOTTANT ON ADMET DE LIRE UN ENTIER IF(ITYPE.EQ.'FLOTTANT') THEN ITYP='ENTIER' JTYP=.TRUE. ENDIF C DANS LE CAS DE LECTURE D'UN MOT ON ADMET DE LIRE UNE PROCEDURE IF(ITYPE.EQ.'MOT ') THEN ITYP='PROCEDUR' JTYP=.TRUE. ENDIF * if ( iimpi.eq.1876) THEN * write(6,*) ' lirabj on demande ',itype * write(6,*) ' ibpile,ihpile ',ibpile,ihpile * write(6,*) ' instab,lectab,iextab' ,instab,lectab,iextab * endif 5 L=IHPILE-IBPILE ILTTA=0 INSTAB=0 IF(L) 2,1,1 C********************** ON CHERCHE SI UN OBJET DU TYPE DESIRE EST C********************** DEJA DANS LA PILE 1 IBPILN=0 * write(6,*) ' apres 1 lectab instab iextab ibpile ihpile' * write(6,*) lectab ,instab, iextab, ibpile,ihpile DO 10 I=IBPILE,IHPILE * write(6,*) 'bcl 10 i jpoob1(i) iva' ,i,JPOOB1(I),jpoob4(i) IF(.NOT.JPOOB1(I)) THEN * ON MET A 0 INSTAB CAR LA SPECIFICATION PRECISE QUE LA DONNEE INDICE * DOIT IMMEDIATEMENT SUIVRE LA DONNEE DE LA TABLE INSTAB=0 GO TO 10 ENDIF IF (IBPILN.EQ.0) IBPILN=I IF (INSTAB.NE.0.AND.LECTAB.EQ.0 ) THEN * LA DONNEE QUI PRECEDE EST UNE TABLE ou un objet ON REGARDE SI * CELLE CI EST UN SEPARATEUR SUIVI D'UN INDICE * DANS CE CAS ON SE CONTENTE DE REMPLACER CE NOUVEL OBJET PAR CELUI * CONTENU DANS LA TABLE SINON ON REND CE NOUVEL OBJET * DANS TOUS LES CAS ON POSITIONNE INSTAB A 0 ISUCC=INSTAB * write (6,*) ' lirabj appel a rempil ' CALL REMPIL(I-1,ISUCC) * write(6,*) ' apres rempil i isucc',i,isucc iextab=0 if (i+1.le.ihpile) then if (jtyobj(i+1).eq.'TABLE'.and.isucc.eq.1) iextab=1 endif * if( iimpi.eq.1876) call ecpil ('lirabj boucle') INSTAB=0 IF(IERR.NE.0) RETURN IF(ISUCC.EQ.1.AND.ILTTA.EQ.I-1) ILTTA=0 IF(ISUCC.EQ.1) GO TO 1 ENDIF C JYY IF ( jtyobj(I) .eq. 'ESCLAVE ' ) then MESRES = JPOOB4(I) if (iimpi .eq. 1234) & write(ioimp,*) ' un objet esclave utilise !!!',mesres LOMISA = .FALSE. if (.not.lodesl.or.ith.ne.0) lomisa =.true. C * il faut faire la mise a jour pour continuer le travail C * mise a jour eventuelle et menage eventuel IF ( LOMISA ) THEN * on essaye de recuperer un travail d'assistant. A priori mcoord est * actif et le pauvre assistant risque d'etre bloque dessus * on va donc desactiver mcoord puis le reactiver son etat * de même pour la tétralogie ipflo... * segdes mcoord SEGACT MESRES NESRES = IESRES segact nesres if (.not.loremp) then 15 continue segdes nesres*record segdes mesres SEGACT NESRES*(ECR=1,MOD) segact mesres if (.not.loremp) then write(6,*) ' loremp pas vrai dans lirabj ' goto 15 endif endif segdes mesres segact mcoord if (iimpi .eq. 1234) & write(ioimp,*) 'le segment a ete mis a jour ',MESRES call decesc(nesres,desret,desrev) JPOOB4(I) = desrev JTYOBJ(I) = desret * c'est un element d'une table on ne fais pas de mise a jour de celle ci indic1 = JPOOB2(I) if (indic1.eq.0) then * write (6,*) 'lirabj esclave mais pas de nom ' else iouep2(indic1)=desrev inoob2(indic1)=desret endif SEGDES MESRES,NESRES END IF END IF C JYYY JTYOBI=JTYOBJ(I) * write(6,*) ' jtyobi itype iextab ',jtyobi,itype ,iextab IF(ITYPE.EQ.JTYOBI.and.iextab.eq.0) GO TO 11 IF(JTYP) THEN IF(ITYP.EQ.JTYOBI.and.iextab.eq.0) GO TO 11 ENDIF IF(INTEXT.EQ.0.AND.JTYOBI.EQ.'TEXTE ') THEN C ON VIENT DE TOMBER SUR UN OBJET DE TYPE TEXTE IIO=JPOOB4(I) CALL INSPIL(IIO,I) GO TO 5 ENDIF IF(ITYPE.EQ.' ') THEN IF(JTYOBI.NE.'SEPARATE'.AND.JTYOBI.NE.'TABLE '.AND. $ JTYOBI.NE.'METHODOL' ) GO TO 11 ENDIF * write(6,*) ' iblqm ' , iblqm if (iblqm.eq.1) then IF (JTYOBI.EQ.'MOT ') GOTO 20 IF (JTYOBI.EQ.'PROCEDUR') GOTO 20 endif IF(JTYOBI.EQ.'TABLE '.OR.JTYOBI.EQ.'OBJET ') THEN INSTAB=1 * write(6,*) ' on positionne instab à 1' IF(ILTTA.EQ.0) ILTTA=I ENDIF IF(JTYOBI.EQ.'METHODOL') THEN IF(MOBJCO.NE.0) THEN IF(ITYPE.EQ.'OBJET ') THEN JPOOB4(I) =MOBJCO GO TO 11 ENDIF INSTAB=2 IF(ILTTA.EQ.0) ILTTA=I ELSE IF(ITYPE.EQ.' ') GO TO 11 ENDIF ENDIF 10 CONTINUE 2 CONTINUE C********************** IL N'EN EXISTE PAS C********************** ON VA LIRE DANS LA TABLE INTERMEDIAIRE IF(ISTOP.EQ.1) GO TO 20 IPLAC=ITINTE(IINTPO) * write (6,*) ' iplac dans lirabj apres 2 ',iplac IRAZ=IPLAC IF(IRAZ.LE.0) GO TO 28 N= JTYOBJ(/2) IF( IHPILE.GE.N) THEN N=N+1 SEGADJ JPOOB JTYOBJ(N)=' ' ENDIF IIP=IOUEP2(IPLAC) IF(INOOB2(IPLAC).EQ.' ') THEN * ON MET INSTAB A ZERO INSTAB=0 IINTPO=IINTPO+1 GO TO 2 ENDIF IHPILE=IHPILE+1 interm=inoob2(iplac) JTYOBJ(IHPILE)=interm JPOOB1(IHPILE)=.TRUE. JPOOB2(IHPILE)=IPLAC JPOOB4(IHPILE)=IIP I=IHPILE IINTPO=IINTPO+1 C************************** ON VIENT DE LIRE UN OBJET INSTAB=0 * write (6,*) ' lirabj iintpo itinte interm ',iintpo,itinte(iintpo), * > interm if( interm.eq.itype) go to 1 if (itinte(iintpo).gt.0.and. > (interm.eq.'TABLE'.or.interm.eq.'SEPARATE')) goto 2 if (jtyobj(ihpile-2).eq.'TABLE'.AND. > jtyobj(ihpile-1).eq.'SEPARATE') iextab=1 * write (6,*) ' jtyobj instab ',jtyobj(ihpile-2), * > jtyobj(ihpile-1),jtyobj(ihpile),instab GO TO 1 11 CONTINUE C**************************** ON A TROUVE L'INFORMATION DEMANDE * write (6,*) ' ancien ibpile ',ibpile,' nouveau ',ibpiln IPLAC=JPOOB2(I) * write (6,*) ' iplac dans lirabj apres 11 ',iplac,jtyobj(i) IF (IBPILN.NE.0) IBPILE=IBPILN IRETOU=1 IF(ITYPE.EQ.' '.AND.ILTTA.NE.0) THEN I = ILTTA ENDIF * write(6,*) ' i ' , i JPOOB1(I)=.FALSE. IF(ITYPE.EQ.'FLOTTANT'.AND.JTYOBJ(I).EQ.'ENTIER') THEN ITYPE='ENTIER ' ENDIF IRET=JPOOB4(I) MESERR=0 IF(JTYOBJ(I).EQ.'PROCEDUR'.AND.ITYPE.EQ.'MOT') THEN C FAIRE ATTENTION POUR REMPLACEMENT D'UNE PROCEDURE PAR SON NOM C DE TYPE MOT * IF(iimpi.eq.1754.OR.iimpi.eq.1876) * $ write (6,fmt='('' remplacement '' * $ ,'' d une procedure par son nom'')') IRET=INOOB1(IPLAC) ITYPE='MOT ' IMOTLU=I if(iimpi.eq.1876) write(6,*) ' imotlu ', imotlu * IF(IIMPI.EQ.1876)THEN * do 255 IK=IBPILE,IHPILE * write(6,*) 'lirabj IK JTYOBj JPOOB1 JPOOB2 JPOOB4', * $ ik, JTYOBJ(IK),JPOOB1(IK),JPOOB2(IK),JPOOB4(IK) * 255 continue * write(6,*) 'on a trouver type valeur',itype,iret * ENDIF RETURN ENDIF IMOTLU=I IF (ITYPE.EQ.'TEXTE ') INTEXT=0 IF(ITYPE.NE.' ') RETURN ITYPE=JTYOBJ(I) * IF(IIMPI.EQ.1876)THEN * do 254 IK=IBPILE,IHPILE * write(6,*) 'lirabj IK JTYOBj JPOOB1 JPOOB2 JPOOB4', * $ ik, JTYOBJ(IK),JPOOB1(IK),JPOOB2(IK),JPOOB4(IK) * 254 continue * write(6,*) 'on a trouver type valeur',itype,iret * ENDIF RETURN C******************************** LECTURE DU POINT VIRGULE 28 ISTOP=1 C******************************** ON N'A PAS TROUVEE L'INFORMATION 20 CONTINUE C DANS LE CAS DE LECTURE BLANCHE ET DE LA SEULE PRESENCE D'UNE TABLE C ON ARRIVE ICI AVEC ILTTA NE 0 IF(ILTTA.NE.0) THEN IF(ITYPE.EQ.' ') THEN ISTOP=0 ITYPE = 'TABLE ' IMOTLU= ILTTA IRETOU=1 JPOOB1(IMOTLU)=.FALSE. IRET=JPOOB4(IMOTLU) MESERR=0 RETURN ENDIF ENDIF IRETOU=0 IF(ICODE) 30,30,31 30 IF (ITYPE.EQ.'TEXTE ') INTEXT=0 RETURN 31 CONTINUE MOTERR(1:8)=ITYPE CALL ERREUR(37) IF (ITYPE.EQ.'TEXTE ') INTEXT=0 MESERR=0 RETURN END