Télécharger la plaquette Cast3M


fr en

Télécharger procpn.eso

Retour à la liste

Numérotation des lignes : 

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

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