Télécharger obteni.eso

Retour à la liste

Numérotation des lignes :

  1. C OBTENI SOURCE CB215821 16/04/15 21:15:34 8907
  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. SEGDES MLENTI
  74. CALL NOMOBJ(CHAR,CHARB,MLENTI)
  75. GO TO 200
  76. ENDIF
  77. ENDIF
  78. IF(IRE.EQ.0.AND.CHAR.EQ.'LISTREEL') THEN
  79. MOTERR(1:8) ='LISTREEL'
  80. CALL ERREUR(-290)
  81. READ(IOTER,FMT='(A72)',END=21) TEXT(1:72)
  82. NRAN=0
  83. IFINAN=73
  84. ICOUR=72
  85. CALL REDLEC(sredle)
  86. IF(IRE.EQ.0) THEN
  87. SEGDES MLREEL
  88. CALL NOMOBJ(CHAR,CHARB,MLREEL)
  89. GO TO 200
  90. ENDIF
  91. ENDIF
  92. IF(IRE.EQ.0) GO TO 21
  93. IAVA=0
  94. IF(IRE.EQ.3) THEN
  95. DO 123 IAUX=1,NCAR
  96. * PASSAGE EN MAJUSCULE
  97. IRAL=INDEX(MINU,MOT(IAUX:IAUX))
  98. IF (IRAL.NE.0) MOT(IAUX:IAUX)=MAJU(IRAL:IRAL)
  99. 123 CONTINUE
  100. ENDIF
  101. CALL PRENOM(IPLAMO,IAVA,sredle)
  102. if(nbesc.ne.0) segact ipiloc
  103. IP= INOOB1(IPLAMO)
  104. IDEBCH=IPCHAR(IP)
  105. IFINCH=IPCHAR(IP+1)-1
  106. CNOMP=ICHARA(IDEBCH:IFINCH)
  107. IF(IIMPI.EQ.1754) WRITE(IOIMP,654) CNOMP
  108. # ,INOOB2(IPLAMO)
  109. 654 FORMAT(' DANS OBTENI OBJET(1.5) ',A8,2X,A8,2X,A4)
  110. IF(IIMPI.EQ.1754) WRITE(IOIMP,657)CHAR
  111. 657 FORMAT(' DANS OBTENI TYPE ATTENDU ',A8)
  112. if(nbesc.ne.0) segdes ipiloc
  113.  
  114. C
  115. C **** DECODAGE DE LA LECTURE ET VERIF DU TYPE
  116. C
  117. IF(CNOMP.NE.'NON ') GO TO 31
  118. 210 CONTINUE
  119. CALL NOMCHA(CHARB,'NON')
  120. GO TO 200
  121. 31 CONTINUE
  122. IF(CHAR.EQ.' ') CHAR=INOOB2(IPLAMO)
  123. IF(CHAR.EQ.'FLOTTANT'.AND.INOOB2(IPLAMO).EQ.'ENTIER ') THEN
  124. IOO=IOUEP2(IPLAMO)
  125. XPO=IOO
  126. CALL NOMREE(CHARB,XPO)
  127. GO TO 465
  128. ENDIF
  129. IF(CHAR.EQ.'LISTREEL') THEN
  130. IF(ICREA.EQ.0) THEN
  131. JG=0
  132. SEGINI MLREEL
  133. ICREA=1
  134. ENDIF
  135. IF(INOOB2(IPLAMO) .NE . 'ENTIER '.AND.
  136. $ INOOB2(IPLAMO) .NE . 'FLOTTANT' ) GO TO 210
  137. IOO=IOUEP2(IPLAMO)
  138. IF (INOOB2(IPLAMO).EQ.'ENTIER ') THEN
  139. XPO=IOO
  140. ELSE
  141. if(nbesc.ne.0) segact ipiloc
  142. XPO= XIFLOT(IOO)
  143. if(nbesc.ne.0) segdes ipiloc
  144. ENDIF
  145. JG=JG+1
  146. SEGADJ MLREEL
  147. PROG(JG)=XPO
  148. GO TO 25
  149. ENDIF
  150. IF(CHAR.EQ.'LISTENTI') THEN
  151. IF(ICREA.EQ.0) THEN
  152. JG=0
  153. SEGINI MLENTI
  154. ICREA=1
  155. ENDIF
  156. IF(INOOB2(IPLAMO) .NE . 'ENTIER ') GO TO 210
  157. JG=JG+1
  158. SEGADJ MLENTI
  159. LECT(JG)=IOUEP2(IPLAMO)
  160. GO TO 25
  161. ENDIF
  162. IF(CHAR.NE.INOOB2(IPLAMO)) GO TO 50
  163. IOO=IOUEP2(IPLAMO)
  164. if(nbesc.ne.0) segact ipiloc
  165. IF(CHAR.EQ.'ENTIER ') THEN
  166. IVAL=IOO
  167. CALL NOMENT(CHARB,IVAL)
  168. ELSEIF(CHAR.EQ.'FLOTTANT') THEN
  169. XPO= XIFLOT(IOO)
  170. CALL NOMREE(CHARB,XPO)
  171. ELSEIF(CHAR.EQ.'MOT ') THEN
  172. ID=IPCHAR(IOO)
  173. IFI=IPCHAR(IOO+1)
  174. IF1=IFI-ID
  175. CHARC=' '
  176. IF1=MIN(IF1,72)
  177. CHARC(1:IF1)=ICHARA(ID:IFI-1)
  178. CALL NOMCHA(CHARB,CHARC(1:IF1))
  179. ELSEIF(CHAR.EQ.'LOGIQUE ') THEN
  180. LOGI=IPLOGI(IOO)
  181. CALL NOMLOG(CHARB,LOGI)
  182. ELSE
  183. CALL NOMOBJ(CHAR,CHARB,IOO)
  184. ENDIF
  185. if(nbesc.ne.0) segdes ipiloc
  186. 465 CONTINUE
  187. IPASS=0
  188. GO TO 1
  189. 50 CONTINUE
  190. WRITE(IOIMP,51) CHAR
  191. 51 FORMAT(' LA QUANTITE LUE N''EST PAS DU TYPE ',A8,
  192. #' RECOMMENCEZ S''IL VOUS PLAIT')
  193. GO TO 20
  194. 200 CONTINUE
  195. C-- ON REMET TEXT EN PLACE
  196. * TEXT(1:500)=CMTEXT(1:500)
  197. * IFINAN=IFINA1
  198. * IPREC=IPREC1
  199. * ICOUR=ICOUR1
  200. * NRAN=NRAN1
  201. segsup sredle
  202. RETURN
  203. 21 CONTINUE
  204. IF(IOGRA.EQ.3.OR.IOGRA.EQ.2) THEN
  205. REWIND IOTER
  206. GOTO 210
  207. ELSE
  208. CALL ERREUR ( 34 )
  209. RETURN
  210. ENDIF
  211. END
  212.  
  213.  
  214.  

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