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

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