Télécharger obteni.eso

Retour à la liste

Numérotation des lignes :

  1. C OBTENI SOURCE CB215821 17/07/25 21:15:10 9519
  2. SUBROUTINE OBTENI
  3. IMPLICIT INTEGER(I-N)
  4. -INC CCNOYAU
  5. -INC CCOPTIO
  6. -INC CCREDLE
  7. -INC SMLENTI
  8. -INC SMLREEL
  9. -INC CCASSIS
  10. CHARACTER*(8) CHAR,CHARB,CNOMP
  11. CHARACTER*(72) CHARC
  12. CHARACTER*4 MOAST(1)
  13. LOGICAL LOGI
  14. CHARACTER*500 CMTEXT
  15. REAL*8 XPO
  16. CHARACTER*26 MINU,MAJU
  17. DATA MINU/'abcdefghijklmnopqrstuvwxyz'/
  18. DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  19. DATA MOAST/'* '/
  20. IPASS=1
  21. MLENTI=0
  22. MLREEL=0
  23. 1 CONTINUE
  24. CALL QUETYP (CHAR,IPASS,IRETOU)
  25. IF(IERR.NE.0) RETURN
  26. IF(IRETOU.EQ.0) GO TO 200
  27. IF(CHAR.EQ.'ENTIER ') THEN
  28. CALL LIRENT(IPO,1,IRETOU)
  29. ELSEIF(CHAR.EQ.'FLOTTANT')THEN
  30. CALL LIRREE(XPO,1,IRETOU)
  31. ELSEIF(CHAR.EQ.'MOT ')THEN
  32. CALL LIRCHA(CHAR,1,IRETOU)
  33. ELSEIF(CHAR.EQ.'LOGIQUE ')THEN
  34. CALL LIRLOG(LOGI,1,IRETOU)
  35. ELSE
  36. CALL LIROBJ(CHAR,IPO,1,IRETOU)
  37. ENDIF
  38. CALL QUENOM(CHARB)
  39. CALL LIRMOT(MOAST,1,IVAL,0)
  40. CHAR=' '
  41. IF(IVAL.NE.0) THEN
  42. CALL LIRCHA(CHAR,1,IRETOU)
  43. IF(IERR.NE.0) RETURN
  44. ENDIF
  45. ICREA=0
  46. IF(IPASS.NE.1) GO TO 25
  47. C
  48. C *** SAUVETAGE DE LA LECTURE
  49. C
  50. * CMTEXT(1:500)=TEXT(1:500)
  51. * NRAN1=NRAN
  52. * ICOUR1=ICOUR
  53. * IFINA1=IFINAN
  54. * IPREC1=IPREC
  55. call inired(sredle)
  56. NRAN= 0
  57. IPREC=1
  58. 20 CONTINUE
  59. NRAN=0
  60. IFINAN=73
  61. ICOUR=72
  62. READ(IOTER,FMT='(A72)',END=21) TEXT(1:72)
  63. 25 CALL REDLEC(sredle)
  64. IF(IRE.EQ.0.AND.CHAR.EQ.'LISTENTI') THEN
  65. MOTERR(1:8) ='LISTENTI'
  66. CALL ERREUR(-290)
  67. READ(IOTER,FMT='(A72)',END=21) TEXT(1:72)
  68. NRAN=0
  69. IFINAN=73
  70. ICOUR=72
  71. CALL REDLEC(sredle)
  72. IF(IRE.EQ.0) THEN
  73. IF(MLENTI.EQ.0) THEN
  74. CALL NOMOBJ('ANNULE',CHARB,MLENTI)
  75. ELSE
  76. SEGDES MLENTI
  77. CALL NOMOBJ(CHAR,CHARB,MLENTI)
  78. ENDIF
  79. GO TO 200
  80. ENDIF
  81. ENDIF
  82. IF(IRE.EQ.0.AND.CHAR.EQ.'LISTREEL') THEN
  83. MOTERR(1:8) ='LISTREEL'
  84. CALL ERREUR(-290)
  85. READ(IOTER,FMT='(A72)',END=21) TEXT(1:72)
  86. NRAN=0
  87. IFINAN=73
  88. ICOUR=72
  89. CALL REDLEC(sredle)
  90. IF(IRE.EQ.0) THEN
  91. IF(MLREEL.EQ.0) THEN
  92. CALL NOMOBJ('ANNULE',CHARB,MLREEL)
  93. ELSE
  94. SEGDES MLREEL
  95. CALL NOMOBJ(CHAR,CHARB,MLREEL)
  96. ENDIF
  97. GO TO 200
  98. ENDIF
  99. ENDIF
  100. IF(IRE.EQ.0) GO TO 21
  101. IAVA=0
  102. IF(IRE.EQ.3) THEN
  103. DO 123 IAUX=1,NCAR
  104. * PASSAGE EN MAJUSCULE
  105. IRAL=INDEX(MINU,MOT(IAUX:IAUX))
  106. IF (IRAL.NE.0) MOT(IAUX:IAUX)=MAJU(IRAL:IRAL)
  107. 123 CONTINUE
  108. ENDIF
  109. CALL PRENOM(IPLAMO,IAVA,sredle)
  110. if(nbesc.ne.0) segact ipiloc
  111. IP= INOOB1(IPLAMO)
  112. IDEBCH=IPCHAR(IP)
  113. IFINCH=IPCHAR(IP+1)-1
  114. CNOMP=ICHARA(IDEBCH:IFINCH)
  115. IF(IIMPI.EQ.1754) WRITE(IOIMP,654) CNOMP
  116. # ,INOOB2(IPLAMO)
  117. 654 FORMAT(' DANS OBTENI OBJET(1.5) ',A8,2X,A8,2X,A4)
  118. IF(IIMPI.EQ.1754) WRITE(IOIMP,657)CHAR
  119. 657 FORMAT(' DANS OBTENI TYPE ATTENDU ',A8)
  120. if(nbesc.ne.0) segdes ipiloc
  121.  
  122. C
  123. C **** DECODAGE DE LA LECTURE ET VERIF DU TYPE
  124. C
  125. IF(CNOMP.NE.'NON ') GO TO 31
  126. 210 CONTINUE
  127. CALL NOMOBJ('ANNULE',CHARB,ip1)
  128. GO TO 200
  129. 31 CONTINUE
  130. IF(CHAR.EQ.' ') CHAR=INOOB2(IPLAMO)
  131. IF(CHAR.EQ.'FLOTTANT'.AND.INOOB2(IPLAMO).EQ.'ENTIER ') THEN
  132. IOO=IOUEP2(IPLAMO)
  133. XPO=IOO
  134. CALL NOMREE(CHARB,XPO)
  135. GO TO 465
  136. ENDIF
  137. IF(CHAR.EQ.'LISTREEL') THEN
  138. IF(ICREA.EQ.0) THEN
  139. JG=0
  140. SEGINI MLREEL
  141. ICREA=1
  142. ENDIF
  143. IF(INOOB2(IPLAMO) .NE . 'ENTIER '.AND.
  144. $ INOOB2(IPLAMO) .NE . 'FLOTTANT' ) GO TO 54
  145. IOO=IOUEP2(IPLAMO)
  146. IF (INOOB2(IPLAMO).EQ.'ENTIER ') THEN
  147. XPO=IOO
  148. ELSE
  149. if(nbesc.ne.0) segact ipiloc
  150. XPO= XIFLOT(IOO)
  151. if(nbesc.ne.0) segdes ipiloc
  152. ENDIF
  153. JG=JG+1
  154. SEGADJ MLREEL
  155. PROG(JG)=XPO
  156. GO TO 25
  157. ENDIF
  158. IF(CHAR.EQ.'LISTENTI') THEN
  159. IF(ICREA.EQ.0) THEN
  160. JG=0
  161. SEGINI MLENTI
  162. ICREA=1
  163. ENDIF
  164. IF(INOOB2(IPLAMO) .NE . 'ENTIER ') GO TO 52
  165. JG=JG+1
  166. SEGADJ MLENTI
  167. LECT(JG)=IOUEP2(IPLAMO)
  168. GO TO 25
  169. ENDIF
  170. IF(CHAR.NE.INOOB2(IPLAMO)) GO TO 50
  171. IOO=IOUEP2(IPLAMO)
  172. if(nbesc.ne.0) segact ipiloc
  173. IF(CHAR.EQ.'ENTIER ') THEN
  174. IVAL=IOO
  175. CALL NOMENT(CHARB,IVAL)
  176. ELSEIF(CHAR.EQ.'FLOTTANT') THEN
  177. XPO= XIFLOT(IOO)
  178. CALL NOMREE(CHARB,XPO)
  179. ELSEIF(CHAR.EQ.'MOT ') THEN
  180. ID=IPCHAR(IOO)
  181. IFI=IPCHAR(IOO+1)
  182. IF1=IFI-ID
  183. CHARC=' '
  184. IF1=MIN(IF1,72)
  185. CHARC(1:IF1)=ICHARA(ID:IFI-1)
  186. CALL NOMCHA(CHARB,CHARC(1:IF1))
  187. ELSEIF(CHAR.EQ.'LOGIQUE ') THEN
  188. LOGI=IPLOGI(IOO)
  189. CALL NOMLOG(CHARB,LOGI)
  190. ELSE
  191. CALL NOMOBJ(CHAR,CHARB,IOO)
  192. ENDIF
  193. if(nbesc.ne.0) segdes ipiloc
  194. 465 CONTINUE
  195. IPASS=0
  196. GO TO 1
  197. 50 CONTINUE
  198. WRITE(IOIMP,51) CHAR
  199. 51 FORMAT(' LA QUANTITE LUE N''EST PAS DU TYPE ',A8,
  200. #' RECOMMENCEZ S''IL VOUS PLAIT')
  201. GO TO 20
  202. 52 CONTINUE
  203. WRITE(IOIMP,53) 'ENTIER'
  204. 53 FORMAT(' LA QUANTITE LUE N''EST PAS DU TYPE ',A8,
  205. #' RECOMMENCEZ S''IL VOUS PLAIT')
  206. GO TO 20
  207. 54 CONTINUE
  208. WRITE(IOIMP,55) 'FLOTTANT'
  209. 55 FORMAT(' LA QUANTITE LUE N''EST PAS DU TYPE ',A8,
  210. #' RECOMMENCEZ S''IL VOUS PLAIT')
  211. GO TO 20
  212. 200 CONTINUE
  213. C-- ON REMET TEXT EN PLACE
  214. * TEXT(1:500)=CMTEXT(1:500)
  215. * IFINAN=IFINA1
  216. * IPREC=IPREC1
  217. * ICOUR=ICOUR1
  218. * NRAN=NRAN1
  219. segsup sredle
  220. RETURN
  221. 21 CONTINUE
  222. IF(IOGRA.EQ.3.OR.IOGRA.EQ.2) THEN
  223. C REWIND IOTER
  224. GOTO 210
  225. ELSE
  226. CALL ERREUR ( 34 )
  227. RETURN
  228. ENDIF
  229. END
  230.  
  231.  
  232.  
  233.  
  234.  

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