Télécharger acquer.eso

Retour à la liste

Numérotation des lignes :

  1. C ACQUER SOURCE PV 19/03/22 21:15:00 10169
  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. * sauver lmnnom car prenom va l'augmenter
  73. LMNSAU=LMNNOM
  74.  
  75. 1 CONTINUE
  76. CALL QUETYP(CHAR,0,IRETOU)
  77. IF (IRETOU.EQ.0) GOTO 200
  78. C Lecture du NOM Gibiane (CHARB) de l'objet a acquerir
  79. CALL LIROBJ(CHAR,IPO,0,IRETOU)
  80. CALL QUENOM(CHARB)
  81. IF (IIMPI.EQ.1754) THEN
  82. WRITE(IOIMP,FMT='('' TYPE LU : '',A8)') CHAR
  83. WRITE(IOIMP,FMT='('' NOM LU : '',A24)') CHARB
  84. ENDIF
  85. C On veut savoir si l'objet a acquerir doit avoir un TYPE ('*....')
  86. CALL QUETYP(CHAR,0,iretou)
  87. IVAL=0
  88. IF (CHAR.EQ.'MOT ') CALL LIRMOT(MOAST,1,IVAL,0)
  89. IF (IIMPI.EQ.1754) THEN
  90. IF (IVAL.EQ.0) THEN
  91. WRITE(IOIMP,FMT='('' PAS D ASTERISQUE TOUVEE '')')
  92. ELSE
  93. WRITE(IOIMP,FMT='('' ASTERISQUE TOUVEE '')')
  94. ENDIF
  95. ENDIF
  96. C CHAR contient le type demande de l'objet (=' 'si aucun + IVAL=0)
  97. CHAR=' '
  98. IF (IVAL.NE.0) THEN
  99. C Lecture du TYPE de l'objet a acquerir demande par l'utilisateur
  100. CALL LIRCHA(CHAR,1,IRETOU)
  101. IF (IERR.NE.0) GOTO 200
  102. IF (IIMPI.EQ.1754)WRITE(IOIMP,FMT='('' TYPE ATTENDU '',A8)')CHAR
  103. C
  104. C CAS DES LISTENTI ET DES LISTREEL
  105. C
  106. IF (CHAR.EQ.'LISTENTI'.OR.CHAR.EQ.'LISTREEL') THEN
  107. CALL LIRENT(JG,1,IRETOU)
  108. IF (IERR.NE.0) GOTO 200
  109. IOP = 0
  110. IF (CHAR.EQ.'LISTENTI') THEN
  111. SEGINI MLENTI
  112. IF (IPASS.EQ.0) GOTO 202
  113. SEPARA=.FALSE.
  114. 201 CONTINUE
  115. NRAN=0
  116. ICOUR =NCARMAX
  117. IFINAN=NCARFIN
  118. READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
  119. 202 CONTINUE
  120. CALL REDLEC(sredle)
  121. IF (IRE.EQ.0) GOTO 201
  122. IOP=IOP+1
  123. IF (IRE.NE.1) THEN
  124. CALL ERREUR(8)
  125. GOTO 200
  126. ENDIF
  127. LECT(IOP)=NFIX
  128. IF (IOP.LT.JG) GOTO 202
  129. SEGDES,MLENTI
  130. CALL NOMOBJ('LISTENTI',CHARB,MLENTI)
  131. C* ELSE IF (CHAR.EQ.'LISTREEL') THEN
  132. ELSE
  133. SEGINI,MLREEL
  134. IF (IPASS.EQ.0) GOTO 302
  135. SEPARA=.FALSE.
  136. 301 CONTINUE
  137. NRAN=0
  138. ICOUR =NCARMAX
  139. IFINAN=NCARFIN
  140. READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
  141. 302 CALL REDLEC(sredle)
  142. IF (IRE.EQ.0) GOTO 301
  143. IOP=IOP+1
  144. IF (IRE.EQ.1) THEN
  145. PROG(IOP)=NFIX
  146. ELSE IF (IRE.EQ.2) THEN
  147. PROG(IOP)=FLOT
  148. ELSE
  149. CALL ERREUR(15)
  150. GOTO 200
  151. ENDIF
  152. IF (IOP.LT.JG) GOTO 302
  153. SEGDES,MLREEL
  154. CALL NOMOBJ('LISTREEL',CHARB,MLREEL)
  155. ENDIF
  156. IPASS=0
  157. GOTO 1
  158. ENDIF
  159. ENDIF
  160. C
  161. C AUTRES CAS ENTIER FLOTTANT MOT LOGIQUE
  162. C
  163. IF (IPASS.EQ.0) GOTO 25
  164. SEPARA=.FALSE.
  165. 20 CONTINUE
  166. NRAN=0
  167. ICOUR =NCARMAX
  168. IFINAN=NCARFIN
  169. READ(IOACQ,FMT=3000,END=21,ERR=21) TEXT
  170. 25 CONTINUE
  171. CALL REDLEC(sredle)
  172. IF (IRE.EQ.0) GOTO 20
  173. * PASSAGE EN MAJUSCULE SI UN MOT EST LU
  174. IF (IRE.EQ.3) THEN
  175. DO 123 IAUX=1, NCAR
  176. IRAL=INDEX(MINU,MOT(IAUX:IAUX))
  177. IF (IRAL.NE.0) MOT(IAUX:IAUX)=MAJU(IRAL:IRAL)
  178. 123 CONTINUE
  179. ENDIF
  180. IAVA=0
  181. CALL PRENOM(IPLAMO,IAVA,SREDLE)
  182. IF (IIMPI.EQ.1754) THEN
  183. WRITE(IOIMP,654) INOOB1(IPLAMO),INOOB2(IPLAMO)
  184. WRITE(IOIMP,657) CHAR
  185. ENDIF
  186. 654 FORMAT(' DANS ACQUER ) ',A8,2X,A8,2X,A4)
  187. 657 FORMAT(' DANS ACQUER TYPE ATTENDU ',A8)
  188. C
  189. C **** DECODAGE DE LA LECTURE ET VERIF DU TYPE
  190. C
  191. IF (INOOB1(IPLAMO).EQ.IPONON) THEN
  192. CHAR='NON'
  193. CALL NOMCHA(CHARB,CHAR)
  194. GOTO 200
  195. ENDIF
  196. IF (CHAR.EQ.' ') CHAR=INOOB2(IPLAMO)
  197. IOO=IOUEP2(IPLAMO)
  198. IF (CHAR.EQ.'FLOTTANT'.AND.INOOB2(IPLAMO).EQ.'ENTIER ') THEN
  199. XPO=IOO
  200. CALL NOMREE(CHARB,XPO)
  201. GO TO 465
  202. ENDIF
  203. IF (CHAR.NE.INOOB2(IPLAMO)) THEN
  204. C- ERREUR : donnee lue pas du TYPE demande
  205. MOTERR(1:8)=INOOB2(IPLAMO)
  206. CALL ERREUR(39)
  207. GOTO 200
  208. ENDIF
  209. if (nbesc.ne.0) segact ipiloc
  210. IF (CHAR.EQ.'ENTIER ') THEN
  211. IVAL=IOO
  212. CALL NOMENT(CHARB,IVAL)
  213. ELSE IF (CHAR.EQ.'FLOTTANT') THEN
  214. XPO=XIFLOT(IOO)
  215. CALL NOMREE(CHARB,XPO)
  216. ELSE IF (CHAR.EQ.'MOT ') THEN
  217. ID=IPCHAR(IOO)
  218. IFI=IPCHAR(IOO+1)
  219. IF1=IFI-ID
  220. IF1=MIN(IF1,NCARMAX)
  221. CHARMO(1:IF1)=ICHARA(ID:IFI-1)
  222. CALL NOMCHA(CHARB,CHARMO(1:IF1))
  223. ELSE IF (CHAR.EQ.'LOGIQUE ') THEN
  224. LOGI=IPLOGI(IOO)
  225. CALL NOMLOG(CHARB,LOGI)
  226. ELSE
  227. CALL NOMOBJ(CHAR,CHARB,IOO)
  228. ENDIF
  229. if (nbesc.ne.0) SEGDES,IPILOC
  230. 465 CONTINUE
  231. IPASS=0
  232. GOTO 1
  233.  
  234. C- ERREUR : Fin du fichier atteinte pendant la lecture d'une donnee
  235. 21 CONTINUE
  236. CALL ERREUR(4)
  237. GOTO 200
  238.  
  239. C- FIN de l'acquisition (normale ou avec erreur)
  240. 200 CONTINUE
  241. * On peut avoir SREDLE=0 (option brut par exemple)
  242. IF (SREDLE.NE.0) SEGSUP,SREDLE
  243. * srestaurer lmnnom
  244. LMNNOM=LMNSAU
  245.  
  246. RETURN
  247. END
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  

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