Télécharger la plaquette Cast3M


fr en

Télécharger anasyn.eso

Retour à la liste

Numérotation des lignes : 

anasyn

  1. C ANASYN    SOURCE    PV        20/11/15    23:26:13     10785          
  2. C    BUT    :  FOURNIR LA PHRASE ELEMENTAIRE A TRAITER
  3. C
  4. C    SORTIE : IPEG  LOGIQUE VRAI S'IL EXISTE UN SIGNE EGAL FAUX SINON
  5. C             IPVIR=1 ON EST ARRIVE AU POINT-VIRGULE =0 SINON
  6. C
  7. C    VARIABLES INTERNES : IDEB  DEBUT DANS TEXTE DE LA PHRASE A TRAITER
  8. C                         IFINAN  POSITION DU ;
  9. C
  10. C    VARIABLES EXTERNES : IPREC  POSITION DU PREMIER CARACTERE DE LA
  11. C                         PHRASE ELEMENTAIRE (CONTIENT LES NOMS A
  12. C                         AFFECTER).
  13. C                         ICOUR  POSITION DU DERNIER CARACTERE.
  14. C                         IEGAL  POSITION DU SIGNE = ( OU IPREC).
  15. C
  16. C    LA PHRASE COMPLETE EST DANS TEXT.
  17. C
  18. C
  19.       SUBROUTINE ANASYN(IPEG,IPVIR)
  20.  
  21.       IMPLICIT INTEGER (I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC CCREDLE
  27. -INC CCNOYAU
  28.  
  29.       LOGICAL IPEG,ITXCR
  30.       LOGICAL INIANA
  31.       LOGICAL ITERM
  32.       LOGICAL itx
  33.       LOGICAL bGuil
  34.       integer jpos
  35.       SAVE ITERM,INIANA,ITXCR,IDEB
  36. C   DIRECTIVE SUR LOCHAI CARACTERES AU MAX
  37.       CHARACTER*(LOCHAI) BUF,CTAMPO
  38.       CHARACTER*26 MINU,MAJU
  39.       DATA MINU/'abcdefghijklmnopqrstuvwxyz'/
  40.       DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  41.       DATA ITERM/.FALSE./
  42.       DATA INIANA/.TRUE./
  43.  
  44.       sredle=iredle
  45.       IF (ITERM) THEN
  46.         IERR=3
  47.         CALL FIN
  48.       ENDIF
  49.       IPEG=.FALSE.
  50.       IF (.NOT.INIANA.AND.IERR.EQ.0) THEN
  51.         I1=IPREC+1
  52.         IF (IDPAR.EQ.0) THEN
  53.           I1=IPREC
  54.         ENDIF
  55.         I2=ICOUR-1
  56.         IF (I1.EQ.1.AND.I2.EQ.IFINAN-1) THEN
  57.           N=IPOS-IFINAN
  58.           IF (N.NE.0) THEN
  59.             IPAR=IFINAN+1
  60.             BUF(1:N)=TEXT(IPAR:IPAR+N-1)
  61.             TEXT(1:N)=BUF(1:N)
  62.             ICOUR=1
  63.             IDC=IDEB
  64.             IPOS=N
  65.             LGPTT=0
  66.             LGETT=0
  67.             GOTO 3
  68.           ENDIF
  69.         ELSE
  70.           GOTO 100
  71.         ENDIF
  72.       ENDIF
  73.       ITXCR=.FALSE.
  74.       INIANA=.FALSE.
  75.       IDEB=1
  76.       ICOUR=1
  77.       IFINAN=0
  78.    1  IPOS=IFINAN+1
  79. c      write(6,*) 'Ipos vaut ',ipos
  80.       IF (IPOS.GE.500) THEN
  81. c      on va faire un deborder lors de la lecture : on sort en erreur
  82. c      avant (427+72=500)
  83.         moterr(1:40)=text(1:40)
  84.         write(IOIMP,*) text
  85.         CALL ERREUR(3)
  86.         RETURN
  87.       ENDIF
  88.       IF (ITERM) THEN
  89.         RETURN
  90.       ENDIF
  91.       CALL LIRECA
  92. c          write(IOIMP,*)TEXT(IFINAN+1:IPOS)
  93. c      write(6,*) 'Verif guille',IFINAN+1,IPOS
  94.       bGuil=.FALSE.
  95.         DO JPOS=IFINAN+1,IPOS
  96. c            write(6,*) JPOS,TEXT(JPOS:JPOS)
  97.           IF (TEXT(JPOS:JPOS).EQ.'''') THEN
  98.             bGuil=.NOT.bGuil
  99.           ENDIF
  100.         ENDDO
  101.         IF(bGuil) THEN
  102.           write(IOIMP,*)TEXT(IFINAN+1:IPOS)
  103.           call erreur (1071)
  104.         GOTO 111
  105.         ENDIF
  106. c          write(6,*) TEXT(1:IPOS)
  107.       IF (IPOS.EQ.IFINAN+1) THEN
  108.         CALL ERREUR(4)
  109.         IF (IFINAN.EQ.0) THEN
  110.           CALL FIN
  111.         ENDIF
  112.         I=IFINAN
  113.         ITERM=.TRUE.
  114.         GOTO 10
  115.       ENDIF
  116.       IDC=IFINAN+1
  117.       IF(.NOT.ITXCR) THEN
  118. C  COMPACTAGE DE LA CARTE DE DONNEE
  119.         DO  KL=IDC,IPOS
  120. c On cherche la position du premier caractere non espace
  121.          IF(TEXT(KL:KL).NE.' ') THEN
  122.             IF(KL.EQ.IDC) THEN
  123.               IDGD=KL
  124.             ELSE
  125.               IDGD=KL-1
  126.             ENDIF
  127.             GO TO 334
  128.          ENDIF
  129.         ENDDO
  130. C  IL N'Y A QUE DES BLANCS
  131.         GO TO 1
  132. c il faut comprendre goto 1 comme "on lit une nouvelle ligne"
  133.  334    DO  KL=IPOS,IDC,-1
  134. c On cherche la position du dernier caractere non espace
  135.           IF(TEXT(KL:KL).NE.' ') THEN
  136.             IF(KL.EQ.IPOS) THEN
  137.               IDGF=KL
  138.             ELSE
  139.               IDGF=KL+1
  140.             ENDIF
  141.             GO TO 336
  142.           ENDIF
  143.         ENDDO
  144.   336   CONTINUE
  145.         IDLO= IDGF-IDGD+1
  146.  
  147.         IF(IDLO.LE.500) THEN
  148.           CTAMPO(1:IDLO)=TEXT(IDGD:IDGF)
  149.           IPOS=IFINAN+IDLO
  150.           TEXT(IDC:IPOS)=CTAMPO(1:IDLO)
  151.         else
  152.           call erreur(5)
  153.         ENDIF
  154.       ENDIF
  155. C  FIN DU COMPACTAGE
  156.    3  CONTINUE
  157.       I = 0
  158.       DO IAUX=IDC,IPOS
  159.         IF (TEXT(IAUX:IAUX).EQ.'''') THEN
  160.           ITXCR=.NOT.ITXCR
  161.         ENDIF
  162.         IF (.NOT.ITXCR) THEN
  163. *  PASSAGE EN MAJUSCULE
  164.           IRAL=INDEX(MINU,TEXT(IAUX:IAUX))
  165.           IF (IRAL.NE.0) THEN
  166.             TEXT(IAUX:IAUX)=MAJU(IRAL:IRAL)
  167.           ENDIF
  168.           IF (TEXT(IAUX:IAUX).EQ.';') THEN
  169.             I = IAUX
  170.             GO TO 124
  171.           ENDIF
  172.         ENDIF
  173.       ENDDO
  174.  124  CONTINUE
  175.       IF (I.EQ.0) THEN
  176.         IFINAN=IPOS
  177.         GOTO 1
  178.       ENDIF
  179.   10  IFINAN=I
  180.       IERR=0
  181.       IERGLB=0
  182.       CALL RAZPIL
  183.       IPREC=IDEB
  184.       ICOUR=IDEB
  185.  100  ICAU=ICOUR
  186.       IF (ICAU.LE.IFINAN) THEN
  187.         ICOUR=ICAU-1
  188.         DO IAUX=ICAU,IFINAN
  189.           IF (TEXT(IAUX:IAUX).EQ.'''') THEN
  190.             ITXCR=.NOT.ITXCR
  191.           ENDIF
  192.           IF (.NOT.ITXCR.AND.TEXT(IAUX:IAUX).EQ.')') THEN
  193.             ICOUR = IAUX
  194.             GO TO 114
  195.           ENDIF
  196.         ENDDO
  197.  114    CONTINUE
  198.         IF (ICOUR.NE.(ICAU-1)) THEN
  199.           IFPAR=1
  200.         ELSE
  201.           IFPAR=0
  202.           ICOUR=IFINAN
  203.         ENDIF
  204.       ENDIF
  205.       IDREC=ICOUR-1
  206.       IF (IDREC.GE.0) THEN
  207.         IDPAR=1
  208.         ITXCR=.FALSE.
  209.         DO IAUX=IDEB,IDREC
  210.           IPREC=IDREC+IDEB-IAUX
  211.           IF (TEXT(IPREC:IPREC).EQ.'''') THEN
  212.             ITXCR=.NOT.ITXCR
  213.           ENDIF
  214.           IF (.NOT.ITXCR) THEN
  215.             IF (TEXT(IPREC:IPREC).EQ.'=') THEN
  216.               IPEG=.TRUE.
  217.               IEGAL=IPREC
  218.             ENDIF
  219.             IF (TEXT(IPREC:IPREC).EQ.'(') GOTO 111
  220.           ENDIF
  221.         ENDDO
  222.       ENDIF
  223.       IPREC=1
  224.       IDPAR=0
  225.  111  CONTINUE
  226.       IF (.NOT.IPEG) THEN
  227.         IEGAL = IPREC
  228.       ENDIF
  229.       moterr(1:40)=text(1:40)
  230.       IF (IFPAR.EQ.0.AND.IDPAR.EQ.1) THEN
  231.         CALL ERREUR(1)
  232.       ENDIF
  233.       IF (IDPAR.EQ.0.AND.IFPAR.EQ.1) THEN
  234.         CALL ERREUR(2)
  235.       ENDIF
  236.       IF (IDPAR.EQ.1) THEN
  237.         TEXT(IPREC:IPREC)=' '
  238.       ENDIF
  239.       TEXT(ICOUR:ICOUR)=' '
  240.       IF (IIMPI.EQ.1) THEN
  241.         WRITE (IOIMP,3000) (TEXT(IBO:IBO),IBO=IPREC,ICOUR)
  242.       ENDIF
  243.       NRAN=IPREC-1
  244. C   EN ATTENDANT DE TROUVER MIEUX   ------
  245.       IF(ICOUR.EQ.IFINAN) THEN
  246.         IPVIR= 1
  247.       ENDIF
  248.       ISTOP=0
  249.       ieg=0
  250.       itx=.false.
  251.       do iaa=nran,icour
  252.         if(TEXT(Iaa:Iaa).EQ.'''') then
  253.           itx= .not.itx
  254.         endif
  255.         if(.not.itx.and.text(iaa:iaa).eq.'=')  then
  256.             ieg=ieg+1
  257.         endif
  258.       enddo
  259.       if(ieg.ge.2)  then
  260.         call erreur (1014)
  261.         return
  262.       endif
  263.       RETURN
  264.  3000 FORMAT (/,(' ANALYSE -',72A1))
  265.       END
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  

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