Télécharger la plaquette Cast3M


fr en

Télécharger operin.eso

Retour à la liste

Numérotation des lignes : 

operin

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

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