Télécharger liproc.eso

Retour à la liste

Numérotation des lignes :

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

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