Télécharger la plaquette Cast3M


fr en

Télécharger utilis.eso

Retour à la liste

Numérotation des lignes : 

utilis

  1. C UTILIS    SOURCE    PV        22/02/23    21:15:02     11292          
  2.       SUBROUTINE UTILIS
  3.       IMPLICIT INTEGER(I-N)
  4.  
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC CCNOYAU
  8.       external long
  9.       SEGMENT IINDE
  10.        INTEGER INDOX(NINDE)
  11.        CHARACTER*(LONOM) INDIX(NINDE)
  12.       ENDSEGMENT
  13.       CHARACTER*(LONOM) CNOM,CNOM2
  14.       LOGICAL KNOM2
  15.       SEGMENT UTIFIC
  16.        integer debCha(nlig+1)
  17.       ENDSEGMENT
  18.       CHARACTER*4 MDIR(2)
  19.       CHARACTER*500 ITEXT
  20.       CHARACTER*4 IDOL
  21.       CHARACTER*4 MDEBP
  22.       CHARACTER*8 FNAME
  23.       CHARACTER*100000 buff
  24.       character*26 minus,majus
  25.  
  26.       integer curCha,curEnr,curLig,totCha
  27.       integer iProc
  28.       integer iLonEn
  29.       integer finlu,deblu
  30.  
  31.       LOGICAL BOEXIS
  32.  
  33.       DATA minus/'abcdefghijklmnopqrstuvwxyz'/
  34.       DATA majus/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  35.       DATA iLonEn/100000/
  36.   103 FORMAT(A100000)
  37.       DATA IDOL/'$$$$'/
  38.       DATA MDEBP /'DEBP'/
  39.       DATA MDIR /'NOTI','PROC'/
  40.       KNOM2=.FALSE.
  41.       CALL LIRMOT (MDIR,2,IROP,1)
  42.       IF(IERR.NE.0) RETURN
  43.       IF(IROP.EQ.1) THEN
  44.          FNAME='UTILNOTI'
  45.          IOUT=37
  46.       ELSEIF (IROP.EQ.2) THEN
  47.          FNAME='UTILPROC'
  48.          IOUT=36
  49.       ENDIF
  50. *  23/02/2022 debranchement
  51.       moterr(1:40)='UTIL '//MDIR(irop)
  52.       call erreur(1136)
  53.       return
  54.       CALL LIRCHA(ITEXT,1,IRETOU)
  55.       IF(IERR.NE.0) RETURN
  56.       L=LONG(ITEXT)
  57.       IF(IERR.NE.0) RETURN
  58. c       Voici la procedure :
  59. c       on lit le fichier util proc / noti qu'on va remplir dans un tableau de
  60. c       chaine de caractere, en meme temps, on remplit un tableau avec
  61. c       le nombre de caractere par ligne
  62. c       le nom de la procedure et le numero de la premiere ligne
  63. c       on a le nombre de ligne, on peut donc trouver le nombre
  64. c       d'enregistrement pour enregistrer la correspondance ligne/carac
  65. c       On peut remplir l'enregistrement 1 avec le sommaire / procedure
  66. c       numero de ligne        
  67. c       puis l'enregistrement 2 avec la correspondance ligne/carac
  68. c       en faisant attention a augmenter le numero de l'enregistrement
  69. c       enfin, on
  70.  
  71.         OPEN(UNIT=39,FILE=ITEXT(1:L),ACCESS='SEQUENTIAL',STATUS='OLD',
  72.      &       FORM='FORMATTED',IOSTAT=IOS)
  73.         IF(IOS .NE. 0) GOTO 2000
  74.  
  75. *  destruction du fichier cible puis reouverture
  76.         CLOSE (UNIT=IOUT,STATUS='DELETE',IOSTAT=IOS)
  77.         IF(IOS .NE. 0)THEN
  78.           INTERR(1)=IOS
  79.           MOTERR=FNAME
  80.           CALL ERREUR(424)
  81.           RETURN
  82.         ENDIF
  83.         UTIFI3(IOUT-30)=0
  84.  
  85.         OPEN(UNIT=IOUT,FILE=FNAME,ACCESS='DIRECT',STATUS='UNKNOWN',
  86.      &       FORM='FORMATTED',RECL=iLonEn,IOSTAT=IOS)
  87.         IF(IOS .NE. 0)THEN
  88.           INTERR(1)=IOS
  89.           MOTERR=FNAME
  90.           CALL ERREUR(424)
  91.           RETURN
  92.         ENDIF
  93.         NINDE=500
  94.         SEGINI IINDE
  95.         nLig=200000
  96.         segini utific
  97.         I=1
  98.         curCha=1
  99.         curEnr=2
  100.         curLig=1
  101.         totCha=iLonEn
  102.         iProc=0
  103.         WRITE(IOUT,REC=1,FMT=300)1,1
  104.   110   CONTINUE
  105.         READ(39,102,END=120)ITEXT
  106. c
  107. c       Ignore les espaces en fin de ligne        
  108.           FINLU=LEN(ITEXT)
  109.           DO WHILE ( FINLU.GT.0.AND.(ITEXT(FINLU:FINLU).EQ.' '.OR.
  110.      >     ICHAR(ITEXT(FINLU:FINLU)).EQ.13))
  111.           FINLU = FINLU -1
  112.           ENDDO 
  113.           IF (FINLU.EQ.0) THEN
  114.             FINLU=1
  115.             ITEXT=' '
  116.           ENDIF
  117. c
  118. c         Ignore les espaces en debut de ligne (desactive)    
  119.           DEBLU=1      
  120. c          DO WHILE ( DEBLU.LT.FINLU.AND.ITEXT(DEBLU:DEBLU).EQ.' ') 
  121. c          DEBLU = DEBLU + 1
  122. c          ENDDO 
  123. c          IF(DEBLU.NE.1.AND.ITEXT(DEBLU:DEBLU).EQ.'*') THEN
  124. c          DEBLU= DEBLU-1
  125. c          ENDIF
  126. c
  127.           LONGLU=FINLU-DEBLU+1
  128.           UTIFIC.debCha(curLig)=totCha
  129.           totCha=totCha+LONGLU
  130.           curLig=curLig+1
  131.           IF(curLig.GT.nLig) THEN
  132.             nLig=nLig+nLig
  133.             SEGADJ UTIFIC
  134.           ENDIF
  135. c
  136. c       attention au cas ou      curCha+LONGLU.eq.iLonEn     
  137.         IF(curCha+LONGLU-1.LE.iLonEn) THEN
  138.           buff(curCha:curCha+LONGLU-1)=ITEXT(DEBLU:FINLU)
  139. c          write(6,*) 'ecriture de ',curCha,'a',curCha+LONGLU-1
  140.           curCha=curCha+LONGLU
  141.           if(curCha.gt.iLonEn) then
  142.           WRITE(IOUT,REC=curEnr,FMT=103)buff
  143.           curEnr=curEnr+1
  144.           curCha=1
  145.           endif
  146.         ELSE
  147. c     vidage buffer et passage a l enregistrement sup        
  148.           buff(curCha:iLonEn)=ITEXT(DEBLU:DEBLU+iLonEn-curCha)
  149. c          write(6,*)'Passage a l enregistrement suivant. longueur :',
  150. c     &    LONGLU
  151. c          write(6,*) 'ecriture de ',curCha,'a',iLonEn
  152.           WRITE(IOUT,REC=curEnr,FMT=103)buff
  153.           curEnr=curEnr+1
  154.           buff(1:LONGLU-(iLonEn-curCha+1))=
  155.      &     ITEXT(DEBLU+iLonEn-curCha+1:FINLU)
  156.           curCha=LONGLU-(iLonEn-curCha+1)+1
  157. c          write(6,*) 'ecriture de 1 a',curCha-1
  158.         ENDIF
  159. c          write(6,*) "ligne ajoutee    ", curEnr, curCha, totCha
  160.  
  161. c      la ligne commence par $$$$ suivi d'un nom de procedure
  162.         IF(ITEXT(1:4).EQ.IDOL.AND.ITEXT(6:5+LONOM).NE.' ') then
  163.           iProc=iProc+1
  164.           IF(iProc.GT.NINDE) THEN
  165.             NINDE=NINDE+NINDE
  166.             SEGADJ IINDE
  167.           ENDIF
  168. *         on ne prend que le premier mot parmi les LONOM caracteres lus
  169. *         car l'atelier logiciel ecri(vai)t des choses a cet emplacement
  170. *         dans le cas des notices
  171.           CNOM=ITEXT(6:min(5+LONOM,finlu))
  172.           DO LON=2,LONOM
  173.             IF (CNOM(LON:LON).EQ.' ') GOTO 10
  174.           ENDDO
  175.   10      CALL VERNAM(CNOM(1:LON),IRET)
  176.           IF (IRET.EQ.0) THEN
  177.               MOTERR(1:8)=CNOM(1:LON)
  178.               IF (LON.GT.8) MOTERR(7:8)='..'
  179.               CALL ERREUR(1029)
  180.               RETURN
  181.           ENDIF
  182.           INDIX(iProc)=CNOM(1:LON)
  183.           INDOX(iProc)=curLig
  184. c          write(6,*) "procedure ajoutee", INDIX(iProc), INDOX(iProc)
  185.         endif
  186. c
  187. c      on verifie si le nom derriere DEBP correspond bien a celui
  188. c      derriere $$$$ (sinon erreur GEMAT lors de l'appel a la procedure)
  189.         IDEBP=INDEX(ITEXT,MDEBP)
  190.         INOM2=DEBLU
  191.         if (irop.eq.1) goto 110
  192.         IF (IDEBP.GT.0) THEN
  193.             IF (ITEXT(1:1).EQ.'*') GOTO 110
  194.             KNOM2=.TRUE.
  195.             DO INOM2=IDEBP+3,FINLU
  196.                 IF (ITEXT(INOM2:INOM2).EQ.' ') GOTO 11
  197.             ENDDO
  198. c           si l'on arrive ici, c'est que le nom de la procedure est
  199. c           sur une autre ligne que l'instruction DEBP
  200.             GOTO 110
  201.  11         CONTINUE
  202.         ENDIF
  203.         IF (KNOM2) THEN
  204. c           on saute les eventuels commentaires entre DEBP et le nom
  205. c           de la procedure
  206.             IF (ITEXT(1:1).EQ.'*') GOTO 110
  207. c           on saute tous les eventuels espaces entre DEBP et le nom
  208. c           de la procedure (ou bien en debut de la ligne suivant DEBP)
  209.             DO K1=INOM2,FINLU
  210.                 IF (ITEXT(K1:K1).NE.' ') GOTO 12
  211.             ENDDO
  212. c           si l'on arrive ici, c'est que le nom de la procedure n'est
  213. c           pas sur cette ligne
  214.             GOTO 110
  215.  12         CONTINUE
  216. c           on a trouve le nom, on le lit jusqu'au bout
  217.             DO K2=K1,FINLU
  218.                 IF (ITEXT(K2:K2).EQ.' '.OR.ITEXT(K2:K2).EQ.';') GOTO 13
  219.             ENDDO
  220.  13         CONTINUE
  221.             IF (K2.NE.FINLU+1) K2=K2-1
  222.             KNOM2=.FALSE.
  223.             CNOM2=ITEXT(K1:K2)
  224. *  passage en majuscule de cnom2
  225.             do il=1,k2-k1+1
  226.               ind=index(minus,cnom2(il:il))
  227.               if (ind.ne.0) cnom2(il:il)=majus(ind:ind)
  228.             enddo
  229.             IF (CNOM2.NE.CNOM) THEN
  230.               MOTERR(1:8)=CNOM(1:LON)
  231.               IF (LON.GT.8) MOTERR(7:8)='..'
  232.               MOTERR(9:16)=CNOM2(1:K2-K1+1)
  233.               IF (K2-K1+1.GT.8) MOTERR(15:16)='..'
  234.               CALL ERREUR(1031)
  235.               RETURN
  236.             ENDIF
  237.         ENDIF
  238.         GOTO 110
  239.  120    CONTINUE
  240.           UTIFIC.debCha(curLig)=totCha
  241. c       pour etre sur de ne pqs recuperer de reliquat        
  242.         WRITE(buff(curCha:iLonEn),FMT=203)' '
  243.         NINDE=Iproc
  244.         nLig=curLig-1
  245.         WRITE(IOUT,REC=curEnr,FMT=103)buff
  246.         curEnr=curEnr+1
  247.         WRITE(buff,FMT=301)curEnr,nLig,iProc
  248.         curCha=31
  249.         nl=LONOM+10
  250.         DO iproc=1,ninde
  251.         if(curcha.le.iLonEn-nl+1) then
  252.           write(buff(curCha:curcha+nl-1),FMT=202)
  253.      &    INDIX(iProc),INDOX(iProc)
  254.           curCha=curCha+nl
  255.         else
  256.           write(IOIMP,*) 'Trop de procedures ou de notices'
  257.         endif
  258.         enddo
  259.         WRITE(IOUT,REC=1,FMT=103)buff
  260.         curCha=1
  261.         WRITE(buff,FMT=203)' '
  262.  
  263.         do curLig=1,nLig+1
  264. c       attention, ici, on fait l'hypothese que iLonEn est un multiple de 10
  265.           WRITE(buff(curCha:curCha+9),FMT=204) UTIFIC.debCha(curLig)
  266.           curCha=curCha+10
  267.           if(curCha.GE.iLonEn) then
  268.           WRITE(IOUT,REC=curEnr,FMT=103)buff
  269.           WRITE(buff,FMT=203)' '
  270.           curEnr=curEnr+1
  271.           curCha=1
  272.           endif
  273.         enddo
  274.           WRITE(IOUT,REC=curEnr,FMT=103)buff
  275.  
  276.         CLOSE(UNIT=39)
  277.         CLOSE(UNIT=IOUT)
  278.         SEGSUP IINDE
  279.         SEGSUP UTIFIC
  280. *      CLOSE(UNIT=IOUT,STATUS='KEEP')
  281.         RETURN
  282.   102 FORMAT(A500)
  283. c   101 FORMAT(A80)
  284. c   200 FORMAT(5(A8,I6))
  285.   300 FORMAT(2I6)
  286.   301 FORMAT(3I10)
  287.   202 FORMAT(A24,I10)
  288.   203 FORMAT(A)
  289.   204 FORMAT(I10)
  290.  
  291.  2000 CONTINUE
  292.       MOTERR=ITEXT(1:L)
  293.       INTERR(1)=IOS
  294.       CALL ERREUR(599)
  295.       END
  296.  
  297.  
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  
  305.  
  306.  

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