Télécharger procpn.eso

Retour à la liste

Numérotation des lignes :

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

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