Télécharger la plaquette Cast3M


fr en

Télécharger liproc.eso

Retour à la liste

Numérotation des lignes : 

liproc

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales