1 : C LIPROC SOURCE JC220346 14/01/31 21:15:07 7938 2 : ************************************************************************ 3 : * NOM : LIPROC 4 : * DESCRIPTION : Lit une procedure GIBIANE depuis un fichier externe 5 : ************************************************************************ 6 : * HISTORIQUE : 19/12/2013 : JCARDO : création de la subroutine 7 : * HISTORIQUE : 30/01/2013 : JCARDO : remplissage de la subroutine 8 : * HISTORIQUE : 31/01/2013 : JCARDO : corr. bug appel depuis procedure 9 : * HISTORIQUE : 10 : ************************************************************************ 11 : * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES 12 : * en cas de modification de ce sous-programme afin de faciliter 13 : * la maintenance ! 14 : ************************************************************************ 15 : * APPELÉ PAR : lirefi.eso 16 : ************************************************************************ 17 : * ENTRÉES :: aucune 18 : * SORTIES :: aucune 19 : ************************************************************************ 20 : * SYNTAXE (GIBIANE) : 21 : * 22 : * LIRE 'PROC' NOMFIC1 (MOT1) ; 23 : * 24 : ************************************************************************ 25 : SUBROUTINE LIPROC 26 : 27 : IMPLICIT INTEGER(I-N) 28 : IMPLICIT REAL*8(A-H,O-Z) 29 : 30 : -INC CCNOYAU 31 : -INC CCOPTIO 32 : -INC SMBLOC 33 : -INC CCREDLE 34 : 35 : CHARACTER*512 NOMSRC 36 : CHARACTER*12 NOMPR1,NOMPR2,NOMPR3 37 : CHARACTER*72 CHBUFF 38 : 39 : CHARACTER*4 MDEBP(1) 40 : DATA MDEBP/'DEBP'/ 41 : 42 : PARAMETER(IOTMP=70) 43 : PARAMETER(LTMP=10) 44 : CHARACTER*(LTMP) FITMP 45 : DATA FITMP/'LIPROC.TMP'/ 46 : 47 : SEGMENT ITITE3 48 : INTEGER ITITEN(NIS),IOU(NIS) 49 : CHARACTER*(8) ITITEM(NIS) 50 : ENDSEGMENT 51 : 52 : 53 : 54 : * +---------------------------------+ 55 : * | | 56 : * | LECTURE DES PARAMETRES D'ENTREE | 57 : * | | 58 : * +---------------------------------+ 59 : 60 : * LECTURE DU NOM DU FICHIER SOURCE 60 : CALL LIRCHA(NOMSRC,1,LSRC) 61 : IF (IERR.NE.0) RETURN 62 : 63 : * LECTURE EVENTUELLE ET VERIFICATION DU NOM DE LA PROCEDURE 63 : CALL LIRCHA(NOMPR1,0,LPR1) 64 : IF (LPR1.GT.0) THEN 64 : CALL VERNAM(NOMPR1(1:LPR1),IRET) 65 : IF (IRET.EQ.0) THEN 66 : MOTERR(1:8)=NOMPR1(1:LPR1) 67 : IF (LPR1.GT.8) MOTERR(6:8)='...' 67 : CALL ERREUR(1029) 68 : RETURN 69 : ENDIF 70 : ENDIF 71 : 72 : 73 : 74 : * +-----------------------------+ 75 : * | | 76 : * | SAUVETAGE DE L'ETAT COURANT | 77 : * | | 78 : * +-----------------------------+ 79 : 80 : * SAUVETAGE DES OBJETS TEMPORAIRES 81 : ITITE=0 82 : IF (IPTEM.NE.0) THEN 83 : ITITE=1 84 : MOT(1:8)='#' 85 : IRE=3 86 : NIS=IPTEM 87 : SEGINI,ITITE3 88 : DO I=1,IPTEM 89 : IF (I.LT.10) THEN 90 : WRITE(MOT(2:2),FMT='(I1)') I 91 : NCAR=2 92 : ELSE 93 : WRITE(MOT(2:3),FMT='(I2)') I 94 : NCAR=3 95 : ENDIF 96 : IAVA=0 96 : CALL PRENOM(IPLAMO,IAVA,SREDLE) 97 : ITITEN(I)=IPLAMO 98 : ITITEM(I)=INOOB2(IPLAMO) 99 : IOU(I)=IOUEP2(IPLAMO) 100 : ENDDO 101 : ENDIF 102 : 103 : * SAUVETAGE DE CCNOYAU ET CCREDLE 103 : CALL PROCSA 104 : MBFONC=1 105 : 106 : 107 : 108 : * +-----------------------------+ 109 : * | | 110 : * | OUVERTURE DU FICHIER SOURCE | 111 : * | | 112 : * +-----------------------------+ 113 : 114 : OPEN(UNIT=IOCAR, 115 : & ACCESS='SEQUENTIAL', 116 : & STATUS='OLD', 117 : & FILE=NOMSRC(1:LSRC), 118 : & FORM='FORMATTED', 119 : & IOSTAT=IOS) 120 : 121 : IF (IOS.NE.0) THEN 122 : INTERR(1)=IOS 123 : MOTERR=NOMSRC(1:LSRC) 123 : CALL ERREUR(424) 124 : RETURN 125 : ENDIF 126 : 127 : 128 : * POSITIONNEMENT DE LA LECTURE GIBI SUR LE FICHIER SOURCE 129 : JOLEC=IOLEC 130 : IOLEC=IOCAR 131 : 132 : 133 : 134 : * +---------------------------+ 135 : * | | 136 : * | CHARGEMENT DES PROCEDURES | 137 : * | | 138 : * +---------------------------+ 139 : 140 : * ON DECREMENTE LE NIVEAU D'ECRITURE 141 : IECHA=IECHO 142 : IECHO=MAX(0,IECHO-1) 143 : 144 : * NBPROC = nombre de procedures importees avec succes 145 : * NDELIM = nombre de delimiteurs $$$$ lus 146 : NBPROC=0 147 : NDELIM=0 148 : 149 : 1 READ(UNIT=IOCAR,FMT='(A72)',END=1000) CHBUFF 150 : 151 : IF (CHBUFF.EQ.' ') GOTO 1 152 : 153 : 154 : * ================================================================== 155 : * LE FICHIER CONTIENT UNE PLUSIEURS PROCEDURES SEPAREES PAR LES 156 : * DELIMITEURS $$$$ (FORMAT STANDARD, COMPATIBLE AVEC UTIL 'PROC') 157 : * ================================================================== 158 : IF (CHBUFF(1:4).EQ.'$$$$') THEN 159 : 160 : NDELIM=NDELIM+1 161 : 162 : 163 : * MESSAGE INDIQUANT QUE LE FICHIER EST AU FORMAT STANDARD 163 : IF ((NDELIM.EQ.1).AND.(IIMPI.GE.10)) CALL ERREUR(-348) 164 : 165 : 166 : * LECTURE DU NOM DERRIERE LE DELIMITEUR $$$$ 167 : * ------------------------------------------ 168 : NOMPR2=CHBUFF(6:72) 168 : CALL LENCHA(NOMPR2,LPR2) 169 : IF (LPR2.EQ.0) GOTO 1 170 : 171 : 172 : * LECTURE DU NOM DERRIERE L'INSTRUCTION DEBP 173 : * ------------------------------------------ 173 : CALL NOUTRU 173 : CALL LIRMOT(MDEBP,1,IRET,1) 174 : NOMPR3=' ' 174 : CALL LIRCHA(NOMPR3,0,LPR3) 175 : 176 : 177 : * VERIFICATION QUE LES DEUX NOMS CONCORDENT ET SONT VALIDES 178 : * --------------------------------------------------------- 178 : CALL MINMAJ(NOMPR2(1:LPR2)) 178 : CALL MINMAJ(NOMPR3(1:LPR3)) 179 : 179 : CALL VERNAM(NOMPR2(1:LPR2),IRET) 180 : IF (IRET.EQ.0) THEN 181 : MOTERR(1:8)=NOMPR2(1:LPR2) 182 : IF (LPR2.GT.8) MOTERR(6:8)='...' 182 : CALL ERREUR(1029) 183 : GOTO 1002 184 : ELSEIF (NOMPR2(1:LPR2).NE.NOMPR3(1:LPR3)) THEN 185 : MOTERR(1:8)=NOMPR2(1:LPR2) 186 : MOTERR(9:9+LPR3)=NOMPR3(1:LPR3) 186 : CALL ERREUR(1031) 187 : GOTO 1002 188 : ENDIF 189 : 190 : 191 : * SI UN NOM DE PROCEDURE A ETE FOURNI EN ENTREE, ON IGNORE 192 : * TOUTES LES PROCEDURES LUES QUI NE PORTENT PAS CE NOM 193 : * -------------------------------------------------------- 194 : IF ((LPR1.NE.0).AND.(NOMPR1(1:LPR1).NE.NOMPR2(1:LPR2))) THEN 195 : IF (IIMPI.GE.10) THEN 196 : MOTERR(1:8)=NOMPR2(1:LPR1) 196 : CALL ERREUR(-351) 197 : ENDIF 198 : GOTO 1 199 : ENDIF 200 : 201 : 202 : * CREATION ET CHARGEMENT DU CONTENU DE L'OBJET PROCEDUR 203 : * ----------------------------------------------------- 203 : CALL REFUS 203 : CALL MAPR(1) 204 : 205 : 206 : * MESSAGE INDIQUANT UNE ERREUR OU LA REUSSITE DE L'IMPORTATION 207 : * ------------------------------------------------------------ 208 : MOTERR(1:8)=NOMPR2(1:LPR2) 209 : IF (IERR.NE.0) THEN 210 : IERR=0 210 : CALL ERREUR(1030) 211 : GOTO 1002 212 : ELSEIF (IIMPI.GE.10) THEN 212 : CALL ERREUR(-350) 213 : NBPROC=NBPROC+1 214 : ENDIF 215 : 216 : 217 : GOTO 1 218 : 219 : 220 : * ================================================================== 221 : * LE FICHIER INDIQUE CONTIENT UNE SUITE D'INSTRUCTIONS BRUTES, SANS 222 : * LE DELIMITEUR $$$$ NI LES INSTRUCTIONS DEBP/FINP 223 : * ================================================================== 224 : ELSEIF (NDELIM.EQ.0) THEN 225 : 226 : * MESSAGE INDIQUANT QUE L'ON A PAS TROUVE DE DELIMITEURS 226 : IF ((LPR1.EQ.0).OR.(IIMPI.GE.10)) CALL ERREUR(-349) 227 : 228 : * DANS CE CAS DE FIGURE, IL EST OBLIGATOIRE DE FOURNIR LE NOM 229 : * DE LA PROCEDURE QUE L'ON VA CREER 230 : IF (LPR1.EQ.0) THEN 231 : IOLEC=JOLEC 232 : MOTERR(1:8)='PROCEDUR' 232 : CALL ERREUR(1028) 233 : GOTO 1002 234 : ENDIF 235 : 236 : 237 : * CREATION D'UN FICHIER TEMPORAIRE 238 : * -------------------------------- 239 : OPEN(UNIT=IOTMP, 240 : & ACCESS='SEQUENTIAL', 241 : & STATUS='UNKNOWN', 242 : & FILE=FITMP(1:LTMP), 243 : & FORM='FORMATTED', 244 : & IOSTAT=IOS) 245 : 246 : IF (IOS.NE.0) THEN 247 : INTERR(1)=IOS 248 : MOTERR=FITMP(1:LTMP) 248 : CALL ERREUR(424) 249 : GOTO 1002 250 : ENDIF 251 : 252 : 253 : * ECRITURE DU NOM DE LA PROCEDURE (REQUIS PAR MAPR) 254 : * ------------------------------------------------- 255 : WRITE(IOTMP,'(A)') NOMPR1(1:LPR1)//' ;' 256 : 257 : 258 : * COPIE DES INSTRUCTIONS CONTENUES DANS LE FICHIER SOURCE 259 : * ------------------------------------------------------- 260 : BACKSPACE(UNIT=IOCAR) 261 : 2 READ(UNIT=IOCAR,FMT='(A72)',END=3) CHBUFF 262 : WRITE(UNIT=IOTMP,FMT='(A72)') CHBUFF 263 : GOTO 2 264 : 3 CONTINUE 265 : 266 : 267 : * AJOUT DE L'INSTRUCTION FINP (REQUIS PAR MAPR) 268 : * => NE POSE PAS DE PROBLEME SI ELLE ETAIT DEJA PRESENTE 269 : * ------------------------------------------------------ 270 : WRITE(IOTMP,'(A6)') 'FINP ;' 271 : 272 : 273 : * REPOSITIONNEMENT DE LA LECTURE GIBI SUR LE FICHIER TEMPORAIRE 274 : * ------------------------------------------------------------- 275 : REWIND(UNIT=IOTMP) 276 : IOLEC=IOTMP 276 : CALL NOUTRU 277 : 278 : 279 : * CREATION ET CHARGEMENT DU CONTENU DE L'OBJET PROCEDUR 280 : * ----------------------------------------------------- 280 : CALL MAPR(1) 281 : 282 : 283 : * MESSAGE INDIQUANT UNE ERREUR OU LA REUSSITE DE L'IMPORTATION 284 : * ------------------------------------------------------------ 285 : MOTERR(1:8)=NOMPR1(1:LPR1) 286 : IF (IERR.NE.0) THEN 287 : IERR=0 287 : CALL ERREUR(1030) 288 : GOTO 1001 289 : ELSEIF (IIMPI.GE.10) THEN 289 : CALL ERREUR(-350) 290 : NBPROC=NBPROC+1 291 : ENDIF 292 : 293 : 294 : GOTO 1000 295 : 296 : ENDIF 297 : 298 : GOTO 1 299 : 300 : 301 : 302 : * +-------------------------+ 303 : * | | 304 : * | SORTIE DE LA SUBROUTINE | 305 : * | | 306 : * +-------------------------+ 307 : 308 : 309 : 1000 CONTINUE 310 : 311 : * MESSAGE INDIQUANT LE NOMBRE DE PROCEDURES CREEES 312 : IF (IIMPI.GE.10) THEN 313 : INTERR(1)=NBPROC 313 : CALL ERREUR(-352) 314 : ENDIF 315 : 316 : 317 : 1001 CONTINUE 318 : 319 : * ON FERME LE FICHIER TEMPORAIRE 320 : CLOSE(UNIT=IOTMP,STATUS='DELETE') 321 : 322 : 323 : 1002 CONTINUE 324 : 325 : * ON FERME LE FICHIER SOURCE 326 : CLOSE(UNIT=IOCAR) 327 : 328 : * ON RESTAURE LA LECTURE SUR L'ANCIENNE UNITE 329 : * (OU SUR LE TERMINAL S'IL Y A UNE ERREUR) 330 : IF (IERR.NE.0) THEN 331 : IOLEC=IOTER 332 : ELSE 333 : IOLEC=JOLEC 334 : ENDIF 335 : 336 : * ON RESTAURE LE NIVEAU D'ECRITURE 337 : IECHO=IECHA 338 : 339 : * ON RESTAURE LES OBJETS TEMPORAIRES, LE NOYAU ET LA LECTURE 340 : IF (ITITE.NE.0) THEN 341 : DO I=1,ITITEN(/1) 342 : IPLAMO=ITITEN(I) 343 : INOOB2(IPLAMO)=ITITEM(I) 344 : IOUEP2(IPLAMO)=IOU(I) 345 : ENDDO 346 : SEGSUP,ITITE3 347 : ENDIF 347 : CALL PROCRE 348 : 349 : 350 : 351 : RETURN 352 : 353 : END 354 : 355 : 356 : 357 : 358 : 359 : 360 : 361 : 362 :
© Cast3M 2003 - All rights reserved.
Disclaimer