C LIPROC SOURCE CB215821 24/07/17 21:15:08 11961 ************************************************************************ * NOM : LIPROC * DESCRIPTION : Lit une procedure GIBIANE depuis un fichier externe ************************************************************************ * HISTORIQUE : 19/12/2013 : JCARDO : création de la subroutine * HISTORIQUE : 30/01/2013 : JCARDO : remplissage de la subroutine * HISTORIQUE : 31/01/2013 : JCARDO : corr. bug appel depuis procedure * HISTORIQUE : 26/03/2014 : PV : SREDLE non affecte remplace par IREDLE * HISTORIQUE : 05/05/2015 : JCARDO : ajout de SREDLE=IREDLE * HISTORIQUE : ************************************************************************ * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES * en cas de modification de ce sous-programme afin de faciliter * la maintenance ! ************************************************************************ * APPELÉ PAR : lirefi.eso ************************************************************************ * ENTRÉES :: aucune * SORTIES :: aucune ************************************************************************ * SYNTAXE (GIBIANE) : * * LIRE 'PROC' NOMFIC1 (MOT1) ; * ************************************************************************ SUBROUTINE LIPROC IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCNOYAU -INC CCOPTIO -INC SMBLOC -INC CCREDLE C LOCHAI dans CCNOYAU.INC CHARACTER*(LOCHAI) NOMSRC,CHBUFF CHARACTER*(LONOM) NOMPR1,NOMPR2,NOMPR3 CHARACTER*8 CHA8 CHARACTER*4 MDEBP(1) DATA MDEBP/'DEBP'/ PARAMETER(IOTMP=70) PARAMETER(LTMP=10) CHARACTER*(LTMP) FITMP DATA FITMP/'LIPROC.TMP'/ SEGMENT ITITE3 INTEGER ITITEN(NIS),IOU(NIS) CHARACTER*(8) ITITEM(NIS) ENDSEGMENT * +---------------------------------+ * | | * | LECTURE DES PARAMETRES D'ENTREE | * | | * +---------------------------------+ * LECTURE DU NOM DU FICHIER SOURCE CALL LIRCHA(NOMSRC,1,LSRC) IF (IERR.NE.0) RETURN * LECTURE EVENTUELLE ET VERIFICATION DU NOM DE LA PROCEDURE CALL LIRCHA(NOMPR1,0,LPR1) IF (LPR1.GT.0) THEN CALL VERNAM(NOMPR1(1:LPR1),IRET) IF (IRET.EQ.0) THEN MOTERR(1:8)=NOMPR1(1:LPR1) IF (LPR1.GT.8) MOTERR(6:8)='...' CALL ERREUR(1029) RETURN ENDIF ENDIF * +-----------------------------+ * | | * | SAUVETAGE DE L'ETAT COURANT | * | | * +-----------------------------+ * SAUVETAGE DU TYPE DES OBJETS TEMPORAIRES SREDLE=IREDLE ITITE=0 IF (IPTEM.NE.0) THEN ITITE=1 MOT(1:LONOM)='#' IRE=3 NIS=IPTEM SEGINI,ITITE3 DO I=1,IPTEM IF (I.LT.10) THEN WRITE(MOT(2:2),FMT='(I1)') I NCAR=2 ELSE WRITE(MOT(2:3),FMT='(I2)') I NCAR=3 ENDIF IAVA=0 CALL PRENOM(IPLAMO,IAVA,SREDLE) ITITEN(I)=IPLAMO ITITEM(I)=INOOB2(IPLAMO) IOU(I)=IOUEP2(IPLAMO) ENDDO ENDIF * SAUVETAGE DE CCNOYAU ET CCREDLE CALL PROCSA MBFONC=1 * +-----------------------------+ * | | * | OUVERTURE DU FICHIER SOURCE | * | | * +-----------------------------+ OPEN(UNIT=IOCAR, & ACCESS='SEQUENTIAL', & STATUS='OLD', & FILE=NOMSRC(1:LSRC), & FORM='FORMATTED', & IOSTAT=IOS) IF (IOS.NE.0) THEN INTERR(1)=IOS MOTERR=NOMSRC(1:LSRC) CALL ERREUR(424) RETURN ENDIF * POSITIONNEMENT DE LA LECTURE GIBI SUR LE FICHIER SOURCE JOLEC=IOLEC IOLEC=IOCAR * +---------------------------+ * | | * | CHARGEMENT DES PROCEDURES | * | | * +---------------------------+ * ON DECREMENTE LE NIVEAU D'ECRITURE IECHA=IECHO IECHO=MAX(0,IECHO-1) * NBPROC = nombre de procedures importees avec succes * NDELIM = nombre de delimiteurs $$$$ lus NBPROC=0 NDELIM=0 1 READ(UNIT=IOCAR,FMT=FMCHAI,END=1000) CHBUFF IF (CHBUFF.EQ.' ') GOTO 1 * ================================================================== * LE FICHIER CONTIENT UNE OU PLUSIEURS PROCEDURES SEPAREES PAR LES * DELIMITEURS $$$$ (FORMAT STANDARD, COMPATIBLE AVEC UTIL 'PROC') * ================================================================== IF (CHBUFF(1:4).EQ.'$$$$') THEN NDELIM=NDELIM+1 * MESSAGE INDIQUANT QUE LE FICHIER EST AU FORMAT STANDARD IF ((NDELIM.EQ.1).AND.(IIMPI.GE.10)) CALL ERREUR(-348) * LECTURE DU NOM DERRIERE LE DELIMITEUR $$$$ * ------------------------------------------ NOMPR2=CHBUFF(6:LOCHAI) CALL LENCHA(NOMPR2,LPR2) IF (LPR2.EQ.0) GOTO 1 * LECTURE DU NOM DERRIERE L'INSTRUCTION DEBP * ------------------------------------------ CALL NOUTRU CALL LIRMOT(MDEBP,1,IRET,1) CHA8=' ' CALL LIROBJ(CHA8,IOBJ1,1,IRET) CALL QUENOM(NOMPR3) CALL LENCHA(NOMPR3,LPR3) * VERIFICATION QUE LES DEUX NOMS CONCORDENT ET SONT VALIDES * --------------------------------------------------------- CALL MINMAJ(NOMPR2(1:LPR2)) CALL MINMAJ(NOMPR3(1:LPR3)) CALL VERNAM(NOMPR2(1:LPR2),IRET) IF (IRET.EQ.0) THEN MOTERR(1:8)=NOMPR2(1:LPR2) IF (LPR2.GT.8) MOTERR(6:8)='...' CALL ERREUR(1029) GOTO 1002 ELSEIF (NOMPR2(1:LPR2).NE.NOMPR3(1:LPR3)) THEN MOTERR(1:8)=NOMPR2(1:LPR2) MOTERR(9:16)=NOMPR3(1:LPR3) CALL ERREUR(1031) GOTO 1002 ENDIF * SI UN NOM DE PROCEDURE A ETE FOURNI EN ENTREE, ON IGNORE * TOUTES LES PROCEDURES LUES QUI NE PORTENT PAS CE NOM * -------------------------------------------------------- IF ((LPR1.NE.0).AND.(NOMPR1(1:LPR1).NE.NOMPR2(1:LPR2))) THEN IF (IIMPI.GE.10) THEN MOTERR(1:8)=NOMPR2(1:LPR2) CALL ERREUR(-351) ENDIF GOTO 1 ENDIF * CREATION ET CHARGEMENT DU CONTENU DE L'OBJET PROCEDUR * ----------------------------------------------------- CALL REFUS CALL MAPR(1) IF (IERR.NE.0) RETURN * MESSAGE INDIQUANT UNE ERREUR OU LA REUSSITE DE L'IMPORTATION * ------------------------------------------------------------ MOTERR(1:8)=NOMPR2(1:LPR2) IF (IERR.NE.0) THEN IERR=0 CALL ERREUR(1030) GOTO 1002 ELSEIF (IIMPI.GE.10) THEN CALL ERREUR(-350) NBPROC=NBPROC+1 ENDIF GOTO 1 * ================================================================== * LE FICHIER INDIQUE CONTIENT UNE SUITE D'INSTRUCTIONS BRUTES, SANS * LE DELIMITEUR $$$$ NI LES INSTRUCTIONS DEBP/FINP * ================================================================== ELSEIF (NDELIM.EQ.0) THEN * MESSAGE INDIQUANT QUE L'ON A PAS TROUVE DE DELIMITEURS IF ((LPR1.EQ.0).OR.(IIMPI.GE.10)) CALL ERREUR(-349) * DANS CE CAS DE FIGURE, IL EST OBLIGATOIRE DE FOURNIR LE NOM * DE LA PROCEDURE QUE L'ON VA CREER IF (LPR1.EQ.0) THEN IOLEC=JOLEC MOTERR(1:8)='PROCEDUR' CALL ERREUR(1028) GOTO 1002 ENDIF * CREATION D'UN FICHIER TEMPORAIRE * -------------------------------- OPEN(UNIT=IOTMP, & ACCESS='SEQUENTIAL', & STATUS='UNKNOWN', & FILE=FITMP(1:LTMP), & FORM='FORMATTED', & IOSTAT=IOS) IF (IOS.NE.0) THEN INTERR(1)=IOS MOTERR=FITMP(1:LTMP) CALL ERREUR(424) GOTO 1002 ENDIF * ECRITURE DU NOM DE LA PROCEDURE (REQUIS PAR MAPR) * ------------------------------------------------- WRITE(IOTMP,'(A)') NOMPR1(1:LPR1)//' ;' * COPIE DES INSTRUCTIONS CONTENUES DANS LE FICHIER SOURCE * ------------------------------------------------------- BACKSPACE(UNIT=IOCAR) 2 READ (UNIT=IOCAR,FMT=FMCHAI,END=3) CHBUFF WRITE(UNIT=IOTMP,FMT=FMCHAI ) CHBUFF GOTO 2 3 CONTINUE * AJOUT DE L'INSTRUCTION FINP (REQUIS PAR MAPR) * => NE POSE PAS DE PROBLEME SI ELLE ETAIT DEJA PRESENTE * ------------------------------------------------------ WRITE(IOTMP,'(A6)') 'FINP ;' * REPOSITIONNEMENT DE LA LECTURE GIBI SUR LE FICHIER TEMPORAIRE * ------------------------------------------------------------- REWIND(UNIT=IOTMP) IOLEC=IOTMP CALL NOUTRU * CREATION ET CHARGEMENT DU CONTENU DE L'OBJET PROCEDUR * ----------------------------------------------------- CALL MAPR(1) IF (IERR.NE.0) RETURN * MESSAGE INDIQUANT UNE ERREUR OU LA REUSSITE DE L'IMPORTATION * ------------------------------------------------------------ MOTERR(1:8)=NOMPR1(1:LPR1) IF (IERR.NE.0) THEN IERR=0 CALL ERREUR(1030) GOTO 1001 ELSEIF (IIMPI.GE.10) THEN CALL ERREUR(-350) NBPROC=NBPROC+1 ENDIF GOTO 1000 ENDIF GOTO 1 * +-------------------------+ * | | * | SORTIE DE LA SUBROUTINE | * | | * +-------------------------+ 1000 CONTINUE * MESSAGE INDIQUANT LE NOMBRE DE PROCEDURES CREEES IF (IIMPI.GE.10) THEN INTERR(1)=NBPROC CALL ERREUR(-352) ENDIF 1001 CONTINUE * ON FERME LE FICHIER TEMPORAIRE CLOSE(UNIT=IOTMP,STATUS='DELETE') 1002 CONTINUE * ON FERME LE FICHIER SOURCE CLOSE(UNIT=IOCAR) * ON RESTAURE LA LECTURE SUR L'ANCIENNE UNITE * (OU SUR LE TERMINAL S'IL Y A UNE ERREUR) IF (IERR.NE.0) THEN IOLEC=IOTER ELSE IOLEC=JOLEC ENDIF * ON RESTAURE LE NIVEAU D'ECRITURE IECHO=IECHA * ON RESTAURE LES TYPES D'OBJETS TEMPORAIRES, LE NOYAU ET LA LECTURE IF (ITITE.NE.0) THEN DO I=1,ITITEN(/1) IPLAMO=ITITEN(I) INOOB2(IPLAMO)=ITITEM(I) IOUEP2(IPLAMO)=IOU(I) ENDDO SEGSUP,ITITE3 ENDIF CALL PROCRE RETURN END