C UTILIS SOURCE PV 22/02/23 21:15:02 11292 SUBROUTINE UTILIS IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC CCNOYAU external long SEGMENT IINDE INTEGER INDOX(NINDE) CHARACTER*(LONOM) INDIX(NINDE) ENDSEGMENT CHARACTER*(LONOM) CNOM,CNOM2 LOGICAL KNOM2 SEGMENT UTIFIC integer debCha(nlig+1) ENDSEGMENT CHARACTER*4 MDIR(2) CHARACTER*500 ITEXT CHARACTER*4 IDOL CHARACTER*4 MDEBP CHARACTER*8 FNAME CHARACTER*100000 buff character*26 minus,majus integer curCha,curEnr,curLig,totCha integer iProc integer iLonEn integer finlu,deblu LOGICAL BOEXIS DATA minus/'abcdefghijklmnopqrstuvwxyz'/ DATA majus/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA iLonEn/100000/ 103 FORMAT(A100000) DATA IDOL/'$$$$'/ DATA MDEBP /'DEBP'/ DATA MDIR /'NOTI','PROC'/ KNOM2=.FALSE. CALL LIRMOT (MDIR,2,IROP,1) IF(IERR.NE.0) RETURN IF(IROP.EQ.1) THEN FNAME='UTILNOTI' IOUT=37 ELSEIF (IROP.EQ.2) THEN FNAME='UTILPROC' IOUT=36 ENDIF * 23/02/2022 debranchement moterr(1:40)='UTIL '//MDIR(irop) call erreur(1136) return CALL LIRCHA(ITEXT,1,IRETOU) IF(IERR.NE.0) RETURN L=LONG(ITEXT) IF(IERR.NE.0) RETURN c Voici la procedure : c on lit le fichier util proc / noti qu'on va remplir dans un tableau de c chaine de caractere, en meme temps, on remplit un tableau avec c le nombre de caractere par ligne c le nom de la procedure et le numero de la premiere ligne c on a le nombre de ligne, on peut donc trouver le nombre c d'enregistrement pour enregistrer la correspondance ligne/carac c On peut remplir l'enregistrement 1 avec le sommaire / procedure c numero de ligne c puis l'enregistrement 2 avec la correspondance ligne/carac c en faisant attention a augmenter le numero de l'enregistrement c enfin, on OPEN(UNIT=39,FILE=ITEXT(1:L),ACCESS='SEQUENTIAL',STATUS='OLD', & FORM='FORMATTED',IOSTAT=IOS) IF(IOS .NE. 0) GOTO 2000 * destruction du fichier cible puis reouverture CLOSE (UNIT=IOUT,STATUS='DELETE',IOSTAT=IOS) IF(IOS .NE. 0)THEN INTERR(1)=IOS MOTERR=FNAME CALL ERREUR(424) RETURN ENDIF UTIFI3(IOUT-30)=0 OPEN(UNIT=IOUT,FILE=FNAME,ACCESS='DIRECT',STATUS='UNKNOWN', & FORM='FORMATTED',RECL=iLonEn,IOSTAT=IOS) IF(IOS .NE. 0)THEN INTERR(1)=IOS MOTERR=FNAME CALL ERREUR(424) RETURN ENDIF NINDE=500 SEGINI IINDE nLig=200000 segini utific I=1 curCha=1 curEnr=2 curLig=1 totCha=iLonEn iProc=0 WRITE(IOUT,REC=1,FMT=300)1,1 110 CONTINUE READ(39,102,END=120)ITEXT c c Ignore les espaces en fin de ligne FINLU=LEN(ITEXT) DO WHILE ( FINLU.GT.0.AND.(ITEXT(FINLU:FINLU).EQ.' '.OR. > ICHAR(ITEXT(FINLU:FINLU)).EQ.13)) FINLU = FINLU -1 ENDDO IF (FINLU.EQ.0) THEN FINLU=1 ITEXT=' ' ENDIF c c Ignore les espaces en debut de ligne (desactive) DEBLU=1 c DO WHILE ( DEBLU.LT.FINLU.AND.ITEXT(DEBLU:DEBLU).EQ.' ') c DEBLU = DEBLU + 1 c ENDDO c IF(DEBLU.NE.1.AND.ITEXT(DEBLU:DEBLU).EQ.'*') THEN c DEBLU= DEBLU-1 c ENDIF c LONGLU=FINLU-DEBLU+1 UTIFIC.debCha(curLig)=totCha totCha=totCha+LONGLU curLig=curLig+1 IF(curLig.GT.nLig) THEN nLig=nLig+nLig SEGADJ UTIFIC ENDIF c c attention au cas ou curCha+LONGLU.eq.iLonEn IF(curCha+LONGLU-1.LE.iLonEn) THEN buff(curCha:curCha+LONGLU-1)=ITEXT(DEBLU:FINLU) c write(6,*) 'ecriture de ',curCha,'a',curCha+LONGLU-1 curCha=curCha+LONGLU if(curCha.gt.iLonEn) then WRITE(IOUT,REC=curEnr,FMT=103)buff curEnr=curEnr+1 curCha=1 endif ELSE c vidage buffer et passage a l enregistrement sup buff(curCha:iLonEn)=ITEXT(DEBLU:DEBLU+iLonEn-curCha) c write(6,*)'Passage a l enregistrement suivant. longueur :', c & LONGLU c write(6,*) 'ecriture de ',curCha,'a',iLonEn WRITE(IOUT,REC=curEnr,FMT=103)buff curEnr=curEnr+1 buff(1:LONGLU-(iLonEn-curCha+1))= & ITEXT(DEBLU+iLonEn-curCha+1:FINLU) curCha=LONGLU-(iLonEn-curCha+1)+1 c write(6,*) 'ecriture de 1 a',curCha-1 ENDIF c write(6,*) "ligne ajoutee ", curEnr, curCha, totCha c la ligne commence par $$$$ suivi d'un nom de procedure IF(ITEXT(1:4).EQ.IDOL.AND.ITEXT(6:5+LONOM).NE.' ') then iProc=iProc+1 IF(iProc.GT.NINDE) THEN NINDE=NINDE+NINDE SEGADJ IINDE ENDIF * on ne prend que le premier mot parmi les LONOM caracteres lus * car l'atelier logiciel ecri(vai)t des choses a cet emplacement * dans le cas des notices CNOM=ITEXT(6:min(5+LONOM,finlu)) DO LON=2,LONOM IF (CNOM(LON:LON).EQ.' ') GOTO 10 ENDDO 10 CALL VERNAM(CNOM(1:LON),IRET) IF (IRET.EQ.0) THEN MOTERR(1:8)=CNOM(1:LON) IF (LON.GT.8) MOTERR(7:8)='..' CALL ERREUR(1029) RETURN ENDIF INDIX(iProc)=CNOM(1:LON) INDOX(iProc)=curLig c write(6,*) "procedure ajoutee", INDIX(iProc), INDOX(iProc) endif c c on verifie si le nom derriere DEBP correspond bien a celui c derriere $$$$ (sinon erreur GEMAT lors de l'appel a la procedure) IDEBP=INDEX(ITEXT,MDEBP) INOM2=DEBLU if (irop.eq.1) goto 110 IF (IDEBP.GT.0) THEN IF (ITEXT(1:1).EQ.'*') GOTO 110 KNOM2=.TRUE. DO INOM2=IDEBP+3,FINLU IF (ITEXT(INOM2:INOM2).EQ.' ') GOTO 11 ENDDO c si l'on arrive ici, c'est que le nom de la procedure est c sur une autre ligne que l'instruction DEBP GOTO 110 11 CONTINUE ENDIF IF (KNOM2) THEN c on saute les eventuels commentaires entre DEBP et le nom c de la procedure IF (ITEXT(1:1).EQ.'*') GOTO 110 c on saute tous les eventuels espaces entre DEBP et le nom c de la procedure (ou bien en debut de la ligne suivant DEBP) DO K1=INOM2,FINLU IF (ITEXT(K1:K1).NE.' ') GOTO 12 ENDDO c si l'on arrive ici, c'est que le nom de la procedure n'est c pas sur cette ligne GOTO 110 12 CONTINUE c on a trouve le nom, on le lit jusqu'au bout DO K2=K1,FINLU IF (ITEXT(K2:K2).EQ.' '.OR.ITEXT(K2:K2).EQ.';') GOTO 13 ENDDO 13 CONTINUE IF (K2.NE.FINLU+1) K2=K2-1 KNOM2=.FALSE. CNOM2=ITEXT(K1:K2) * passage en majuscule de cnom2 do il=1,k2-k1+1 ind=index(minus,cnom2(il:il)) if (ind.ne.0) cnom2(il:il)=majus(ind:ind) enddo IF (CNOM2.NE.CNOM) THEN MOTERR(1:8)=CNOM(1:LON) IF (LON.GT.8) MOTERR(7:8)='..' MOTERR(9:16)=CNOM2(1:K2-K1+1) IF (K2-K1+1.GT.8) MOTERR(15:16)='..' CALL ERREUR(1031) RETURN ENDIF ENDIF GOTO 110 120 CONTINUE UTIFIC.debCha(curLig)=totCha c pour etre sur de ne pqs recuperer de reliquat WRITE(buff(curCha:iLonEn),FMT=203)' ' NINDE=Iproc nLig=curLig-1 WRITE(IOUT,REC=curEnr,FMT=103)buff curEnr=curEnr+1 WRITE(buff,FMT=301)curEnr,nLig,iProc curCha=31 nl=LONOM+10 DO iproc=1,ninde if(curcha.le.iLonEn-nl+1) then write(buff(curCha:curcha+nl-1),FMT=202) & INDIX(iProc),INDOX(iProc) curCha=curCha+nl else write(IOIMP,*) 'Trop de procedures ou de notices' endif enddo WRITE(IOUT,REC=1,FMT=103)buff curCha=1 WRITE(buff,FMT=203)' ' do curLig=1,nLig+1 c attention, ici, on fait l'hypothese que iLonEn est un multiple de 10 WRITE(buff(curCha:curCha+9),FMT=204) UTIFIC.debCha(curLig) curCha=curCha+10 if(curCha.GE.iLonEn) then WRITE(IOUT,REC=curEnr,FMT=103)buff WRITE(buff,FMT=203)' ' curEnr=curEnr+1 curCha=1 endif enddo WRITE(IOUT,REC=curEnr,FMT=103)buff CLOSE(UNIT=39) CLOSE(UNIT=IOUT) SEGSUP IINDE SEGSUP UTIFIC * CLOSE(UNIT=IOUT,STATUS='KEEP') RETURN 102 FORMAT(A500) c 101 FORMAT(A80) c 200 FORMAT(5(A8,I6)) 300 FORMAT(2I6) 301 FORMAT(3I10) 202 FORMAT(A24,I10) 203 FORMAT(A) 204 FORMAT(I10) 2000 CONTINUE MOTERR=ITEXT(1:L) INTERR(1)=IOS CALL ERREUR(599) END