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

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