1 : C ANASYN SOURCE CHAT 11/05/31 21:15:00 6991 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 : IMPLICIT INTEGER(I-N) 21 : -INC CCREDLE 22 : -INC CCOPTIO 23 : -INC CCNOYAU 24 : SAVE ITERM,INIANA,ITXCR,IDEB 25 : LOGICAL IPEG,ITXCR 26 : C DIRECTIVE SUR 500 CARACTERES AU MAX 27 : CHARACTER*500 BUF 28 : CHARACTER*72 CTAMPO 29 : CHARACTER*26 MINU,MAJU 30 : DATA MINU/'abcdefghijklmnopqrstuvwxyz'/ 31 : DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 32 : DATA ITERM/0/ 33 : DATA INIANA/0/ 34 : sredle=iredle 35 : IF (ITERM.EQ.1) THEN 36 : IERR=3 36 : CALL FIN 37 : ENDIF 38 : IPEG=.FALSE. 39 : IF (INIANA.EQ.0) GOTO 4 40 : IF (IERR.EQ.0) GOTO 201 41 : 4 CONTINUE 42 : ITXCR=.FALSE. 43 : INIANA=1 44 : IDEB=1 45 : ICOUR=1 46 : IFINAN=0 47 : 1 IPOS=IFINAN+1 48 : IF (IPOS.GT.427) GOTO 1000 49 : IF (ITERM.NE.0) RETURN 49 : CALL LIRECA 50 : IF (IPOS.EQ.IFINAN+1) GOTO 1001 51 : IDC=IFINAN+1 52 : IF(.NOT.ITXCR) THEN 53 : C COMPACTAGE DE LA CARTE DE DONNEE 54 : DO 333 KL=IDC,IPOS 55 : IF(TEXT(KL:KL).EQ.' ') GO TO 333 56 : IDGD=KL 57 : IF(IDGD.NE.IDC) IDGD=IDGD-1 58 : GO TO 334 59 : 333 CONTINUE 60 : C IL N'Y A QUE DES BLANCS 61 : GO TO 1 62 : 334 DO 335 KL=IPOS,IDC,-1 63 : IF(TEXT(KL:KL).EQ.' ') GO TO 335 64 : IDGF=KL 65 : IF(IDGF.NE.IPOS) IDGF=IDGF+1 66 : GO TO 336 67 : 335 CONTINUE 68 : 336 CONTINUE 69 : IDLO= IDGF-IDGD+1 70 : IF(IDLO.EQ.72) GO TO 339 71 : CTAMPO(1:IDLO)=TEXT(IDGD:IDGF) 72 : IPOS=IFINAN+IDLO 73 : TEXT(IDC:IPOS)=CTAMPO(1:IDLO) 74 : 339 CONTINUE 75 : ENDIF 76 : C FIN DU COMPACTAGE 77 : 3 CONTINUE 78 : I = 0 79 : DO 123 IAUX=IDC,IPOS 80 : IF (TEXT(IAUX:IAUX).EQ.'''') ITXCR=.NOT.ITXCR 81 : IF (ITXCR) GOTO 123 82 : * PASSAGE EN MAJUSCULE 83 : IRAL=INDEX(MINU,TEXT(IAUX:IAUX)) 84 : IF (IRAL.NE.0) TEXT(IAUX:IAUX)=MAJU(IRAL:IRAL) 85 : IF (TEXT(IAUX:IAUX).NE.';') GOTO 123 86 : I = IAUX 87 : GO TO 124 88 : 123 CONTINUE 89 : 124 CONTINUE 90 : IF (I.NE.0) GOTO 10 91 : IFINAN=IPOS 92 : GOTO 1 93 : 10 IFINAN=I 94 : IERR=0 94 : CALL RAZPIL 95 : IPREC=IDEB 96 : ICOUR=IDEB 97 : GO TO 100 98 : 200 N=IPOS-IFINAN 99 : IF (N.EQ.0) GOTO 4 100 : IPAR=IFINAN+1 101 : BUF(1:N)=TEXT(IPAR:IPAR+N-1) 102 : TEXT(1:N)=BUF(1:N) 103 : ICOUR=1 104 : IDC=IDEB 105 : IPOS=N 106 : LGPTT=0 107 : LGETT=0 108 : GOTO 3 109 : 100 ICAU=ICOUR 110 : IF (ICAU.GT.IFINAN) GOTO 102 111 : ICOUR=ICAU-1 112 : DO 113 IAUX=ICAU,IFINAN 113 : IF (TEXT(IAUX:IAUX).EQ.'''') ITXCR=.NOT.ITXCR 114 : IF (ITXCR) GOTO 113 115 : IF (TEXT(IAUX:IAUX).NE.')') GOTO 113 116 : ICOUR = IAUX 117 : GO TO 114 118 : 113 CONTINUE 119 : 114 CONTINUE 120 : IF (ICOUR.NE.(ICAU-1)) THEN 121 : IFPAR=1 122 : ELSE 123 : IFPAR=0 124 : ICOUR=IFINAN 125 : ENDIF 126 : 102 IDREC=ICOUR-1 127 : IF (IDREC.LT.0) GOTO 110 128 : IDPAR=1 129 : ITXCR=.FALSE. 130 : DO 103 IAUX=IDEB,IDREC 131 : IPREC=IDREC+IDEB-IAUX 132 : IF (TEXT(IPREC:IPREC).EQ.'''') ITXCR=.NOT.ITXCR 133 : IF (ITXCR) GOTO 103 134 : IF (TEXT(IPREC:IPREC).NE.'=') GOTO 105 135 : IPEG=.TRUE. 136 : IEGAL=IPREC 137 : 105 IF (TEXT(IPREC:IPREC).EQ.'(') GOTO 111 138 : 103 CONTINUE 139 : 110 IPREC=1 140 : IDPAR=0 141 : 111 CONTINUE 142 : IF (.NOT.IPEG) IEGAL = IPREC 143 : moterr(1:40)=text(1:40) 143 : IF (IFPAR.EQ.0.AND.IDPAR.EQ.1) CALL ERREUR(1) 143 : IF (IDPAR.EQ.0.AND.IFPAR.EQ.1) CALL ERREUR(2) 144 : IF (IDPAR.EQ.1) TEXT(IPREC:IPREC)=' ' 145 : TEXT(ICOUR:ICOUR)=' ' 146 : IF (IIMPI.NE.1) GOTO 104 147 : WRITE (IOIMP,3000) (TEXT(IBO:IBO),IBO=IPREC,ICOUR) 148 : 3000 FORMAT (/,(' ANALYSE -',72A1)) 149 : 104 NRAN=IPREC-1 150 : C EN ATTENDANT DE TROUVER MIEUX ------ 151 : IF(ICOUR.EQ.IFINAN) IPVIR= 1 152 : ISTOP=0 153 : ieg=0 154 : itx=0 155 : do iaa=nran,icour 156 : if(TEXT(Iaa:Iaa).EQ.'''') itx= itx+1 157 : if( itx.ge.2) itx=0 158 : if(itx.eq.0) then 159 : if( text(iaa:iaa).eq.'=') ieg=ieg+1 160 : endif 161 : enddo 162 : if(ieg.ge.2) then 162 : call erreur (1014) 163 : return 164 : * go to 4 165 : endif 166 : RETURN 167 : 201 CONTINUE 168 : I1=IPREC+1 169 : IF (IDPAR.EQ.0) I1=IPREC 170 : I2=ICOUR-1 171 : IL=I1-I2-1 172 : IF (I1.EQ.1.AND.I2.EQ.IFINAN-1) GOTO 200 173 : GOTO 100 174 : 1000 moterr(1:40)=text(1:40) 175 : write(6,*) text(1:72),text(73:144),text(145:216) 175 : CALL ERREUR(3) 176 : 177 : * GOTO 4 178 : return 178 : 1001 CALL ERREUR(4) 178 : IF (IFINAN.EQ.0) CALL FIN 179 : I=IFINAN 180 : ITERM=1 181 : GOTO 10 182 : END 183 : 184 : 185 : 186 : 187 : 188 : 189 : 190 : 191 : 192 : 193 : 194 :
© Cast3M 2003 - All rights reserved.
Disclaimer