Télécharger acquer.eso

Retour à la liste

Numérotation des lignes :

  1. C ACQUER SOURCE FANDEUR 14/07/10 21:15:01 8089
  2.  
  3. SUBROUTINE ACQUER(IBRUT)
  4. * SG
  5. * IBRUT est un entier valant 1 si l'option 'BRUT' a été lue et 0 sinon
  6. * Si IBRUT vaut 1, un traitement particulier est effectué dans
  7. * pilot pour ne pas interpréter la ligne lue (comme avec CHAI et MOT)
  8. *
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8 (A-H,O-Z)
  11.  
  12. -INC CCNOYAU
  13. -INC CCOPTIO
  14. -INC CCASSIS
  15. -INC CCREDLE
  16.  
  17. -INC SMLENTI
  18. -INC SMLREEL
  19.  
  20. EXTERNAL LONG
  21. LOGICAL LOGI
  22. REAL*8 XPO
  23. CHARACTER*8 CHAR,CHARB
  24. CHARACTER*26 MINU,MAJU
  25. CHARACTER*4 MOAST(1)
  26. CHARACTER*4 MOBRUT(1)
  27.  
  28. C TAILLE D'UN ENREGISTREMENT DU FICHIER IOACQ : NCARMAX CARACTERES
  29. C La taille est limitee a 500 (dimension de TEXT dans SREDLE).
  30. PARAMETER (NCARMAX = 256 , NCARFIN = NCARMAX+1)
  31. * PARAMETER (NCARMAX = 72 , NCARFIN = NCARMAX+1)
  32. C MOT pouvant etre lu dans un enregistrement
  33. CHARACTER*(NCARMAX) CHARMO
  34. C Moins de limitation dans l'option 'BRUT'
  35. CHARACTER*512 CHARM2
  36.  
  37. DATA MINU / 'abcdefghijklmnopqrstuvwxyz' /
  38. DATA MAJU / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
  39. DATA MOAST / '* ' /
  40. DATA MOBRUT/ 'BRUT' /
  41. C FORMAT DE LECTURE D'UN ENREGISTREMENT DU FICHIER IOACQ
  42. 3000 FORMAT(A256)
  43. *3000 FORMAT(A72)
  44. C FORMAT pour l'option BRUT
  45. 3002 FORMAT(A512)
  46. *
  47. CALL LIRMOT(MOBRUT,1,IBRUT,0)
  48. * Cas : chaine = ACQU 'BRUT' ;
  49. IF (IBRUT.EQ.1) THEN
  50. * Initialise SREDLE a 0 pour garder le traitement d'erreur normal au
  51. * label 21
  52. SREDLE=0
  53. READ(IOACQ,FMT=3002,END=21,ERR=21) CHARM2
  54. LONCHA=LONG(CHARM2)
  55. CALL ECRCHA(CHARM2(1:LONCHA))
  56. RETURN
  57. ENDIF
  58. *
  59. CALL POSCHA('NON',IPONON)
  60. IF (IERR.NE.0) RETURN
  61.  
  62. IPASS=1
  63.  
  64. SREDLE=0
  65. CALL INIRED(SREDLE)
  66. IPREC =1
  67. NRAN =0
  68. ICOUR =NCARMAX
  69. IFINAN=NCARFIN
  70.  
  71. 1 CONTINUE
  72. CALL QUETYP(CHAR,0,IRETOU)
  73. IF (IRETOU.EQ.0) GOTO 200
  74. C Lecture du NOM Gibiane (CHARB) de l'objet a acquerir
  75. CALL LIROBJ(CHAR,IPO,0,IRETOU)
  76. CALL QUENOM(CHARB)
  77. IF (IIMPI.EQ.1754) THEN
  78. WRITE(IOIMP,FMT='('' TYPE LU : '',A8)') CHAR
  79. WRITE(IOIMP,FMT='('' NOM LU : '',A8)') CHARB
  80. ENDIF
  81. C On veut savoir si l'objet a acquerir doit avoir un TYPE ('*....')
  82. CALL QUETYP(CHAR,0,iretou)
  83. IVAL=0
  84. IF (CHAR.EQ.'MOT ') CALL LIRMOT(MOAST,1,IVAL,0)
  85. IF (IIMPI.EQ.1754) THEN
  86. IF (IVAL.EQ.0) THEN
  87. WRITE(IOIMP,FMT='('' PAS D ASTERISQUE TOUVEE '')')
  88. ELSE
  89. WRITE(IOIMP,FMT='('' ASTERISQUE TOUVEE '')')
  90. ENDIF
  91. ENDIF
  92. C CHAR contient le type demande de l'objet (=' 'si aucun + IVAL=0)
  93. CHAR=' '
  94. IF (IVAL.NE.0) THEN
  95. C Lecture du TYPE de l'objet a acquerir demande par l'utilisateur
  96. CALL LIRCHA(CHAR,1,IRETOU)
  97. IF (IERR.NE.0) GOTO 200
  98. IF (IIMPI.EQ.1754)WRITE(IOIMP,FMT='('' TYPE ATTENDU '',A8)')CHAR
  99. C
  100. C CAS DES LISTENTI ET DES LISTREEL
  101. C
  102. IF (CHAR.EQ.'LISTENTI'.OR.CHAR.EQ.'LISTREEL') THEN
  103. CALL LIRENT(JG,1,IRETOU)
  104. IF (IERR.NE.0) GOTO 200
  105. IOP = 0
  106. IF (CHAR.EQ.'LISTENTI') THEN
  107. SEGINI MLENTI
  108. IF (IPASS.EQ.0) GOTO 202
  109. SEPARA=.FALSE.
  110. 201 CONTINUE
  111. NRAN=0
  112. ICOUR =NCARMAX
  113. IFINAN=NCARFIN
  114. READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
  115. 202 CONTINUE
  116. CALL REDLEC(sredle)
  117. IF (IRE.EQ.0) GOTO 201
  118. IOP=IOP+1
  119. IF (IRE.NE.1) THEN
  120. CALL ERREUR(8)
  121. GOTO 200
  122. ENDIF
  123. LECT(IOP)=NFIX
  124. IF (IOP.LT.JG) GOTO 202
  125. SEGDES,MLENTI
  126. CALL NOMOBJ('LISTENTI',CHARB,MLENTI)
  127. C* ELSE IF (CHAR.EQ.'LISTREEL') THEN
  128. ELSE
  129. SEGINI,MLREEL
  130. IF (IPASS.EQ.0) GOTO 302
  131. SEPARA=.FALSE.
  132. 301 CONTINUE
  133. NRAN=0
  134. ICOUR =NCARMAX
  135. IFINAN=NCARFIN
  136. READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
  137. 302 CALL REDLEC(sredle)
  138. IF (IRE.EQ.0) GOTO 301
  139. IOP=IOP+1
  140. IF (IRE.EQ.1) THEN
  141. PROG(IOP)=NFIX
  142. ELSE IF (IRE.EQ.2) THEN
  143. PROG(IOP)=FLOT
  144. ELSE
  145. CALL ERREUR(15)
  146. GOTO 200
  147. ENDIF
  148. IF (IOP.LT.JG) GOTO 302
  149. SEGDES,MLREEL
  150. CALL NOMOBJ('LISTREEL',CHARB,MLREEL)
  151. ENDIF
  152. IPASS=0
  153. GOTO 1
  154. ENDIF
  155. ENDIF
  156. C
  157. C AUTRES CAS ENTIER FLOTTANT MOT LOGIQUE
  158. C
  159. IF (IPASS.EQ.0) GOTO 25
  160. SEPARA=.FALSE.
  161. 20 CONTINUE
  162. NRAN=0
  163. ICOUR =NCARMAX
  164. IFINAN=NCARFIN
  165. READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
  166. 25 CONTINUE
  167. CALL REDLEC(sredle)
  168. IF (IRE.EQ.0) GOTO 20
  169. * PASSAGE EN MAJUSCULE SI UN MOT EST LU
  170. IF (IRE.EQ.3) THEN
  171. DO 123 IAUX=1, NCAR
  172. IRAL=INDEX(MINU,MOT(IAUX:IAUX))
  173. IF (IRAL.NE.0) MOT(IAUX:IAUX)=MAJU(IRAL:IRAL)
  174. 123 CONTINUE
  175. ENDIF
  176. IAVA=0
  177. CALL PRENOM(IPLAMO,IAVA,SREDLE)
  178. IF (IIMPI.EQ.1754) THEN
  179. WRITE(IOIMP,654) INOOB1(IPLAMO),INOOB2(IPLAMO)
  180. WRITE(IOIMP,657) CHAR
  181. ENDIF
  182. 654 FORMAT(' DANS ACQUER ) ',A8,2X,A8,2X,A4)
  183. 657 FORMAT(' DANS ACQUER TYPE ATTENDU ',A8)
  184. C
  185. C **** DECODAGE DE LA LECTURE ET VERIF DU TYPE
  186. C
  187. IF (INOOB1(IPLAMO).EQ.IPONON) THEN
  188. CHAR='NON'
  189. CALL NOMCHA(CHARB,CHAR)
  190. GOTO 200
  191. ENDIF
  192. IF (CHAR.EQ.' ') CHAR=INOOB2(IPLAMO)
  193. IOO=IOUEP2(IPLAMO)
  194. IF (CHAR.EQ.'FLOTTANT'.AND.INOOB2(IPLAMO).EQ.'ENTIER ') THEN
  195. XPO=IOO
  196. CALL NOMREE(CHARB,XPO)
  197. GO TO 465
  198. ENDIF
  199. IF (CHAR.NE.INOOB2(IPLAMO)) THEN
  200. C- ERREUR : donnee lue pas du TYPE demande
  201. MOTERR(1:8)=INOOB2(IPLAMO)
  202. CALL ERREUR(39)
  203. GOTO 200
  204. ENDIF
  205. if (nbesc.ne.0) segact ipiloc
  206. IF (CHAR.EQ.'ENTIER ') THEN
  207. IVAL=IOO
  208. CALL NOMENT(CHARB,IVAL)
  209. ELSE IF (CHAR.EQ.'FLOTTANT') THEN
  210. XPO=XIFLOT(IOO)
  211. CALL NOMREE(CHARB,XPO)
  212. ELSE IF (CHAR.EQ.'MOT ') THEN
  213. ID=IPCHAR(IOO)
  214. IFI=IPCHAR(IOO+1)
  215. IF1=IFI-ID
  216. IF1=MIN(IF1,NCARMAX)
  217. CHARMO(1:IF1)=ICHARA(ID:IFI-1)
  218. CALL NOMCHA(CHARB,CHARMO(1:IF1))
  219. ELSE IF (CHAR.EQ.'LOGIQUE ') THEN
  220. LOGI=IPLOGI(IOO)
  221. CALL NOMLOG(CHARB,LOGI)
  222. ELSE
  223. CALL NOMOBJ(CHAR,CHARB,IOO)
  224. ENDIF
  225. if (nbesc.ne.0) segdes ipiloc
  226. 465 CONTINUE
  227. IPASS=0
  228. GOTO 1
  229.  
  230. C- ERREUR : Fin du fichier atteinte pendant la lecture d'une donnee
  231. 21 CONTINUE
  232. CALL ERREUR(4)
  233. GOTO 200
  234.  
  235. C- FIN de l'acquisition (normale ou avec erreur)
  236. 200 CONTINUE
  237. * On peut avoir SREDLE=0 (option brut par exemple)
  238. IF (SREDLE.NE.0) SEGSUP,SREDLE
  239.  
  240. RETURN
  241. END
  242.  
  243.  
  244.  

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