C FILLPO SOURCE PV090527 24/01/16 21:15:02 11824 SUBROUTINE FILLPO (ICOLAC,MTY) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C----------------------------------------------------------------- C A PARTIR DE TOUS LES TYPES EXISTANTS REMPLIT LES PILES C CONNUES ET TRAITEES PAR TYPFIL C ENTREE: MTY POINTEUR SUR LE SEGMENT DES TYPES A TRAITER C LES PILES DOIVENT AVOIR ETE CREES ET INITIALISEES AUPARAVANT C APPELE PAR : SAUV C APPELLE : REPERT AJOUN ERREUR C----------------------------------------------------------------- -INC PPARAM -INC CCOPTIO -INC TMLCHA8 -INC TMCOLAC -INC CCASSIS -INC SMBLOC -INC CCNOYAU common/pil/itabb SEGMENT ILISBB INTEGER ILISOB(MLON) ENDSEGMENT DIMENSION IBID(1) CHARACTER*(1) CHARIN LOGICAL LOGIN REAL*8 XVA CHARACTER*(8) MTYP C--------------------------------------------------------------------- MLCHA8=MTY SEGACT MLCHA8 IN=MLCHAR(/2) C---- S'il n'y a rien dans MLCHA8 on s'en va IF (IN.EQ.0) GO TO 8 IF (IIMPI.EQ.5) WRITE(IOIMP,800)(MLCHAR(I),I=1,IN) 800 FORMAT (' LISTE DES TYPES A SAUVER',/(2X,A8)) SEGACT ICOLAC itabb=kcola(39) ILISSE=ILISSF SEGACT ILISSE*MOD ILISSE=ILISSP SEGACT ILISSE*MOD ILISSE=ILISSG SEGACT ILISSE*MOD CALL LISTOB(MTYP,MLON,IBID,0) SEGINI ILISBB C---- IN = taille du tableau des types dans MLCHAR DO 3 II=1,IN MTYP=MLCHAR(II) IF (IIMPI.EQ.5) WRITE(IOIMP,101) MTYP K=0 CALL TYPFIL (MTYP,K) C------- Si MTYP = ' ' ou un type inconnu par TYPFIL, K devient -NPOSSI C dans ce cas la, on va traiter le suivant IF (K.LE.0) THEN C --------- ICI UN WRITE PILE NON TRAITEE MOTERR(1:8)=MLCHAR(II) GO TO 3 ENDIF C ------ Sinon : 7 CONTINUE CALL LISTOB(MTYP,ITITI,ILISOB,1) IF (ITITI.EQ.0) GO TO 3 ITLACC=KCOLA(K) NUMLIS=1 ilissd=ilisse ITYP=K IF(ITYP.EQ.24) NUMLIS=6 IF(ITYP.EQ.25) then NUMLIS=3 ilissd=ilissf ENDIF IF(ITYP.EQ.26) NUMLIS=2 IF(ITYP.EQ.27) NUMLIS=5 IF(ITYP.EQ.32) then NUMLIS=3 ilissd=ilissp ENDIF IF(ITYP.EQ.36) NUMLIS=7 DO 10 I=1,ITITI IOBVAL=ILISOB(I) IF(IIMPI.EQ.5) WRITE(IOIMP,102) MTYP,IOBVAL * * cas particulier des procedures non deja decodée IF(ITYP.EQ.36.AND.IOBVAL.LE.0) GO TO 10 C---------- Rajoute l'objet IOBVAL sur la pile ITLACC s'il n'y est pas encore C La valeur IOBVAL en sortie contient son numero sur la pile, elle C est ici ignoree CALL AJOUN (ITLACC,IOBVAL,ILISSd,NUMLIS) 10 CONTINUE C 3 CONTINUE * la liste des objets esclaves s'obtient en plus a partir des mesins CALL TYPFIL ('ESCLAVE ',K) CALL TYPFIL ('LISTMOTS',K1) * write (6,*) ' fillpo numero de la pile esclave ',k itlac2=kcola(k) itlac1=kcola(k1) if (nbesc.ne.0) then do 20 ith=0,nbesc mesins=mescl(ith) if (mesins.eq.0) goto 20 segact mesins*mod do 30 ins=0,nbins if (ins.eq.0) then mescla=inscou if (mescla.eq.0) goto 30 else mescla=lismes(ins) endif segact mescla mlmot1=jpcar1 numlis=1 if (mlmot1.ne.0) call ajoun(itlac1,mlmot1,ilisse,numlis) do 40 ies=1,100 if (esrees(ies).eq.0) goto 40 mesres=esrees(ies) numlis=1 * write (6,*) ' fillp2 ajout de l esclave ',mesres call ajoun(itlac2,mesres,ilisse,numlis) 40 continue * il faut aussi rajouter les objet contenus dans les instructions en attente sur * les esclaves do 50 iop=1,100 if (esoplu(iop)) goto 50 mtyp=esopty(iop) K=0 CALL TYPFIL (MTYP,K) IF (K.LE.0) THEN C --------- ICI UN WRITE PILE NON TRAITEE MOTERR(1:8)=MLCHAR(II) GO TO 8 ENDIF ITLACC=KCOLA(K) NUMLIS=1 ilissd=ilisse ITYP=K IF(ITYP.EQ.24) NUMLIS=6 IF(ITYP.EQ.25) then NUMLIS=3 ilissd=ilissf endif IF(ITYP.EQ.26) NUMLIS=2 IF(ITYP.EQ.27) NUMLIS=5 IF(ITYP.EQ.32) then NUMLIS=3 ilissd=ilissp endif IF(ITYP.EQ.36) NUMLIS=7 * logique IF(ITYP.EQ.24) goto 50 * flottant IF(ITYP.EQ.25) goto 50 * entier IF(ITYP.EQ.26) goto 50 * mot IF(ITYP.EQ.27) goto 50 iobval=esopva(iop) * write (6,*) ' fillpo instruction contient ', mtyp,iobval CALL AJOUN (ITLACC,IOBVAL,ILISSD,NUMLIS) 50 continue segdes mescla 30 continue segdes mesins*record 20 continue endif * rajouter les blocs actifs itlacc=kcola(37) mblo1=mbloc numlis=1 90 continue if (mblo1.ne.0) then segact mblo1*mod ** write(6,*) ' ajout du bloc ',mblo1 iobval=mblo1 call ajoun(itlacc,iobval,ilisse,numlis) if(mblo1.ne.mblo1.mblsup) then mblo1=mblo1.mblsup goto 90 endif endif SEGSUP ILISBB * SEGDES ILISSE SEGDES ICOLAC 8 SEGDES MLCHA8 RETURN C ------------------------------------- 102 FORMAT(1X,8(1X,A8,I15)) 101 FORMAT (/,' OBJETS DE TYPE ',A8) END