Télécharger acquer.eso

Retour à la liste

Numérotation des lignes :

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

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