C LIRABJ SOURCE SP204843 26/02/03 21:15:29 12461 SUBROUTINE LIRABJ( ITYPE , IRET , ICODE , IRETOU ) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCNOYAU -INC CCOPTIO -INC SMBLOC -INC CCASSIS -INC SMCOORD -INC SMLOBJE LOGICAL JTYP CHARACTER*(*) ITYPE CHARACTER*(8) ITYP,INTERM,MOVID8 CHARACTER*8 JTYOBI * SAVE IPLAC LOGICAL LOMISA,ILOREMP integer desrev character*(8) desret MOVID8=' ' IF(LEN(ITYPE).LT.8) THEN CALL ERREUR(5) RETURN ENDIF iextab=0 * initialisation de lotesc lotesc=.false. ith=0 if (nbesc.ne.0) ith = oothrd 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(1:5).EQ.'TEXTE') INTEXT=1 ITYP=' ' JTYP=.FALSE. C DANS LE CAS DE LECTURE D'UN FLOTTANT ON ADMET DE LIRE UN ENTIER IF (ITYPE(1:8).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(1:4).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 .lt. 0) goto 2 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---------------------------- C VECTORIZATION avec LISTOBJE C---------------------------- C C Si LISTOBJE de contenu 'ESCLAVE' en sequentiel, remplace par les C objets resultat lorsqu'ils sont disponibles et on met MLOBJE.TYPOBJ C a jour C IF ( jtyobj(I) .eq. 'LISTOBJE' .and. LUPARA .eq. 0) THEN MLOBJE = JPOOB4(I) segact, MLOBJE NOBJ1 =MLOBJE.LISOBJ(/1) C On ne regarde pas la dimension du tableau des reels car, si c'est une liste C d'objets esclaves, il s'agit forcemment de pointeurs if (MLOBJE.TYPOBJ .eq. 'ESCLAVE ' .and. NOBJ1 .GT. 0) then if (iimpi .eq. 1234) write(ioimp,*) & 'Liste d''objets esclaves utilisee en sequentiel !!',MLOBJE LOMISA = .FALSE. if (.not.lodesl.or.ith.ne.0) lomisa = .true. IF ( LOMISA ) THEN call oooeta(mcoord,ieta,imod) if (ieta.eq.1) segdes mcoord C On attend que les NOBJ1 objets soient disponibles en partant du dernier IK = 1 DO 13 IOB1=NOBJ1,1,-1 MESRES =MLOBJE.LISOBJ(IOB1) SEGACT MESRES if (.not.loremp) then 130 continue segdes mesres*record SEGACT MESRES*(ECR=1,MOD) if (.not.loremp) then write(6,*) ' loremp pas vrai dans lirabj ' goto 130 endif endif if (ieta.eq.1) segact mcoord if (iimpi .eq. 1234) & write(ioimp,*) 'le segment a ete mis a jour ',MESRES call decesc(mesres,desret,desrev) C Remplacement de l'objet et placement du type segact, MLOBJE*MOD IF (desret.EQ.'FLOTTANT') THEN IK = 2 MLOBJE.RLIREE(IOB1) = desrev ELSE MLOBJE.LISOBJ(IOB1) = desrev ENDIF if(MLOBJE.TYPOBJ .eq.'ESCLAVE ') MLOBJE.TYPOBJ = desret SEGDES, MESRES 13 continue IF (IK.EQ.2) THEN NREE = NOBJ1 NOBJ = 0 SEGADJ,MLOBJE ENDIF ENDIF endif SEGACT, MLOBJE*NOMOD ENDIF C---------------------------- C Actualisation objet ESCLAVE C---------------------------- C 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... * call oooeta(mcoord,ieta,imod) if (ieta.eq.1) segdes mcoord SEGACT MESRES if (.not. loremp) then 15 continue segdes mesres*record SEGACT MESRES*(ECR=1,MOD) if (.not. loremp) then write(6,*) ' loremp pas vrai dans lirabj ' goto 15 endif endif if (ieta.eq.1) segact,mcoord if (iimpi .eq. 1234) & write(ioimp,*) 'le segment a ete mis a jour ',MESRES call decesc(mesres,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 ENDIF ENDIF C JYYY JTYOBI=JTYOBJ(I) * write(6,*) ' jtyobi itype iextab ',jtyobi,itype ,iextab IF(ITYPE(1:8).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(1:8).EQ.MOVID8) 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(1:6).EQ.'OBJET ') THEN JPOOB4(I) =MOBJCO GO TO 11 ENDIF INSTAB=2 IF(ILTTA.EQ.0) ILTTA=I ELSE IF(ITYPE(1:8).EQ.MOVID8) 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.MOVID8) 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(1:8)) 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(1:8).EQ.MOVID8.AND.ILTTA.NE.0) THEN I = ILTTA ENDIF * write(6,*) ' i ' , i JPOOB1(I)=.FALSE. IF(ITYPE(1:8).EQ.'FLOTTANT'.AND.JTYOBJ(I).EQ.'ENTIER ') THEN ITYPE='ENTIER ' ENDIF IRET=JPOOB4(I) MESERR=0 IF(JTYOBJ(I).EQ.'PROCEDUR'.AND.ITYPE(1:4).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(1:8).EQ.'TEXTE ') INTEXT=0 IF(ITYPE(1:8).NE.MOVID8) 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(1:8).EQ.MOVID8) THEN ISTOP=0 ITYPE = 'TABLE ' IMOTLU= ILTTA IRETOU=1 JPOOB1(IMOTLU)=.FALSE. IRET=JPOOB4(IMOTLU) MESERR=0 RETURN ENDIF ENDIF IRETOU=0 IF(ICODE.gt.0) goto 31 30 IF (ITYPE(1:8).EQ.'TEXTE ') INTEXT=0 RETURN 31 CONTINUE MOTERR(1:8)=ITYPE CALL ERREUR(37) IF (ITYPE(1:8).EQ.'TEXTE ') INTEXT=0 MESERR=0 END