Télécharger procpn.eso

Retour à la liste

Numérotation des lignes :

  1. C PROCPN SOURCE CB215821 18/01/23 21:15:42 9704
  2. SUBROUTINE PROCPN(IAREA,IRET)
  3. IMPLICIT INTEGER(I-N)
  4. -INC CCOPTIO
  5. SAVE LINDEX,ISTAT,IULEPR,ISTAT2
  6. integer curEnr,curCha,curFic,curLig
  7. integer totCha
  8. SAVE curEnr,curCha,curFic,curLig
  9. CHARACTER*(*) IAREA
  10. INTEGER IRET
  11. DATA iLonEn /100000/
  12. CHARACTER*100000 cCHAR
  13. CHARACTER*8 c8
  14. integer nDol
  15. integer iProc
  16. integer iEnre
  17. integer nProc,nProc34
  18. integer nEnt
  19. integer curCh2
  20. integer tmpLong
  21. CHARACTER*500 cline
  22. DIMENSION INDEX (6)
  23. DIMENSION NAME(2)
  24. CHARACTER*8 INDIX (6)
  25. SEGMENT indFic
  26. CHARACTER*8 nomEnt(nEnt)
  27. INTEGER carDeb(nEnt)
  28. INTEGER numFic(nEnt)
  29. ENDSEGMENT
  30. SEGMENT UTIFIC
  31. integer debCha(nlig+1)
  32. ENDSEGMENT
  33. 103 FORMAT(A100000)
  34. pointeur pLiPro.indFic
  35. pointeur utif3.utific
  36. utif3=0
  37. C IJKL=0
  38. IDEJA=0
  39. ISTAT=1
  40. nEnt=0
  41. SEGINI pLiPro
  42. c write(6,*) 'Lecture du premier fichier de procedure'
  43. nProc=0
  44. IF(utifi3(4).EQ.0) THEN
  45. goto 95
  46. ENDIF
  47. READ(34,REC=1,FMT=103,IOSTAT=IOSTAT)cCHAR
  48. if (iostat.gt.0) then
  49. goto 95
  50. endif
  51.  
  52. READ(cCHAR(1:30),FMT=301,IOSTAT=IOSTAT)curEnr,nLig,nProc
  53. if (iostat.gt.0) then
  54. goto 95
  55. endif
  56. ISTAT=0
  57. c recuperation du nombre de ligne, d enregistrement, et de procedure
  58. c write(6,*) 'nb proc',nProc
  59. c lecture de la liste des procedures
  60. nEnt=nProc
  61. SEGADJ pLiPro
  62. curCha=31
  63. DO iproc=1,nProc
  64. if(curcha.le.iLonEn-17) then
  65. read(cCHAR(curCha:curcha+17),FMT=202,IOSTAT=IOSTAT) c8,
  66. & curCh2
  67. if (iostat.gt.0) then
  68. nEnt=iProc-1
  69. segadj pLiPro
  70. goto 95
  71. endif
  72. pLiPro.nomEnt(iProc)=c8
  73. pLiPro.carDeb(iProc)=curCh2
  74. c on enleve 1 pour etre sur que jchar-1 n'est pas sup ou egal a iLonEn
  75. pLiPro.numFic(iProc)=34
  76. CALL NOMOBJ('PROCEDUR',c8,-curCh2)
  77. curCha=curCha+18
  78. else
  79. write(IOIMP,*) 'Trop de procedure'
  80. endif
  81. enddo
  82. c lecture de la correspondance des lignes
  83. c write(IOIMP,*) 'nb lig',nLig
  84. c write(IOIMP,*) 'nb Enr',curEnr
  85. READ(34,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR
  86. if (iostat.gt.0) then
  87. goto 95
  88. endif
  89. segini utif3
  90. curCha=1
  91. do curLig=1,nLig+1
  92. c attention, ici, on fait l'hypothese que iLonEn est un multiple de 10
  93. READ(cCHAR(curCha:curCha+9),FMT=204,IOSTAT=IOSTAT)
  94. & utif3.debCha(curLig)
  95. if (iostat.gt.0) then
  96. nLig=curLig-2
  97. segadj utif3
  98. goto 95
  99. endif
  100. c WRITE(6,*) 'ligne',curLig,utif3.debCha(curLig)
  101. curCha=curCha+10
  102. if(curCha.GE.iLonEn) then
  103. curEnr=curEnr+1
  104. READ(34,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR
  105. if (iostat.gt.0) then
  106. nLig=curLig-1
  107. segadj utif3
  108. goto 95
  109. endif
  110. curCha=1
  111. endif
  112. enddo
  113. 95 CONTINUE
  114. utifi3(4)=utif3
  115. IF(utif3 .GT. 0) then
  116. segdes utif3
  117. endif
  118.  
  119. utif3=0
  120. nProc34=nProc
  121. c write(6,*) cline
  122. c write(6,*) 'fin de Lecture du fichier de procedure'
  123.  
  124. ISTAT2=1
  125. c write(6,*) 'Lecture du deuxieme fichier de procedure'
  126. nProc=0
  127. IF(utifi3(6).EQ.0) THEN
  128. goto 96
  129. ENDIF
  130. READ(36,REC=1,FMT=103,IOSTAT=IOSTAT)cCHAR
  131. if (iostat.gt.0) then
  132. goto 96
  133. endif
  134.  
  135. READ(cCHAR(1:30),FMT=301,IOSTAT=IOSTAT)curEnr,nLig,nProc
  136. if (iostat.gt.0) then
  137. goto 96
  138. endif
  139. ISTAT2=0
  140. c recuperation du nombre de ligne, d enregistrement, et de procedure
  141. c write(IOIMP,*) 'nb Enr',curEnr
  142. c write(IOIMP,*) 'nb lig',nLig
  143. c write(IOIMP,*) 'nb proc',nProc
  144. c lecture de la liste des procedures
  145. nEnt=nProc+nProc34
  146. SEGADJ pLiPro
  147. curCha=31
  148. DO iproc=nProc34+1,nEnt
  149. if(curcha.le.iLonEn-17) then
  150. read(cCHAR(curCha:curcha+17),FMT=202,IOSTAT=IOSTAT) c8,curCh2
  151. if (iostat.gt.0) then
  152. nEnt=iProc-1
  153. SEGADJ pLiPro
  154. goto 96
  155. endif
  156. pLiPro.nomEnt(iProc)=c8
  157. pLiPro.carDeb(iProc)=curCh2
  158. cc on enleve 1 pour etre sur que jchar-1 n'est pas sup ou egal a iLonEn
  159. pLiPro.numFic(iProc)=36
  160. DO 40 nProc=1,nProc34
  161. IF(c8(1:8).EQ.pLiPro.nomEnt(nProc)) THEN
  162. IF(IDEJA.EQ.0) THEN
  163. CALL ERREUR (-302)
  164. ENDIF
  165. WRITE(IOIMP,*) c8(1:8)
  166. IDEJA=IDEJA+1
  167. GO TO 41
  168. ENDIF
  169. 40 CONTINUE
  170. 41 CONTINUE
  171. CALL NOMOBJ('PROCEDUR',c8,-(curCh2+500000000))
  172. curCha=curCha+18
  173. else
  174. write(IOIMP,*) 'Trop de procedures'
  175. endif
  176. enddo
  177. c lecture de la correspondance des lignes
  178. READ(36,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR
  179. if (iostat.gt.0) then
  180. goto 96
  181. endif
  182. segini utif3
  183. curCha=1
  184. do curLig=1,nLig+1
  185. c attention, ici, on fait l'hypothese que iLonEn est un multiple de 10
  186. READ(cCHAR(curCha:curCha+9),FMT=204,IOSTAT=IOSTAT)
  187. & utif3.debCha(curLig)
  188. if (iostat.gt.0) then
  189. nLig=curLig-2
  190. segadj utif3
  191. goto 96
  192. endif
  193. c WRITE(6,*) 'ligne',curLig,utif3.debCha(curLig)
  194. curCha=curCha+10
  195. if(curCha.GE.iLonEn) then
  196. curEnr=curEnr+1
  197. READ(36,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR
  198. if (iostat.gt.0) then
  199. nLig=curLig-1
  200. segadj utif3
  201. goto 96
  202. endif
  203. curCha=1
  204. endif
  205. enddo
  206. 96 continue
  207. utifi3(6)=utif3
  208. IF(utifi3(6) .GT. 0) then
  209. segdes utif3
  210. endif
  211.  
  212. c dump de la lecture du fichier
  213. c write(IOIMP,*) 'dump de la lecture du fichier'
  214. c do 93 I=1,nEnt
  215. c write(IOIMP,94)pLiPro.nomEnt(i),(pLiPro.carDeb(i)/iLonEn),
  216. c & mod(pLiPro.carDeb(i),iLonEn)
  217. c write(IOIMP,94)pLiPro.nomEnt(i),pLiPro.carDeb(i)
  218. c write(IOIMP,94)pLiPro.nomEnt(i),pLiPro.carDeb(i),
  219. c & pLiPro.numFic(i)
  220. c94 FORMAT('Proc : ',A8,' ligne ',I10,'fichier',I3)
  221. c93 continue
  222. c write(IOIMP,*) 'statut',ISTAT,ISTAT2
  223. lisProc=pLiPro
  224. segdes pLiPro
  225. IRET=9999
  226. C 9998 CONTINUE
  227. c lecture du deuxieme fichier
  228.  
  229. RETURN
  230. ENTRY PROCPO(JINDEX,IRET)
  231. c Le principe de cette routine est de placer le pointeur LINDEX au bon endroit
  232. c elle renvoit IRET = 0 en cas d erreur, 9999 sinon
  233. c Le pointeur LINDEX est place en fonction de la position demandee modulo le fichier
  234. c Le pointeur demandee est enregistree lors du nomobj de procpn
  235. c write(IOIMP,*)'Entree dans PROCPO'
  236. IRET=0
  237. IF (ISTAT*ISTAT2.EQ.1) RETURN
  238. IF(JINDEX.GT.500000000) THEN
  239. c write(6,94)pLiPro.nomEnt(i),(pLiPro.carDeb(i)/iLonEn),
  240. c & mod(pLiPro.carDeb(i),iLonEn)
  241. curFic=36
  242. curLig = (JINDEX-500000000)
  243. ELSE
  244. curFic=34
  245. curLig = JINDEX
  246. ENDIF
  247. IRET=9999
  248. c write(IOIMP,*)'sortie de PROCPO',IRET
  249. RETURN
  250. ENTRY PROCLI(IAREA,IRET)
  251. c Le principe de cette routine est de lire la ligne sous le pointeur LINDEX et d avancer le pointeur
  252. c La ligne est enregistree dans IAREA et le pointeur LINDEX est avance de 1
  253. c Notre but ici va etre de lire 500 caractere a partir de curCha
  254. c (eventuellement avancer curEnr et s'arreter si on rencontre 4
  255. c dollars. Puis renvoyer ca dans IAREA
  256. c write(IOIMP,*)'Entree dans PROCLI',ISTAT,ISTAT2
  257. IRET=9999
  258. IF (ISTAT*ISTAT2.EQ.1) RETURN
  259. utif3=utifi3(curfic-30)
  260. if(utif3.LE.0) RETURN
  261. segact utif3
  262. nlig=utif3.debCha(/1)
  263. c write(IOIMP,*)'Nombre de lignes',nlig,curLig
  264. IF(curLig.GE.nlig)return
  265. curEnr = utif3.debCha(curLig)/iLonEn+1
  266. c curCha = utif3.debCha(curLig) - ilonEn * (curEnr-1)
  267. curCha = mod(utif3.debCha(curLig),iLonEn)+1
  268. curCh2 = mod(utif3.debCha(curLig+1),iLonEn)
  269. c write(6,*) 'Ligne ',curLig,curCha,curCh2
  270. IRET=0
  271. WRITE(cline,FMT=203)' '
  272. READ(curFic,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cChar
  273. if (iostat.gt.0) then
  274. write(IOIMP,*)'Impossible de lire l''enregistrement',curEnr,
  275. & curFic
  276. IAREA(1:500)=cline(1:500)
  277. segdes utif3
  278. return
  279. endif
  280. c Est-ce que curCh2 peut valoir 0 ??
  281. if(curCha.LE.curCh2) then
  282. tmplong=curCh2-curCha+1
  283. cline(1:tmplong) = cChar(curCha:curCh2)
  284. else
  285. tmplong=(iLonEn-curCha) + 1
  286. cline(1:tmpLong)=cCHAR(curCha:iLonEn)
  287. c write(6,*) 'Premiere partie',curEnr,1,tmpLong,curCha,iLonEn,
  288. c & cline(1:tmpLong)
  289. curEnr=curEnr+1
  290. READ(curFic,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR
  291. if (iostat.eq.0) then
  292. cline(1+tmpLong:curCh2-curCha+1+iLonEn) = cChar(1:curCh2)
  293. tmplong=curCh2-curCha+1+iLonEn
  294. endif
  295. c write(6,*) 'Deuxieme partie',curEnr,1+tmpLong,1,curCh2,
  296. c & curCh2-curCha+1+iLonEn,
  297. c & cline(1+tmpLong:curCh2-curCha+1+iLonEn)
  298. endif
  299. c write(6,'(A,I10,A,I10,A,A,A)') 'Li',curLig,'/',nLig,', |',
  300. c & cline(1:tmplong),'|'
  301. c Nettoyage de cline : on s'arrete si on trouve des $$$$ puis on
  302. c enleve les blanc
  303. IF(cline(1:4).EQ.'$$$$')IRET=9999
  304. IAREA(1:500)=cline(1:500)
  305. curLig=curLig+1
  306. segdes utif3
  307. c write(IOIMP,*)'sortie de PROCLI ',IRET
  308. RETURN
  309. ENTRY PROCL2(IAREA,IRET)
  310. c write(IOIMP,*)'Entree dans PROCL2'
  311. c Procli2 place le pointeur LINDEX sur le debut de la routine IAREA et dans le bon fichier
  312. pLiPro=lisProc
  313. segact pLiPro
  314. IRET=0
  315. IF (ISTAT*ISTAT2.EQ.1) RETURN
  316. do 73 I=pLiPro.numFic(/1),1,-1
  317. if(IAREA(1:8).EQ.pLiPro.nomEnt(i)) THEN
  318. curFic=pLiPro.numFic(i)
  319. IF(curFic.EQ.34) THEN
  320. IRET=9999
  321. ELSE
  322. IRET=9998
  323. ENDIF
  324. curLig = pLiPro.carDeb(i)
  325. segdes pLiPro
  326. c write(IOIMP,*)'sortie de PROCL2 ',IRET
  327. return
  328. ENDIF
  329. 73 continue
  330. segdes pLiPro
  331. c write(IOIMP,*)'sortie de PROCL2 ',IRET
  332. RETURN
  333. 301 FORMAT(3I10)
  334. 202 FORMAT(A8,I10)
  335. 203 FORMAT(A)
  336. 204 FORMAT(I10)
  337. END
  338.  
  339.  
  340.  

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