Télécharger operin.eso

Retour à la liste

Numérotation des lignes :

  1. C OPERIN SOURCE JC220346 14/12/19 21:15:04 8332
  2. ************************************************************************
  3. * NOM : ENTI
  4. * DESCRIPTION : Convertit si possible un objet en nombre entier
  5. ************************************************************************
  6. * APPELE PAR : pilot.eso
  7. ************************************************************************
  8. * ENTREES :: aucune
  9. * SORTIES :: aucune
  10. ************************************************************************
  11. * SYNTAXE (GIBIANE) :
  12. *
  13. * OBJ2 = ENTI (|'TRONCATURE'|) OBJ1 ;
  14. * |'INFERIEUR' |
  15. * |'SUPERIEUR' |
  16. * |'PROCHE' |
  17. *
  18. ************************************************************************
  19. SUBROUTINE OPERIN
  20. IMPLICIT INTEGER(I-N)
  21. IMPLICIT REAL*8(A-H,O-Z)
  22. -INC CCOPTIO
  23. -INC SMLENTI
  24. -INC SMLREEL
  25. -INC SMLMOTS
  26. -INC SMCHPOI
  27. *
  28. CHARACTER*8 CHA8
  29. CHARACTER*32 CH32
  30. *
  31. PARAMETER (NBRTYP=6)
  32. CHARACTER*8 LISTYP(NBRTYP)
  33. DATA LISTYP/'ENTIER','FLOTTANT','LISTREEL','CHPOINT','MOT',
  34. & 'LISTMOTS'/
  35. *
  36. PARAMETER (NBROPT=4)
  37. CHARACTER*4 LISOPT(NBROPT)
  38. DATA LISOPT/'TRON','INFE','SUPE','PROC'/
  39. *
  40. *
  41. * LECTURE DU TYPE DE CONVERSION
  42. CALL LIRMOT(LISOPT,NBROPT,NUMOPT,0)
  43. IF (NUMOPT.EQ.0) NUMOPT=1
  44. *
  45. * LECTURE DU TYPE D'OBJET A CONVERTIR
  46. CALL QUETYP(CHA8,1,IRETOU)
  47. IF (IERR.NE.0) RETURN
  48. CALL PLACE(LISTYP,NBRTYP,NUMTYP,CHA8)
  49. IF (NUMTYP.EQ.0) THEN
  50. * "On ne veut pas d'objet de type %m1:8"
  51. MOTERR(1:8)=CHA8
  52. CALL ERREUR(39)
  53. RETURN
  54. ENDIF
  55. *
  56. *
  57. *
  58. * +---------------------------------------------------------------+
  59. * | O B J E T = E N T I E R |
  60. * +---------------------------------------------------------------+
  61. *
  62. IF (NUMTYP.EQ.1) THEN
  63. CALL LIRENT(IVAL1,1,IRETOU)
  64. IF (IERR.NE.0) RETURN
  65. *
  66. CALL ECRENT(IVAL1)
  67. *
  68. RETURN
  69. *
  70. *
  71. *
  72. * +---------------------------------------------------------------+
  73. * | O B J E T = F L O T T A N T |
  74. * +---------------------------------------------------------------+
  75. *
  76. ELSEIF (NUMTYP.EQ.2) THEN
  77. CALL LIRREE(XVAL1,1,IRETOU)
  78. IF (IERR.NE.0) RETURN
  79. *
  80. IF (NUMOPT.EQ.1) THEN
  81. IVAL1=INT(XVAL1)
  82. ELSEIF (NUMOPT.EQ.2) THEN
  83. IVAL1=FLOOR(XVAL1)
  84. ELSEIF (NUMOPT.EQ.3) THEN
  85. IVAL1=CEILING(XVAL1)
  86. ELSEIF (NUMOPT.EQ.4) THEN
  87. IVAL1=NINT(XVAL1)
  88. ENDIF
  89. *
  90. CALL ECRENT(IVAL1)
  91. *
  92. RETURN
  93. *
  94. *
  95. *
  96. * +---------------------------------------------------------------+
  97. * | O B J E T = L I S T R E E L |
  98. * +---------------------------------------------------------------+
  99. *
  100. ELSEIF (NUMTYP.EQ.3) THEN
  101. CALL LIROBJ(CHA8,MLREEL,1,IRETOU)
  102. IF (IERR.NE.0) RETURN
  103. *
  104. SEGACT,MLREEL
  105. JG=PROG(/1)
  106. SEGINI,MLENTI
  107. *
  108. IF (NUMOPT.EQ.1) THEN
  109. DO 10 I=1,JG
  110. LECT(I)=INT(PROG(I))
  111. 10 CONTINUE
  112. ELSEIF (NUMOPT.EQ.2) THEN
  113. DO 11 I=1,JG
  114. LECT(I)=FLOOR(PROG(I))
  115. 11 CONTINUE
  116. ELSEIF (NUMOPT.EQ.3) THEN
  117. DO 12 I=1,JG
  118. LECT(I)=CEILING(PROG(I))
  119. 12 CONTINUE
  120. ELSEIF (NUMOPT.EQ.4) THEN
  121. DO 13 I=1,JG
  122. LECT(I)=NINT(PROG(I))
  123. 13 CONTINUE
  124. ENDIF
  125. *
  126. SEGDES,MLREEL,MLENTI
  127. *
  128. CALL ECROBJ('LISTENTI',MLENTI)
  129. *
  130. RETURN
  131. *
  132. *
  133. *
  134. * +---------------------------------------------------------------+
  135. * | O B J E T = C H P O I N T |
  136. * +---------------------------------------------------------------+
  137. *
  138. ELSEIF (NUMTYP.EQ.4) THEN
  139. CALL LIROBJ(CHA8,MCHPOI,1,IRETOU)
  140. IF (IERR.NE.0) RETURN
  141. *
  142. SEGINI,MCHPO1=MCHPOI
  143. NSOUPO=MCHPO1.IPCHP(/1)
  144. DO 20 I=1,NSOUPO
  145. MSOUPO=MCHPO1.IPCHP(I)
  146. SEGINI,MSOUP1=MSOUPO
  147. MCHPO1.IPCHP(I)=MSOUP1
  148. *
  149. MPOVAL=MSOUP1.IPOVAL
  150. SEGINI,MPOVA1=MPOVAL
  151. MSOUP1.IPOVAL=MPOVA1
  152. *
  153. N=MPOVA1.VPOCHA(/1)
  154. NC=MPOVA1.VPOCHA(/2)
  155.  
  156. IF (NUMOPT.EQ.1) THEN
  157. DO 210 J=1,NC
  158. DO 220 K=1,N
  159. MPOVA1.VPOCHA(K,J)=INT(MPOVA1.VPOCHA(K,J))
  160. 220 CONTINUE
  161. 210 CONTINUE
  162. ELSEIF (NUMOPT.EQ.2) THEN
  163. DO 230 J=1,NC
  164. DO 240 K=1,N
  165. MPOVA1.VPOCHA(K,J)=FLOOR(MPOVA1.VPOCHA(K,J))
  166. 240 CONTINUE
  167. 230 CONTINUE
  168. ELSEIF (NUMOPT.EQ.3) THEN
  169. DO 250 J=1,NC
  170. DO 260 K=1,N
  171. MPOVA1.VPOCHA(K,J)=CEILING(MPOVA1.VPOCHA(K,J))
  172. 260 CONTINUE
  173. 250 CONTINUE
  174. ELSEIF (NUMOPT.EQ.4) THEN
  175. DO 270 J=1,NC
  176. DO 280 K=1,N
  177. MPOVA1.VPOCHA(K,J)=NINT(MPOVA1.VPOCHA(K,J))
  178. 280 CONTINUE
  179. 270 CONTINUE
  180. ENDIF
  181. *
  182. SEGDES,MSOUP1,MPOVA1
  183. 20 CONTINUE
  184. *
  185. SEGDES,MCHPO1
  186. *
  187. CALL ECROBJ('CHPOINT',MCHPO1)
  188. *
  189. RETURN
  190. *
  191. *
  192. *
  193. * +---------------------------------------------------------------+
  194. * | O B J E T = M O T |
  195. * +---------------------------------------------------------------+
  196. *
  197. ELSEIF (NUMTYP.EQ.5) THEN
  198. CALL LIRCHA(CH32,1,IRETOU)
  199. IF (IERR.NE.0) RETURN
  200. *
  201. WRITE(CHA8,FMT='("(I",I2,")")') IRETOU
  202. READ(CH32(1:IRETOU),FMT=CHA8,IOSTAT=IOS) IVAL1
  203. IF (IOS.NE.0) THEN
  204. WRITE(CHA8,FMT='("(F",I2,".0)")') IRETOU
  205. READ(CH32(1:IRETOU),FMT=CHA8,ERR=999) XVAL1
  206. IF (NUMOPT.EQ.1) THEN
  207. IVAL1=INT(XVAL1)
  208. ELSEIF (NUMOPT.EQ.2) THEN
  209. IVAL1=FLOOR(XVAL1)
  210. ELSEIF (NUMOPT.EQ.3) THEN
  211. IVAL1=CEILING(XVAL1)
  212. ELSEIF (NUMOPT.EQ.4) THEN
  213. IVAL1=NINT(XVAL1)
  214. ENDIF
  215. ENDIF
  216. *
  217. CALL ECRENT(IVAL1)
  218. *
  219. RETURN
  220. *
  221. *
  222. *
  223. * +---------------------------------------------------------------+
  224. * | O B J E T = L I S T M O T S |
  225. * +---------------------------------------------------------------+
  226. *
  227. ELSEIF (NUMTYP.EQ.6) THEN
  228. CALL LIROBJ('LISTMOTS',MLMOTS,1,IRETOU)
  229. IF (IERR.NE.0) RETURN
  230. *
  231. SEGACT MLMOTS
  232. JG=MOTS(/2)
  233. SEGINI MLENTI
  234. *
  235. IF (NUMOPT.EQ.1) THEN
  236. DO 30 I=1,JG
  237. READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  238. IF (IOS.NE.0) THEN
  239. READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  240. LECT(I)=INT(XVAL1)
  241. ENDIF
  242. 30 CONTINUE
  243. ELSEIF (NUMOPT.EQ.2) THEN
  244. DO 31 I=1,JG
  245. READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  246. IF (IOS.NE.0) THEN
  247. READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  248. LECT(I)=FLOOR(XVAL1)
  249. ENDIF
  250. 31 CONTINUE
  251. ELSEIF (NUMOPT.EQ.3) THEN
  252. DO 32 I=1,JG
  253. READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  254. IF (IOS.NE.0) THEN
  255. READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  256. LECT(I)=CEILING(XVAL1)
  257. ENDIF
  258. 32 CONTINUE
  259. ELSEIF (NUMOPT.EQ.4) THEN
  260. DO 33 I=1,JG
  261. READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  262. IF (IOS.NE.0) THEN
  263. READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  264. LECT(I)=NINT(XVAL1)
  265. ENDIF
  266. 33 CONTINUE
  267. ENDIF
  268. *
  269. SEGDES,MLMOTS,MLENTI
  270. *
  271. CALL ECROBJ('LISTENTI',MLENTI)
  272. *
  273. RETURN
  274. ENDIF
  275. *
  276. *
  277. *
  278. * /!\ ERREUR LORS DE LA CONVERSION MOT=>FLOTTANT
  279. 999 CALL ERREUR(21)
  280. RETURN
  281. *
  282. END
  283. *
  284.  
  285.  

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