Télécharger anasyn.eso

Retour à la liste

Numérotation des lignes :

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

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