Sources Esope | Cast3M

fillpo
C FILLPO    SOURCE    CB215821  24/07/17    21:15:05     11961          
      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