Télécharger obteni.eso

Retour à la liste

Numérotation des lignes :

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

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