C PROCPN SOURCE JC220346 18/12/14 21:15:11 10039 IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC CCNOYAU SAVE LINDEX,ISTAT,IULEPR,ISTAT2 integer curEnr,curCha,curFic,curLig integer totCha SAVE curEnr,curCha,curFic,curLig CHARACTER*(*) IAREA INTEGER IRET DATA iLonEn /100000/ CHARACTER*100000 cCHAR CHARACTER*(LONOM) cnom integer nDol integer iProc integer iEnre integer nProc,nProc34 integer nEnt integer curCh2 integer tmpLong CHARACTER*500 cline DIMENSION INDEX (6) DIMENSION NAME(2) c CHARACTER*8 INDIX (6) SEGMENT indFic INTEGER carDeb(nEnt) INTEGER numFic(nEnt) ENDSEGMENT SEGMENT UTIFIC integer debCha(nlig+1) ENDSEGMENT 103 FORMAT(A100000) pointeur pLiPro.indFic pointeur utif3.utific nl=LONOM+10 utif3=0 C IJKL=0 IDEJA=0 ISTAT=1 nEnt=0 SEGINI pLiPro C Fichier /u/castem/CAST3M.PROC (unite=34) C ======================================== c write(6,*) 'Lecture du premier fichier de procedure' nProc=0 IF(utifi3(4).EQ.0) THEN goto 95 ENDIF READ(34,REC=1,FMT=103,IOSTAT=IOSTAT)cCHAR if (iostat.gt.0) then goto 95 endif READ(cCHAR(1:30),FMT=301,IOSTAT=IOSTAT)curEnr,nLig,nProc if (iostat.gt.0) then goto 95 endif ISTAT=0 c recuperation du nombre de ligne, d enregistrement, et de procedure c write(6,*) 'nb proc',nProc c lecture de la liste des procedures nEnt=nProc SEGADJ pLiPro curCha=31 DO iproc=1,nProc if(curcha.le.iLonEn-nl+1) then read(cCHAR(curCha:curcha+nl-1),FMT=202,IOSTAT=IOSTAT) cnom, & curCh2 if (iostat.gt.0) then nEnt=iProc-1 segadj pLiPro goto 95 endif pLiPro.carDeb(iProc)=curCh2 c on enleve 1 pour etre sur que jchar-1 n'est pas sup ou egal a iLonEn pLiPro.numFic(iProc)=34 curCha=curCha+nl else write(IOIMP,*) 'Trop de procedures' endif enddo c lecture de la correspondance des lignes c write(IOIMP,*) 'nb lig',nLig c write(IOIMP,*) 'nb Enr',curEnr READ(34,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR if (iostat.gt.0) then goto 95 endif segini utif3 curCha=1 do curLig=1,nLig+1 c attention, ici, on fait l'hypothese que iLonEn est un multiple de 10 READ(cCHAR(curCha:curCha+9),FMT=204,IOSTAT=IOSTAT) & utif3.debCha(curLig) if (iostat.gt.0) then nLig=curLig-2 segadj utif3 goto 95 endif c WRITE(6,*) 'ligne',curLig,utif3.debCha(curLig) curCha=curCha+10 if(curCha.GE.iLonEn) then curEnr=curEnr+1 READ(34,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR if (iostat.gt.0) then nLig=curLig-1 segadj utif3 goto 95 endif curCha=1 endif enddo 95 CONTINUE utifi3(4)=utif3 IF(utif3 .GT. 0) then segdes utif3 endif utif3=0 nProc34=nProc c write(6,*) cline c write(6,*) 'fin de Lecture du fichier de procedure' C Fichier UTILPROC du repertoire local (unite=36) C =============================================== ISTAT2=1 c write(6,*) 'Lecture du deuxieme fichier de procedure' nProc=0 IF(utifi3(6).EQ.0) THEN goto 96 ENDIF READ(36,REC=1,FMT=103,IOSTAT=IOSTAT)cCHAR if (iostat.gt.0) then goto 96 endif READ(cCHAR(1:30),FMT=301,IOSTAT=IOSTAT)curEnr,nLig,nProc if (iostat.gt.0) then goto 96 endif ISTAT2=0 c recuperation du nombre de ligne, d enregistrement, et de procedure c write(IOIMP,*) 'nb Enr',curEnr c write(IOIMP,*) 'nb lig',nLig c write(IOIMP,*) 'nb proc',nProc c lecture de la liste des procedures nEnt=nProc+nProc34 SEGADJ pLiPro curCha=31 DO iproc=nProc34+1,nEnt if(curcha.le.iLonEn-nl+1) then read(cCHAR(curCha:curcha+nl-1),FMT=202,IOSTAT=IOSTAT) cnom, & curCh2 if (iostat.gt.0) then nEnt=iProc-1 SEGADJ pLiPro goto 96 endif pLiPro.carDeb(iProc)=curCh2 cc on enleve 1 pour etre sur que jchar-1 n'est pas sup ou egal a iLonEn pLiPro.numFic(iProc)=36 DO 40 nProc=1,nProc34 IF(IDEJA.EQ.0) THEN ENDIF WRITE(IOIMP,*) cnom IDEJA=IDEJA+1 GO TO 41 ENDIF 40 CONTINUE 41 CONTINUE curCha=curCha+nl else write(IOIMP,*) 'Trop de procedures' endif enddo c lecture de la correspondance des lignes READ(36,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR if (iostat.gt.0) then goto 96 endif segini utif3 curCha=1 do curLig=1,nLig+1 c attention, ici, on fait l'hypothese que iLonEn est un multiple de 10 READ(cCHAR(curCha:curCha+9),FMT=204,IOSTAT=IOSTAT) & utif3.debCha(curLig) if (iostat.gt.0) then nLig=curLig-2 segadj utif3 goto 96 endif c WRITE(6,*) 'ligne',curLig,utif3.debCha(curLig) curCha=curCha+10 if(curCha.GE.iLonEn) then curEnr=curEnr+1 READ(36,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR if (iostat.gt.0) then nLig=curLig-1 segadj utif3 goto 96 endif curCha=1 endif enddo 96 continue utifi3(6)=utif3 IF(utifi3(6) .GT. 0) then segdes utif3 endif c dump de la lecture du fichier c write(IOIMP,*) 'dump de la lecture du fichier' c do 93 I=1,nEnt c write(IOIMP,94)pLiPro.nomEnt(i),(pLiPro.carDeb(i)/iLonEn), c & mod(pLiPro.carDeb(i),iLonEn) c write(IOIMP,94)pLiPro.nomEnt(i),pLiPro.carDeb(i) c write(IOIMP,94)pLiPro.nomEnt(i),pLiPro.carDeb(i), c & pLiPro.numFic(i) c94 FORMAT('Proc : ',A8,' ligne ',I10,'fichier',I3) c93 continue c write(IOIMP,*) 'statut',ISTAT,ISTAT2 lisProc=pLiPro segdes pLiPro IRET=9999 C 9998 CONTINUE c lecture du deuxieme fichier RETURN ENTRY PROCPO(JINDEX,IRET) c Le principe de cette routine est de placer le pointeur LINDEX au bon endroit c elle renvoit IRET = 0 en cas d erreur, 9999 sinon c Le pointeur LINDEX est place en fonction de la position demandee modulo le fichier c Le pointeur demandee est enregistree lors du nomobj de procpn c write(IOIMP,*)'Entree dans PROCPO' IRET=0 IF (ISTAT*ISTAT2.EQ.1) RETURN IF(JINDEX.GT.500000000) THEN c write(6,94)pLiPro.nomEnt(i),(pLiPro.carDeb(i)/iLonEn), c & mod(pLiPro.carDeb(i),iLonEn) curFic=36 curLig = (JINDEX-500000000) ELSE curFic=34 curLig = JINDEX ENDIF IRET=9999 c write(IOIMP,*)'sortie de PROCPO',IRET RETURN ENTRY PROCLI(IAREA,IRET) c Le principe de cette routine est de lire la ligne sous le pointeur LINDEX et d avancer le pointeur c La ligne est enregistree dans IAREA et le pointeur LINDEX est avance de 1 c Notre but ici va etre de lire 500 caractere a partir de curCha c (eventuellement avancer curEnr et s'arreter si on rencontre 4 c dollars. Puis renvoyer ca dans IAREA c write(IOIMP,*)'Entree dans PROCLI',ISTAT,ISTAT2 IRET=9999 IF (ISTAT*ISTAT2.EQ.1) RETURN utif3=utifi3(curfic-30) if(utif3.LE.0) RETURN segact utif3 nlig=utif3.debCha(/1) c write(IOIMP,*)'Nombre de lignes',nlig,curLig IF(curLig.GE.nlig)return curEnr = utif3.debCha(curLig)/iLonEn+1 c curCha = utif3.debCha(curLig) - ilonEn * (curEnr-1) curCha = mod(utif3.debCha(curLig),iLonEn)+1 curCh2 = mod(utif3.debCha(curLig+1),iLonEn) c write(6,*) 'Ligne ',curLig,curCha,curCh2 IRET=0 WRITE(cline,FMT=203)' ' READ(curFic,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cChar if (iostat.gt.0) then write(IOIMP,*)'Impossible de lire l''enregistrement',curEnr, & curFic IAREA(1:500)=cline(1:500) segdes utif3 return endif c Est-ce que curCh2 peut valoir 0 ?? if(curCha.LE.curCh2) then tmplong=curCh2-curCha+1 cline(1:tmplong) = cChar(curCha:curCh2) else tmplong=(iLonEn-curCha) + 1 cline(1:tmpLong)=cCHAR(curCha:iLonEn) c write(6,*) 'Premiere partie',curEnr,1,tmpLong,curCha,iLonEn, c & cline(1:tmpLong) curEnr=curEnr+1 READ(curFic,REC=curEnr,FMT=103,IOSTAT=IOSTAT)cCHAR if (iostat.eq.0) then cline(1+tmpLong:curCh2-curCha+1+iLonEn) = cChar(1:curCh2) tmplong=curCh2-curCha+1+iLonEn endif c write(6,*) 'Deuxieme partie',curEnr,1+tmpLong,1,curCh2, c & curCh2-curCha+1+iLonEn, c & cline(1+tmpLong:curCh2-curCha+1+iLonEn) endif c write(6,'(A,I10,A,I10,A,A,A)') 'Li',curLig,'/',nLig,', |', c & cline(1:tmplong),'|' c Nettoyage de cline : on s'arrete si on trouve des $$$$ puis on c enleve les blanc IF(cline(1:4).EQ.'$$$$')IRET=9999 IAREA(1:500)=cline(1:500) curLig=curLig+1 segdes utif3 c write(IOIMP,*)'sortie de PROCLI ',IRET RETURN ENTRY PROCL2(IAREA,IRET) c write(IOIMP,*)'Entree dans PROCL2' c Procli2 place le pointeur LINDEX sur le debut de la routine IAREA et dans le bon fichier pLiPro=lisProc segact pLiPro IRET=0 IF (ISTAT*ISTAT2.EQ.1) RETURN do 73 I=pLiPro.numFic(/1),1,-1 curFic=pLiPro.numFic(i) IF(curFic.EQ.34) THEN IRET=9999 ELSE IRET=9998 ENDIF curLig = pLiPro.carDeb(i) segdes pLiPro c write(IOIMP,*)'sortie de PROCL2 ',IRET return ENDIF 73 continue segdes pLiPro c write(IOIMP,*)'sortie de PROCL2 ',IRET RETURN 301 FORMAT(3I10) 202 FORMAT(A24,I10) 203 FORMAT(A) 204 FORMAT(I10) END
© Cast3M 2003 - Tous droits réservés.
Mentions légales