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