1 : C FILLPO SOURCE PV 07/04/18 21:15:03 5722 2 : SUBROUTINE FILLPO (ICOLAC,MTY) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C----------------------------------------------------------------- 6 : C A PARTIR DE TOUS LES TYPES EXISTANTS REMPLIT LES PILES 7 : C CONNUES ET TRAITEES PAR TYPFIL 8 : C ENTREE: MTY POINTEUR SUR LE SEGMENT DES TYPES A TRAITER 9 : C LES PILES DOIVENT AVOIR ETE CREES ET INITIALISEES AUPARAVANT 10 : C APPELE PAR : SAUV 11 : C APPELLE : REPERT AJOUN ERREUR 12 : C----------------------------------------------------------------- 13 : -INC CCOPTIO 14 : -INC TMLCHA8 15 : -INC TMCOLAC 16 : -INC CCASSIS 17 : common/pil/itabb 18 : SEGMENT ILISBB 19 : INTEGER ILISOB(MLON) 20 : ENDSEGMENT 21 : DIMENSION IBID(1) 22 : CHARACTER*(1) CHARIN 23 : LOGICAL LOGIN 24 : REAL*8 XVA 25 : CHARACTER*(8) MTYP 26 : C--------------------------------------------------------------------- 27 : MLCHA8=MTY 28 : SEGACT MLCHA8 29 : IN=MLCHAR(/2) 30 : 31 : C---- S'il n'y a rien dans MLCHA8 on s'en va 32 : IF (IN.EQ.0) GO TO 8 33 : 34 : IF (IIMPI.EQ.5) WRITE(IOIMP,800)(MLCHAR(I),I=1,IN) 35 : 800 FORMAT (' LISTE DES TYPES A SAUVER',/(2X,A8)) 36 : 37 : SEGACT ICOLAC 38 : itabb=kcola(39) 39 : ILISSE=ILISSG 40 : SEGACT ILISSE*MOD 40 : CALL LISTOB(MTYP,MLON,IBID,0) 41 : SEGINI ILISBB 42 : C---- IN = taille du tableau des types dans MLCHAR 43 : DO 3 II=1,IN 44 : 45 : MTYP=MLCHAR(II) 46 : 47 : IF (IIMPI.EQ.5) WRITE(IOIMP,101) MTYP 48 : 49 : K=0 49 : CALL TYPFIL (MTYP,K) 50 : 51 : C------- Si MTYP = ' ' ou un type inconnu par TYPFIL, K devient -NPOSSI 52 : C dans ce cas la, on va traiter le suivant 53 : IF (K.LE.0) THEN 54 : C --------- ICI UN WRITE PILE NON TRAITEE 55 : MOTERR(1:8)=MLCHAR(II) 56 : GO TO 3 57 : ENDIF 58 : 59 : C ------ Sinon : 60 : 7 CONTINUE 60 : CALL LISTOB(MTYP,ITITI,ILISOB,1) 61 : IF (ITITI.EQ.0) GO TO 3 62 : ITLACC=KCOLA(K) 63 : NUMLIS=1 64 : ITYP=K 65 : IF(ITYP.EQ.24) NUMLIS=6 66 : IF(ITYP.EQ.25) NUMLIS=4 67 : IF(ITYP.EQ.26) NUMLIS=2 68 : IF(ITYP.EQ.27) NUMLIS=5 69 : IF(ITYP.EQ.32) NUMLIS=3 70 : IF(ITYP.EQ.36) NUMLIS=7 71 : DO 10 I=1,ITITI 72 : IOBVAL=ILISOB(I) 73 : IF(IIMPI.EQ.5) WRITE(IOIMP,102) MTYP,IOBVAL 74 : * 75 : * cas particulier des procedures non deja decodée 76 : IF(ITYP.EQ.36.AND.IOBVAL.LE.0) GO TO 10 77 : C---------- Rajoute l'objet IOBVAL sur la pile ITLACC s'il n'y est pas encore 78 : C La valeur IOBVAL en sortie contient son numero sur la pile, elle 79 : C est ici ignoree 79 : CALL AJOUN (ITLACC,IOBVAL,ILISSE,NUMLIS) 80 : 10 CONTINUE 81 : C 82 : 3 CONTINUE 83 : * la liste des objets esclaves s'obtient en plus a partir des mesins 83 : CALL TYPFIL ('ESCLAVE ',K) 83 : CALL TYPFIL ('LISTMOTS',K1) 84 : * write (6,*) ' fillpo numero de la pile esclave ',k 85 : itlac2=kcola(k) 86 : itlac1=kcola(k1) 87 : if (nbesc.ne.0) then 88 : do 20 ith=0,nbesc 89 : mesins=mescl(ith) 90 : segact mesins*mod 91 : do 30 ins=0,nbins 92 : if (ins.eq.0) then 93 : mescla=inscou 94 : if (mescla.eq.0) goto 30 95 : else 96 : mescla=lismes(ins) 97 : endif 98 : segact mescla 99 : mlmot1=jpcar1 100 : numlis=1 100 : if (mlmot1.ne.0) call ajoun(itlac1,mlmot1,ilisse,numlis) 101 : do 40 ies=1,100 102 : if (esrees(ies).eq.0) goto 40 103 : mesres=esrees(ies) 104 : numlis=1 105 : * write (6,*) ' fillp2 ajout de l esclave ',mesres 105 : call ajoun(itlac2,mesres,ilisse,numlis) 106 : 40 continue 107 : * il faut aussi rajouter les objet contenus dans les instructions en attente sur 108 : * les esclaves 109 : do 50 iop=1,100 110 : if (esoplu(iop)) goto 50 111 : mtyp=esopty(iop) 112 : K=0 112 : CALL TYPFIL (MTYP,K) 113 : IF (K.LE.0) THEN 114 : C --------- ICI UN WRITE PILE NON TRAITEE 115 : MOTERR(1:8)=MLCHAR(II) 116 : GO TO 8 117 : ENDIF 118 : ITLACC=KCOLA(K) 119 : NUMLIS=1 120 : ITYP=K 121 : IF(ITYP.EQ.24) NUMLIS=6 122 : IF(ITYP.EQ.25) NUMLIS=4 123 : IF(ITYP.EQ.26) NUMLIS=2 124 : IF(ITYP.EQ.27) NUMLIS=5 125 : IF(ITYP.EQ.32) NUMLIS=3 126 : IF(ITYP.EQ.36) NUMLIS=7 127 : * logique 128 : IF(ITYP.EQ.24) goto 50 129 : * flottant 130 : IF(ITYP.EQ.25) goto 50 131 : * entier 132 : IF(ITYP.EQ.26) goto 50 133 : * mot 134 : IF(ITYP.EQ.27) goto 50 135 : iobval=esopva(iop) 136 : * write (6,*) ' fillpo instruction contient ', mtyp,iobval 136 : CALL AJOUN (ITLACC,IOBVAL,ILISSE,NUMLIS) 137 : 50 continue 138 : segdes mescla 139 : 30 continue 140 : segdes mesins*record 141 : 20 continue 142 : endif 143 : SEGSUP ILISBB 144 : * SEGDES ILISSE 145 : SEGDES ICOLAC 146 : 8 SEGDES MLCHA8 147 : RETURN 148 : C ------------------------------------- 149 : 102 FORMAT(1X,8(1X,A8,I15)) 150 : 101 FORMAT (/,' OBJETS DE TYPE ',A8) 151 : END 152 : 153 : 154 : 155 : 156 : 157 : 158 : 159 : 160 : 161 : 162 :
© Cast3M 2003 - All rights reserved.
Disclaimer