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.  
  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. CALL RAZPIL
  182. IPREC=IDEB
  183. ICOUR=IDEB
  184. 100 ICAU=ICOUR
  185. IF (ICAU.LE.IFINAN) THEN
  186. ICOUR=ICAU-1
  187. DO IAUX=ICAU,IFINAN
  188. IF (TEXT(IAUX:IAUX).EQ.'''') THEN
  189. ITXCR=.NOT.ITXCR
  190. ENDIF
  191. IF (.NOT.ITXCR.AND.TEXT(IAUX:IAUX).EQ.')') THEN
  192. ICOUR = IAUX
  193. GO TO 114
  194. ENDIF
  195. ENDDO
  196. 114 CONTINUE
  197. IF (ICOUR.NE.(ICAU-1)) THEN
  198. IFPAR=1
  199. ELSE
  200. IFPAR=0
  201. ICOUR=IFINAN
  202. ENDIF
  203. ENDIF
  204. IDREC=ICOUR-1
  205. IF (IDREC.GE.0) THEN
  206. IDPAR=1
  207. ITXCR=.FALSE.
  208. DO IAUX=IDEB,IDREC
  209. IPREC=IDREC+IDEB-IAUX
  210. IF (TEXT(IPREC:IPREC).EQ.'''') THEN
  211. ITXCR=.NOT.ITXCR
  212. ENDIF
  213. IF (.NOT.ITXCR) THEN
  214. IF (TEXT(IPREC:IPREC).EQ.'=') THEN
  215. IPEG=.TRUE.
  216. IEGAL=IPREC
  217. ENDIF
  218. IF (TEXT(IPREC:IPREC).EQ.'(') GOTO 111
  219. ENDIF
  220. ENDDO
  221. ENDIF
  222. IPREC=1
  223. IDPAR=0
  224. 111 CONTINUE
  225. IF (.NOT.IPEG) THEN
  226. IEGAL = IPREC
  227. ENDIF
  228. moterr(1:40)=text(1:40)
  229. IF (IFPAR.EQ.0.AND.IDPAR.EQ.1) THEN
  230. CALL ERREUR(1)
  231. ENDIF
  232. IF (IDPAR.EQ.0.AND.IFPAR.EQ.1) THEN
  233. CALL ERREUR(2)
  234. ENDIF
  235. IF (IDPAR.EQ.1) THEN
  236. TEXT(IPREC:IPREC)=' '
  237. ENDIF
  238. TEXT(ICOUR:ICOUR)=' '
  239. IF (IIMPI.EQ.1) THEN
  240. WRITE (IOIMP,3000) (TEXT(IBO:IBO),IBO=IPREC,ICOUR)
  241. ENDIF
  242. NRAN=IPREC-1
  243. C EN ATTENDANT DE TROUVER MIEUX ------
  244. IF(ICOUR.EQ.IFINAN) THEN
  245. IPVIR= 1
  246. ENDIF
  247. ISTOP=0
  248. ieg=0
  249. itx=.false.
  250. do iaa=nran,icour
  251. if(TEXT(Iaa:Iaa).EQ.'''') then
  252. itx= .not.itx
  253. endif
  254. if(.not.itx.and.text(iaa:iaa).eq.'=') then
  255. ieg=ieg+1
  256. endif
  257. enddo
  258. if(ieg.ge.2) then
  259. call erreur (1014)
  260. return
  261. endif
  262. RETURN
  263. 3000 FORMAT (/,(' ANALYSE -',72A1))
  264. END
  265.  
  266.  
  267.  
  268.  
  269.  

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