1 : C MAPR SOURCE JC220346 14/02/17 21:15:09 7942 2 : SUBROUTINE MAPR (IRZTC) 3 : IMPLICIT INTEGER(I-N) 4 : -INC CCOPTIO 5 : -INC SMBLOC 6 : -INC CCNOYAU 7 : -INC CCASSIS 8 : SEGMENT ISEGP1 9 : INTEGER NOMMM(NIS) 10 : ENDSEGMENT 11 : SEGMENT ISEGP2 12 : CHARACTER*(8) NTYP(NIS) 13 : ENDSEGMENT 14 : SEGMENT ISEGP3 15 : INTEGER IOBLI(NIS) 16 : ENDSEGMENT 17 : SEGMENT ISEGP4 18 : CHARACTER*(8) NSSTYP(NIS) 19 : ENDSEGMENT 20 : SEGMENT ISEGP5 21 : INTEGER ILSSTY(NIS) 22 : ENDSEGMENT 23 : SEGMENT ISEG3 24 : INTEGER IRESAR(NIS) 25 : ENDSEGMENT 26 : SEGMENT IITRA 27 : integer ilevel(nlev),isino(nlev,nsi) 28 : ENDSEGMENT 29 : CHARACTER*(8) ICHA,INOMP,CHAANC,NAM 30 : LOGICAL LOGI 31 : REAL*8 XRET 32 : DIMENSION LIRM(7) 33 : CHARACTER*4 MCLE(7), MAST(2) 34 : DATA MCLE/'REPE','FIN ','FINP','FINM','SI','SINO','FINS'/ 35 : DATA MAST/'* ','/ '/ 36 : C LECTURE DU NOM DE LA PROCEDURE 37 : if(iimpi.eq.1756)write(6,*)'avant appel quetyp lmnnno ',lmnnom 38 : * if(iimpi.eq.1876) write(6,*) ' mapr appel quetyp' 38 : CALL QUETYP (CHAANC ,0,IRETOU) 39 : if(iimpi.eq.1756) write(6,*)'mapr retour quetyp',chaanc ,lmnnom 40 : IF(IRETOU.EQ.0) RETURN 41 : IF(IERR.NE.0) RETURN 42 : IF(CHAANC.EQ.'ENTIER ') THEN 42 : CALL LIRENT ( II,1,IRETOU) 43 : ELSEIF(CHAANC.EQ.'FLOTTANT') THEN 43 : CALL LIRREE(XRET,1,IRETOU) 44 : ELSEIF(CHAANC.EQ.'MOT ') THEN 45 : * if(iimpi.eq.1876) write(6,*) ' mapr appel lircha' 45 : CALL LIRCHA(ICHA,1,IRETOU) 46 : ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN 46 : CALL LIRLOG(LOGI,1,IRETOU) 47 : ELSE 47 : CALL LIROBJ(CHAANC,IRET,1,IRETOU) 48 : ENDIF 48 : CALL QUENOM ( ICHA) 49 : if(iimpi.eq.1756) write(6,*) ' mapr nom de la procedur' , icha 50 : IF(ICHA.EQ.' ') THEN 50 : CALL ERREUR(21 ) 51 : RETURN 52 : ENDIF 53 : IF(IERR.NE.0) RETURN 54 : SEGINI MBLO1 55 : NVQTEM=20 56 : SEGINI ISSPOT 57 : MBLO1.ISPOTE=ISSPOT 58 : INOMP=ICHA 59 : * write(6,*) ' lmnnom avant nomobj' , lmnnom 59 : CALL NOMOBJ('PROCEDUR',INOMP,MBLO1) 60 : * write(6,*) ' lmnnom apres nomobj' , lmnnom 61 : moterr(1:8)=inomp 62 : IF(IIMPI.EQ.1754)WRITE(IOIMP,101) ICHA 63 : 101 FORMAT(' DANS MAPR NOM DE LA PROCEDURE ' ,A8) 64 : IARG=0 65 : MBLO1.MARGUM=0 66 : NIS=0 67 : SEGINI ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5 68 : C LECTURE DES ARGUMENTS ET DE LEURS TYPE ON LES METS DANS NOMMM ET NTYP 69 : * ESSAI PV ON VERROUILLE LES TEXTES PENDANT LA LECTURE DES ARGUMENTS 70 : INTEXT=1 71 : 1 CONTINUE 72 : ICHA=' ' 72 : CALL QUETYP (CHAANC ,0,IRETOU) 73 : * WRITE(6,FMT='('' CHAANC APRES QUETYP '',A8)') CHAANC 74 : IF(IRETOU.EQ.0) GOTO 2 75 : IF(IERR.NE.0) RETURN 76 : IF(CHAANC.EQ.'ENTIER ') THEN 76 : CALL LIRENT ( II,1,IRETOU) 77 : ELSEIF(CHAANC.EQ.'FLOTTANT') THEN 77 : CALL LIRREE(XRET,1,IRETOU) 78 : ELSEIF(CHAANC.EQ.'MOT ') THEN 78 : CALL LIRCHA(ICHA,1,IRETOU) 79 : ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN 79 : CALL LIRLOG(LOGI,1,IRETOU) 80 : ELSE 80 : CALL LIROBJ(CHAANC,IRET,1,IRETOU) 81 : ENDIF 82 : * WRITE(6,FMT='('' CHAANC AVANT QUENON '',A8)') CHAANC 82 : CALL QUENOM ( ICHA) 83 : DO 765 ILW=8,1,-1 84 : IF(ICHA(ILW:ILW).NE.' ') GO TO 764 85 : 765 CONTINUE 86 : 764 LE=ILW 86 : CALL POSCHA(ICHA(1:LE),IPOSCH) 87 : 2 CONTINUE 88 : IF(IRETOU.NE.0) THEN 89 : NIS=NOMMM(/1)+1 90 : SEGADJ ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5 91 : NOMMM(NIS)=IPOSCH 91 : CALL LIRMOT(MAST,2,IAST,0) 92 : IF(IAST.NE.0) THEN 92 : CALL LIRCHA(ICHA,1,IRETOU) 93 : IF(IERR.NE.0) GO TO 1500 94 : NTYP(NIS)=ICHA 95 : NSSTYP(NIS)=' ' 96 : ILSSTY(NIS)=0 97 : IF(IAST.EQ.1) THEN 98 : IOBLI(NIS)=1 99 : ELSE 100 : IOBLI(NIS)=0 101 : ENDIF 102 : * WRITE(6,FMT='('' ICHA TYPE DE L ARGUMENT '',A8)') ICHA 103 : IF(ICHA.EQ.'TABLE ') THEN 104 : CHAANC=' ' 104 : CALL QUETYP(CHAANC,0,IRETOU) 105 : IF(CHAANC.NE.'MOT ') GO TO 1 105 : CALL LIRMOT(MAST,1,IAST,0) 106 : IF(IAST.EQ.0) GO TO 1 107 : ICHA=' ' 107 : CALL LIRCHA(ICHA,1,IRETOU) 108 : * WRITE(6,FMT='('' ICHA TYPE DE LA TABLE '',A8)') ICHA 109 : IF(IERR.NE.0) GO TO 1500 110 : NSSTYP(NIS)=ICHA 111 : ILSSTY(NIS)=IRETOU 112 : ENDIF 113 : ELSE 114 : NTYP(NIS)=' ' 115 : NSSTYP=' ' 116 : IOBLI(NIS)=1 117 : ILSSTY(NIS)=0 118 : ENDIF 119 : GO TO 1 120 : ENDIF 121 : NARG=NOMMM(/1) 122 : * FIN VERROUILLAGE TEXTES 123 : INTEXT=0 124 : C CREATION D'UN BLOC REPETE 125 : MTEM=MBLOC 126 : IF(MTXBL.NE.0) THEN 127 : MTXBLC=MTXBL 128 : SEGDES MTXBLC 129 : ENDIF 130 : ISSPOT=ISPOTE 131 : SEGDES ISSPOT 132 : SEGDES MBLOC 133 : MBLOC=MBLO1 134 : MBLSUP=MTEM 135 : lmnpre=lmnnom 136 : * write(6,*) ' entree dans mapr lmnnom',lmnnom 137 : MDEOBJ=LMNNOM+1 138 : NBNOMM=1200 139 : NINST=1200 140 : IPVINN=3000 141 : SEGINI MTXBLC 142 : MTXBL=MTXBLC 143 : MBLPRO=0 144 : MBFONC=1 145 : MBCOUR=0 146 : MBCONT=1 147 : C ECRITURE DES ARGUMENTS DANS LA PILE DES OBJETS POUR QUE 148 : C L'INTERPRETATION NE SOIT PAS DECALEE. 149 : IF(NARG.NE.0) THEN 150 : NN=LMNNOM 151 : N=NN+NARG +1 152 : IF(N.GT.INOOB1(/1) ) THEN 153 : N=N+50 154 : SEGADJ ITABOB,ITABOC,ITABOD 155 : ENDIF 156 : if(nbesc.ne.0) segact ipiloc 157 : DO 30 I=1,NARG 158 : LMNNOM=LMNNOM+1 159 : INOOB1(NN+I)=NOMMM(I) 160 : IF(IIMPI.EQ.1754) THEN 161 : IDEBCH=IPCHAR(NOMMM(I) ) 162 : IFINCH= IPCHAR(NOMMM(I)+1)-1 163 : NAM = ICHARA( IDEBCH:IFINCH) 163 : * CALL NOMCHA (NAM,NAM) 164 : WRITE(IOIMP,6438) NAM,NTYP(I) 165 : 6438 FORMAT(' MAPR : ARGUMENT TYPE ',A8,2X,A8) 166 : ENDIF 167 : 30 CONTINUE 168 : * write(6,*) ' inomp avant aoppel nomobj' , inomp 169 : * ecriture du nom de la procedur 169 : c CALL NOMOBJ('PROCEDUR',INOMP,MBLO1) 170 : if (nbesc.ne.0) segdes ipiloc 171 : ENDIF 172 : NN=LMNNOM 173 : N=NN+4 174 : IF(N.GT.INOOB1(/1) ) THEN 175 : N=N+50 176 : SEGADJ ITABOB,ITABOC,ITABOD 177 : ENDIF 177 : CALL NOMCHA('#1','#1') 177 : CALL NOMCHA('#2','#2') 177 : CALL NOMCHA('#3','#3') 178 : * on ecrit aussi le nom de la procedure pour pouvoir les quitter! 178 : * CALL nomobj('PROCEDUR',INOMP,MBLO1) 179 : IPTEM=0 179 : CALL NOUTRU 180 : LIRM(1)=-1 181 : C ON LIT TOUT JUSQU'AU MOT FINPROCEDURE ou FINMETHODE 182 : MTEMP=MBLOC 183 : nlev=20 184 : nsi=50 185 : segini iitra 186 : ilev=1 187 : 11 CONTINUE 188 : IF(IERR.NE.0) GO TO 1600 188 : CALL NOUTRU 189 : LECTAB=1 190 : INTEXT=1 190 : CALL LIRMO3(MCLE,7,IRET,0,LIRM) 191 : * write(6,fmt='('' lecture repe fin finp'',i6)') iret 192 : LECTAB=0 193 : INTEXT=0 194 : * IF (IRET.EQ.0) GOTO 11 195 : GOTO (21,22,23,23,24,25,26),IRET 195 : 21 CALL REPETE 196 : ilev=ilev+1 197 : if( ilev.gt.nlev) then 198 : nlev=nlev+20 199 : segadj iitra 200 : endif 201 : if(iimpi.eq.5) then 202 : write(6,*)'$$$$$$$$$$$$$$$ nouveau bloc de niveau ilev ' ,ilev 203 : endif 204 : C NE LIRE QU'UNE FOIS LA BOUCLE 205 : MBCONT=1 206 : GOTO 11 207 : 22 CONTINUE 207 : CALL QUETYP ( CHAANC,0,IRETI) 208 : IF(IRETI.EQ.0) GO TO 11 208 : CALL FIN 209 : if(iimpi.eq.5) then 210 : write(6,*)'$$$$$$$$$$$$$$$$ Fermeture du bloc de niveau ' , ilev 211 : endif 212 : if( ilevel(ilev).ne.0) then 213 : moterr(1:8)= inomp 213 : call erreur( 1022) 214 : return 215 : endif 216 : ilev=ilev - 1 217 : GOTO 11 218 : 24 Continue 219 : ilevel(ilev)=ilevel(ilev)+1 220 : if(ilevel(ilev).gt.nsi) then 221 : nsi=nsi+50 222 : segadj iitra 223 : endif 224 : if(iimpi.eq.5) then 225 : ip=ilevel(ilev) 226 : write(6,*) '$$$$$$$$$$$$$$$$$$ ouverture d un ',ip, ' ieme SI' 227 : endif 228 : go to 11 229 : 25 continue 230 : if( iimpi.eq.5) then 231 : ip=ilevel(ilev) 232 : write(6,*) '$$$$$$$$$$$$$$$ SINON du ',ip, 'ieme SI' 233 : endif 234 : if(ilevel(ilev).eq.0) then 235 : moterr(1:8)= inomp 235 : call erreur(1020) 236 : return 237 : endif 238 : if( isino(ilev,ilevel(ilev)).ne.0)then 239 : moterr(1:8)= inomp 239 : call erreur(1024) 240 : return 241 : endif 242 : isino(ilev,ilevel(ilev))=1 243 : go to 11 244 : 26 continue 245 : if(ilevel(ilev).le.0) then 246 : moterr(1:8)= inomp 246 : call erreur(1021) 247 : return 248 : endif 249 : if( iimpi.eq.5) then 250 : ip=ilevel(ilev) 251 : write(6,*) '$$$$$$$$$$$$$$$$ Fermeture du ',ip,' ieme SI' 252 : endif 253 : isino(ilev,ilevel(ilev))=0 254 : ilevel(ilev)=ilevel(ilev) - 1 255 : go to 11 256 : C 257 : C ON VIENT DE LIRE FINPROC 258 : C IL FAUT LIRE LES RESULTATS POUR STOCKER LEURS PLACES DANS LA PILE 259 : C OBJET 260 : C 261 : 23 CONTINUE 262 : if( ilev.ne.1. or . ilevel.(ilev).ne.0) then 263 : moterr(1:8)= inomp 263 : call erreur (1023) 264 : return 265 : endif 266 : segsup iitra 267 : * write(6,fmt='('' lecture finpro'')') 268 : IF (MBLOC.NE.MTEMP) THEN 269 : C 270 : C ON A OUBLIE DE FERMER UN BLOC 271 : C 271 : CALL ERREUR (154) 272 : MBLOC=MTEMP 273 : SEGACT MBLOC*MOD 274 : MTEM=MBLSUP 275 : MTXBLC=MTXBL 276 : SEGDES MTXBLC 277 : ISSPOT=ISPOTE 278 : SEGDES ISSPOT 279 : SEGDES MBLOC 280 : MBLOC=MTEM 281 : SEGACT MBLOC*MOD 282 : ISSPOT=ISPOTE 283 : SEGACT ISSPOT*MOD 284 : MTXBLC=MTXBL 285 : IF(MTXBL.NE.0) SEGACT MTXBLC 285 : CALL NOMOBJ('ANNULE',INOMP,MBLOC) 286 : RETURN 287 : ENDIF 288 : IPTEM=0 288 : CALL NOUTRU 289 : SEGINI IARGUM 290 : MARGUM=IARGUM 291 : MTXMET=IRZTC 292 : * write(6,*) ' mappr mtxmet ', irztc 293 : IF(IIMPI.EQ.1754) WRITE(6,5911) IARGUM,NARG 294 : 5911 FORMAT(' MAPR : IARGUM NARG ',3I5) 295 : IF(NARG.NE.0) THEN 296 : DO 43 I=1,NARG 297 : ILTYPA(I)=ILSSTY(I) 298 : IOBLIG(I)=IOBLI(I) 299 : 43 CONTINUE 300 : DO 41 I=1,NARG 301 : MTYARG(I)=NTYP(I) 302 : MSTYPA(I)=NSSTYP(I) 303 : 41 CONTINUE 304 : ENDIF 305 : SEGSUP ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5 306 : MRESU=MBLOC 307 : C 308 : C ON FERME LE BLOC REPETE on ajuste mtxblc 309 : C 310 : MFIOBJ=LMNNOM 311 : JDEOBJ=MDEOBJ 312 : msapii=mdeobj 313 : MTEM=MBLSUP 314 : MTXBLC=MTXBL 315 : NINST=NINSTV+1 316 : IPVINN=MTXBA(NINST) 317 : NBNOMM=LMTXBM(NINST) 318 : IF(IIMPI.EQ.1756) WRITE(IOIMP,1788)NINST,IPVINN,NBNOMM 319 : 1788 FORMAT(' apres ajustement NINST IPVINN NBNOMM',3I8) 320 : SEGADJ MTXBLC 321 : SEGDES MTXBLC 322 : ISSPOT=ISPOTE 323 : SEGDES ISSPOT 324 : SEGDES MBLOC 325 : MBLOC=MTEM 326 : SEGACT MBLOC*MOD 327 : ISSPOT=ISPOTE 328 : SEGACT ISSPOT*MOD 329 : MTXBLC=MTXBL 330 : IF(MTXBL.NE.0) SEGACT MTXBLC 331 : 332 : C 333 : C ON SAUVE LA VALEUR DES FLOTTANTS 334 : C 335 : NREE = 0 336 : DO 33 I=JDEOBJ,LMNNOM 337 : IF(INOOB2(I).EQ.'FLOTTANT') NREE = NREE + 1 338 : 33 CONTINUE 339 : MTXFLO=0 340 : IF(NREE.NE.0) THEN 341 : SEGINI MTXFL3 342 : MTXFLO=MTXFL3 343 : NREE=0 344 : if(nbesc.ne.0) segact ipiloc 345 : DO 34 I=JDEOBJ,LMNNOM 346 : IF(INOOB2(I).EQ.'FLOTTANT') THEN 347 : NREE = NREE + 1 348 : XTFLO(NREE)= XIFLOT(IOUEP2(I)) 349 : MITFLO(NREE)=I-jdeobj+1 350 : ENDIF 351 : 34 CONTINUE 352 : if(nbesc.ne.0) segdes ipiloc 353 : SEGDES MTXFL3 354 : ENDIF 355 : C 356 : C 357 : SEGDES IARGUM 358 : C 359 : C ** EFFACEMENT DES NOMS D'OBJET DANS LA TABLE 360 : C 361 : NIIS=LMNNOM-JDEOBJ+1 362 : NIS = NIIS 363 : SEGINI MTXBI3 364 : MTXBB=MTXBI3 365 : if(nbesc.ne.0) segact ipiloc 366 : DO 32 I=JDEOBJ,LMNNOM 367 : MTXBI(I-JDEOBJ+1)=INOOB1(I) 368 : mtxbd(i-JDEOBJ+1)=inoob2(i) 369 : mtxbe(i-JDEOBJ+1)=iouep2(i) 370 : IPP= INOOB1(I) 371 : IDEBCH=IPCHAR(INOOB1(I)) 372 : *tc IF(ICHARA(IDEBCH:IDEBCH).EQ.'&'.AND.INOOB2(I).EQ.'ENTIER ') 373 : *tc 1 INOOB2(I)=' ' 374 : INOOB1(I)=0 375 : inoob2(i)=' ' 376 : iouep2(i)=-10000 377 : 32 CONTINUE 378 : if(nbesc.ne.0) segdes ipiloc 379 : SEGDES MTXBI3 380 : SEGDES IARGUM 381 : lmnnom=lmnpre 382 : 383 : RETURN 384 : C 385 : C ERREUR DETECTE APRES INITIALISATION DU BLOC,ON FERME TOUS LES BLOCS 386 : C JUSQU'A CELUI DE LA PROCEDURE 387 : 1600 CONTINUE 388 : IDER = MARGUM 389 : MTEM=MBLSUP 390 : MTXBLC=MTXBL 391 : SEGDES MTXBLC 392 : ISSPOT=ISPOTE 393 : SEGDES ISSPOT 394 : SEGDES MBLOC 395 : MBLOC=MTEM 396 : SEGACT MBLOC*MOD 397 : ISSPOT=ISPOTE 398 : SEGACT ISSPOT*MOD 399 : MTXBLC=MTXBL 400 : IF(MTXBL.NE.0) SEGACT MTXBLC 401 : IF(IDER.EQ.0) GO TO 1500 402 : IARGUM=IDER 403 : SEGDES IARGUM 404 : lmnnom=lmnpre 405 : 1500 CONTINUE 406 : C 407 : C ON A TROUVE UNE ERREUR AVANT D'OUVRIR LE BLOC 408 : C 408 : CALL NOMOBJ('ANNULE',INOMP,MBLO1) 409 : END 410 : 411 : 412 : 413 : 414 : 415 :
© Cast3M 2003 - All rights reserved.
Disclaimer