1 : C LIRNOM SOURCE CHAT 11/05/27 21:15:24 6985 2 : C LIRNOM SOURCE CHAT 06/03/29 21:27:09 5360 3 : C 4 : C FOURNIT A LIRE UNE PHRASE ELEMENTAIRE MISE EN PILE SOUS FORME DECODEE 5 : C 6 : C DEFINITION DE LA PILE : 7 : C ITANOM( ILONG) CONTIENT LES ADRESSES DANS LA TABLE DES NOMS 8 : C DES NOMS A AFFECTER ET LEURS TYPES. 9 : C 10 : C SI ITINTE(I)=0 SIGNALE FIN DE PHRASE ELEMENTAIRE 11 : C SI ITINTE(I)=-1 SIGNALE FIN DE PHRASE COMPLETE 12 : C SI ITINTE(I)= AUTRE CHOSE DONNE LA POSITION DANS PILE DES NOMS 13 : C 14 : C AUTRES VARIABLES : 15 : C NBNOM = NOMBRE DE NOMS CONTENUS DANS ITANOM 16 : C SI NBNOM=0 LE NOM CONTENUE EST UN NOM 17 : C D'OBJET TEMPORAIRE SONT EXISTENCE EST 18 : C NON GARANTIE. 19 : C INILU =0 SIGNALE QU'IL FAUT INITIALISER LA 20 : C LECTURE PAR L'APPEL A INILIR 21 : C MBFONC = 0 ON SE TROUVE EN REPETITION D'UN BLOC 22 : C REPETER. 23 : C MBLSUP DIFFERENT DE 0 ON SE TROUVE POUR LA 24 : C PREMIERE FOIS DANS UN BLOC REPETER. 25 : SUBROUTINE LIRNOM 26 : IMPLICIT INTEGER(I-N) 27 : -INC CCREDLE 28 : -INC CCNOYAU 29 : -INC CCOPTIO 30 : -INC SMBLOC 31 : -INC CCASSIS 32 : LOGICAL IPEG 33 : sredle=iredle 34 : i100= -100 35 : * write(6,*) ' lirnom mdeobj', mdeobj 35 : IF (INILU.EQ.0) CALL INILIR 36 : IF (MBFONC.EQ.0) THEN 37 : 38 : MBCOUR=MBCOUR+1 39 : MTXBLC=MTXBL 40 : C MTXBLL=MTXBLC(MBCOUR) 41 : C SEGACT MTXBLL 42 : C NBNOM=MTXBLB(/1) 43 : NBNOM=LMTXBM(MBCOUR+1)- LMTXBM(MBCOUR) 44 : C IPVINT=MTXBLA(/1) 45 : IPVINT=MTXBA(MBCOUR+1)-MTXBA(MBCOUR) 46 : IDEF= LMTXBM(MBCOUR) 47 : * write(6,*) ' lirnom mdeobj', mdeobj 48 : if( mbloc.eq.2120910 ) then 49 : * write(6,*)'mbcour nbnom ipvint idef ',mbcour,nbnom,ipvint,idef 50 : endif 51 : DO 103 I=1,NBNOM 52 : C ITANO1(I)=MTXBLB(I) 53 : C ITANOM(I)=MTXBLM(I) 54 : if(MTXBLB(I+IDEF).ge.0) then 55 : ITANO1(I)=MTXBLB(I+IDEF) + mdeobj - 1 56 : * if( itano1(i).eq.646) then 57 : * write(6,*) ' 646 MTXBLB(I+IDEF) mdeobj',MTXBLB(I+IDEF),mdeobj 58 : * endif 59 : else 60 : ITANO1(I)=MTXBLB(I+IDEF)/i100 61 : endif 62 : ITANOM(I)=MTXBLM(I+IDEF) 63 : 103 CONTINUE 64 : IDEF=MTXBA(MBCOUR) 65 : DO 104 I=1,IPVINT 66 : C ITINTE(I)=MTXBLA(I) 67 : if(mtxbla(i+idef).gt.0)then 68 : itinte(i)=MTXBLA(I+IDEF) + mdeobj - 1 69 : elseif( MTXBLA(I+IDEF).lt.-99) then 70 : ITINTE(I)=MTXBLA(I+IDEF)/I100 71 : * write(6,*) ' bizarrequa itinte ' , itinte(i) 72 : else 73 : ITINTE(I)=MTXBLA(I+IDEF) 74 : * write(6,*) ' bizarreter dans lirnom ' ,itinte(i) 75 : endif 76 : * if( mbloc.eq.2120910 ) then 77 : * write(6,*) ' i itinte(I) ',i ,itinte(i) 78 : * endif 79 : 104 CONTINUE 80 : C INTEMP=MTXTEM 81 : INTEMP=MTXTTM(MBCOUR) 82 : NOMLU=1 83 : ISTOP=0 84 : IINTPO=1 85 : C SEGDES MTXBLL 86 : IERR=0 87 : * write(6,*) 'lecture procedur ' 88 : * write(6,*) ' itinte' , (itinte(iou),iou=1,ipvint) 89 : * write(6,*) 'inoob1',( inoob1(ITINTE(IOU)),IOU=1,IPVONT-1) 90 : * write(6,*)' itano1 itanom nbnom',itano1(1),itanom(1),nbnom 91 : RETURN 92 : ENDIF 93 : IPVIR=0 94 : * write(6,*) ' lirnom appel anasyn lmnnom', lmnnom 94 : CALL ANASYN(IPEG,IPVIR) 95 : NOMLU=1 96 : INTEMP=0 97 : NBNOM=0 98 : IINTPO=1 99 : if(ierr.ne.0) return 100 : IF (.NOT.IPEG) GO TO 20 101 : ILUL=0 101 : 1 IF (ILUL.EQ.0) CALL REDLEC(sredle) 102 : IF(IRE.EQ.0) THEN 102 : CALL ERREUR (282) 103 : RETURN 104 : ENDIF 104 : C IF(IRE.NE.3) CALL ERREUR(345) 105 : C IF(IERR.NE.0) RETURN 106 : ILUL=0 107 : IF (MOT(1:1).EQ.'=') GOTO 200 108 : IF (ITANO1(/1).GT.NBNOM) GOTO 2 109 : M=NBNOM+1 110 : SEGADJ ITABNO 111 : ITANOM(M)=' ' 112 : ITANO1(M)=0 113 : 2 NBNOM=NBNOM+1 114 : IREF=NBNOM 115 : IAV=1 115 : CALL PRENOM(IPLAMO,IAV,sredle) 116 : * AFIN DE LIRE CORRECTEMENT L'INDICE D'UNE TABLE SI C'EST UNE CONSTANTE 117 : ITANO1(IREF)=IPLAMO 118 : C ON PEUT INDIQUER APRES LE TYPE DESIRE 118 : CALL REDLEC(sredle) 119 : ILUL=1 120 : IF (MOT(1:1).NE.'*') GOTO 4 120 : CALL REDLEC(sredle) 121 : IF (MOT(1:1).EQ.'=') THEN 122 : ITANOM(IREF)=' ' 123 : ELSE 124 : ITANOM(IREF)=MOT(:8) 125 : ILUL=0 126 : ENDIF 127 : GOTO 1 128 : 4 CONTINUE 129 : ITANOM(IREF)=' ' 130 : GO TO 1 131 : C ON CREE UN NOM D'OBJET TEMPORAIRE 132 : 20 CONTINUE 133 : INTEMP=1 134 : IF (ITANOM(/2).LT.1) THEN 135 : M=1 136 : SEGADJ ITABNO 137 : ENDIF 138 : ITANO1(1)=0 139 : ITANOM(1)=' ' 140 : NBNOM=1 141 : MOT(1:8)='# ' 142 : IF (IPTEM.LT.9) THEN 143 : WRITE (MOT(2:2),FMT='(I1)') IPTEM+1 144 : NCAR=2 145 : ELSE 145 : IF(IPTEM.EQ.99) CALL ERREUR(10) 146 : IF(IERR.NE.0) RETURN 147 : WRITE (MOT(2:3),FMT='(I2)') IPTEM+1 148 : NCAR=3 149 : ENDIF 150 : IRE=3 151 : IAV=1 152 : * write(6,*) ' appel de prenom avec nom temporaire' 152 : CALL PRENOM(IPLAMO,IAV,sredle) 153 : ITANO1(1)= IPLAMO 154 : IPTEM=IPTEM+1 155 : 200 CONTINUE 156 : IPVINT=0 157 : C 158 : C ON VA TRADUIRE LA PHRASE POUR REMPLIR LE TABLEAU INTERMEDIAIRE 159 : C 160 : IF (MBLSUP.NE.0) THEN 161 : MTXBLC=MTXBL 162 : SEGACT MTXBLC*MOD 163 : ENDIF 164 : 21 CONTINUE 165 : ** write(6,*) ' lirnom appel de redlec ' 165 : CALL REDLEC(sredle) 166 : * write(6,*) ' lirnom sortie de redlec ire' , ire 167 : C IRE = 0 FIN DE PHRASE 168 : C METTRE ICI LE SAUVETAGE DE LA PRECOMPILATION DANS LE CAS D'UN BLOC 169 : C 170 : IF (IRE.EQ.0) THEN 171 : IF(ITINTE(/1).LE.IPVINT) THEN 172 : ITINTE(**)=0 173 : ENDIF 174 : IPVINT=IPVINT+1 175 : ITINTE(IPVINT)=0 176 : IF(IPVIR.EQ.1) ITINTE(IPVINT)=-(IPTEM + 1) 177 : C ON EFFACE LA LIGNE (A PARTIR DE = ) 178 : I1=IEGAL 179 : I2=ICOUR-1 180 : DO 7778 II3=I1,I2 181 : TEXT(II3:II3)=' ' 182 : 7778 CONTINUE 183 : IF (INTEMP.NE.0) THEN 184 : IF (ICOUR.LE.2) then 185 : RETURN 186 : endif 187 : if(nbesc.ne.0) segact ipiloc 188 : INCHA=INOOB1(ITANO1(1)) 189 : IDEBCH=IPCHAR(INCHA) 190 : IFINCH= IPCHAR(INCHA+1)-1 191 : TEXT(ICOUR-2:ICOUR)= ICHARA(IDEBCH:IFINCH) 192 : if(nbesc.ne.0) segdes ipiloc 193 : ENDIF 194 : IF(MBLSUP.NE.0) THEN 195 : NINSTV=NINSTV+1 196 : IPVINQ=MTXBA(NINSTV)+IPVINT 197 : IPVINN=MTXBLA(/1) 198 : NINST=LMTXBM(/1) 199 : NBNOMM=MTXBLB(/1) 200 : NBNOML=LMTXBM(NINSTV)+NBNOM 201 : ISEG=0 202 : IF(NINSTV+2.GT.NINST) THEN 203 : NINST= NINST+ 1000 204 : ISEG=1 205 : ENDIF 206 : IF(IPVINQ.GT.IPVINN) THEN 207 : IPVINN=IPVINN+5000 208 : ISEG=1 209 : ENDIF 210 : IF(NBNOML.GT.NBNOMM) THEN 211 : NBNOMM = NBNOMM + 1000 212 : ISEG=1 213 : ENDIF 214 : IF(ISEG.EQ.1) SEGADJ MTXBLC 215 : 216 : C SEGINI MTXBLL 217 : C MTXTEM=INTEMP 218 : MTXTTM(NINSTV)=INTEMP 219 : C NUINST=NBCART 220 : C NUINSV(NINSTV)=NBCART 221 : IDEF= LMTXBM(NINSTV) 222 : * write(6,*) ' nbnom ',nbnom 223 : DO 102 I=1,NBNOM 224 : C MTXBLM(I)=ITANOM(I) 225 : C MTXBLB(I)=ITANO1(I) 226 : MTXBLM(I+IDEF)=ITANOM(I) 227 : if(itano1(i). ge.mdeobj) then 228 : MTXBLB(I+IDEF)=ITANO1(I) - mdeobj + 1 229 : else 230 : MTXBLB(I+IDEF)=ITANO1(I) *I100 231 : endif 232 : 102 CONTINUE 233 : LMTXBM(NINSTV+1)=IDEF+NBNOM 234 : IDEF=MTXBA(NINSTV) 235 : DO 101 I=1,IPVINT 236 : C MTXBLA(I)=ITINTE(I) 237 : if( itinte(i).ge.mdeobj) then 238 : * write(6,*) ' ecriture normal itinte(i) ', itinte(i) 239 : MTXBLA(I+IDEF)=ITINTE(I) - mdeobj + 1 240 : elseif( itinte(i).gt.0) then 241 : * write(6,*) ' on passe bizarre dans lirnom ' ,itinte(I) 242 : MTXBLA(I+IDEF)=ITINTE(I)* I100 243 : else 244 : * write(6,*) ' bizarrebis dans lirnom itinte(i) ',itinte(i) 245 : MTXBLA(I+IDEF)=ITINTE(I) 246 : endif 247 : 101 CONTINUE 248 : * write(6,*)' enr proc mdeobj ',mdeobj 249 : * write(6,*) 'itinte',(itinte(iou),iou=1,ipvint) 250 : * WRITE(6,*)'INOOB1', (INOOB1(ITINTE(IOU)),IOU=1,IPVINT-1) 251 : * write(6,*)'itano1,itanom,nbnom',itano1(1),itanom(1),nbnom 252 : MTXBA(NINSTV+1)= IDEF+IPVINT 253 : C MTXBLC(**)=MTXBLL 254 : C SEGDES MTXBLL 255 : ENDIF 256 : RETURN 257 : ENDIF 258 : C IF(IDEBPR.EQ.1.OR.JARGMT.EQ.1) THEN 259 : C IF(IRE.NE.3.AND.IRE.NE.4) THEN 259 : C CALL ERREUR (6) 260 : C ENDIF 261 : C IRE=4 262 : C ENDIF 263 : IAV=0 264 : * write(6,*) ' lirnom appel de prenom 2 iav 0' 264 : CALL PRENOM(IPLAMO,IAV,sredle) 265 : * write(6,*) ' lirnom appel de prenom 2 iplamo' ,iplamo 266 : * write(6,*) ' inoob1 inoob2 ',inoob1(iplamo),inoob2(iplamo) 267 : IPLINT=ITINTE(/1) 268 : IF(IPVINT.GE.IPLINT) THEN 269 : ITINTE(**)=IPLAMO 270 : ELSE 271 : ITINTE(IPVINT+1)=IPLAMO 272 : ENDIF 273 : * if( iplamo.lt.mdeobj.and.iplamo.gt.0) then 274 : * write(6,*) ' bizarre ',ire,iplamo ,text(1:62) 275 : * endif 276 : IPVINT=IPVINT+1 277 : GO TO 21 278 : END 279 : 280 : 281 : 282 :
© Cast3M 2003 - All rights reserved.
Disclaimer