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/09/15    21:15:07     12642          
  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.          xgrand=igrand
  82.          xval1=min(xval1,xgrand)
  83.          xval1=max(xval1,-xgrand)
  84. *
  85.          IF (NUMOPT.EQ.1) THEN
  86.             IVAL1=INT(XVAL1)
  87.          ELSEIF (NUMOPT.EQ.2) THEN
  88.             IVAL1=FLOOR(XVAL1)
  89.          ELSEIF (NUMOPT.EQ.3) THEN
  90.             IVAL1=CEILING(XVAL1)
  91.          ELSEIF (NUMOPT.EQ.4) THEN
  92.             IVAL1=NINT(XVAL1)
  93.          ENDIF
  94. *
  95.          CALL ECRENT(IVAL1)
  96. *
  97.          RETURN
  98. *
  99. *
  100. *
  101. *     +---------------------------------------------------------------+
  102. *     |                O B J E T   =   L I S T R E E L                |
  103. *     +---------------------------------------------------------------+
  104. *
  105.       ELSEIF (NUMTYP.EQ.3) THEN
  106.          CALL LIROBJ(CHA8,MLREEL,1,IRETOU)
  107.          IF (IERR.NE.0) RETURN
  108. *
  109.          SEGACT,MLREEL
  110.          JG=PROG(/1)
  111.          SEGINI,MLENTI
  112. *
  113.          IF (NUMOPT.EQ.1) THEN
  114.             DO 10 I=1,JG
  115.                LECT(I)=INT(PROG(I))
  116.  10         CONTINUE
  117.          ELSEIF (NUMOPT.EQ.2) THEN
  118.             DO 11 I=1,JG
  119.                LECT(I)=FLOOR(PROG(I))
  120.  11         CONTINUE
  121.          ELSEIF (NUMOPT.EQ.3) THEN
  122.             DO 12 I=1,JG
  123.                LECT(I)=CEILING(PROG(I))
  124.  12         CONTINUE
  125.          ELSEIF (NUMOPT.EQ.4) THEN
  126.             DO 13 I=1,JG
  127.                LECT(I)=NINT(PROG(I))
  128.  13         CONTINUE
  129.          ENDIF
  130. *
  131.          SEGDES,MLREEL,MLENTI
  132. *
  133.          CALL ECROBJ('LISTENTI',MLENTI)
  134. *
  135.          RETURN
  136. *
  137. *
  138. *
  139. *     +---------------------------------------------------------------+
  140. *     |                 O B J E T   =   C H P O I N T                 |
  141. *     +---------------------------------------------------------------+
  142. *
  143.       ELSEIF (NUMTYP.EQ.4) THEN
  144.          CALL LIROBJ(CHA8,MCHPOI,1,IRETOU)
  145.          IF (IERR.NE.0) RETURN
  146. *
  147.          SEGINI,MCHPO1=MCHPOI
  148.          NSOUPO=MCHPO1.IPCHP(/1)
  149.          DO 20 I=1,NSOUPO
  150.             MSOUPO=MCHPO1.IPCHP(I)
  151.             SEGINI,MSOUP1=MSOUPO
  152.             MCHPO1.IPCHP(I)=MSOUP1
  153. *
  154.             MPOVAL=MSOUP1.IPOVAL
  155.             SEGINI,MPOVA1=MPOVAL
  156.             MSOUP1.IPOVAL=MPOVA1
  157. *
  158.             N=MPOVA1.VPOCHA(/1)
  159.             NC=MPOVA1.VPOCHA(/2)
  160.  
  161.             IF (NUMOPT.EQ.1) THEN
  162.                DO 210 J=1,NC
  163.                   DO 220 K=1,N
  164.                       MPOVA1.VPOCHA(K,J)=INT(MPOVA1.VPOCHA(K,J))
  165.  220              CONTINUE
  166.  210           CONTINUE
  167.             ELSEIF (NUMOPT.EQ.2) THEN
  168.                DO 230 J=1,NC
  169.                   DO 240 K=1,N
  170.                       MPOVA1.VPOCHA(K,J)=FLOOR(MPOVA1.VPOCHA(K,J))
  171.  240              CONTINUE
  172.  230           CONTINUE
  173.             ELSEIF (NUMOPT.EQ.3) THEN
  174.                DO 250 J=1,NC
  175.                   DO 260 K=1,N
  176.                       MPOVA1.VPOCHA(K,J)=CEILING(MPOVA1.VPOCHA(K,J))
  177.  260              CONTINUE
  178.  250           CONTINUE
  179.             ELSEIF (NUMOPT.EQ.4) THEN
  180.                DO 270 J=1,NC
  181.                   DO 280 K=1,N
  182.                       MPOVA1.VPOCHA(K,J)=NINT(MPOVA1.VPOCHA(K,J))
  183.  280              CONTINUE
  184.  270           CONTINUE
  185.             ENDIF
  186. *
  187.             SEGDES,MSOUP1,MPOVA1
  188.  20      CONTINUE
  189. *
  190.          SEGDES,MCHPO1
  191. *
  192.          CALL ECROBJ('CHPOINT',MCHPO1)
  193. *
  194.          RETURN
  195. *
  196. *
  197. *
  198. *     +---------------------------------------------------------------+
  199. *     |                     O B J E T   =   M O T                     |
  200. *     +---------------------------------------------------------------+
  201. *
  202.       ELSEIF (NUMTYP.EQ.5) THEN
  203.          CALL LIRCHA(CH32,1,IRETOU)
  204.          IF (IERR.NE.0) RETURN
  205. *
  206.          WRITE(CHA8,FMT='("(I",I2,")")') IRETOU
  207.          READ(CH32(1:IRETOU),FMT=CHA8,IOSTAT=IOS) IVAL1
  208.          IF (IOS.NE.0) THEN
  209.             WRITE(CHA8,FMT='("(F",I2,".0)")') IRETOU
  210.             READ(CH32(1:IRETOU),FMT=CHA8,ERR=999) XVAL1
  211.             IF (NUMOPT.EQ.1) THEN
  212.                 IVAL1=INT(XVAL1)
  213.             ELSEIF (NUMOPT.EQ.2) THEN
  214.                 IVAL1=FLOOR(XVAL1)
  215.             ELSEIF (NUMOPT.EQ.3) THEN
  216.                 IVAL1=CEILING(XVAL1)
  217.             ELSEIF (NUMOPT.EQ.4) THEN
  218.                 IVAL1=NINT(XVAL1)
  219.             ENDIF
  220.          ENDIF
  221. *
  222.          CALL ECRENT(IVAL1)
  223. *
  224.          RETURN
  225. *
  226. *
  227. *
  228. *     +---------------------------------------------------------------+
  229. *     |                O B J E T   =   L I S T M O T S                |
  230. *     +---------------------------------------------------------------+
  231. *
  232.       ELSEIF (NUMTYP.EQ.6) THEN
  233.          CALL LIROBJ('LISTMOTS',MLMOTS,1,IRETOU)
  234.          IF (IERR.NE.0) RETURN
  235. *
  236.          SEGACT MLMOTS
  237.          JG=MOTS(/2)
  238.          SEGINI MLENTI
  239. *
  240.          IF (NUMOPT.EQ.1) THEN
  241.             DO 30 I=1,JG
  242.                READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  243.                IF (IOS.NE.0) THEN
  244.                   READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  245.                   LECT(I)=INT(XVAL1)
  246.                ENDIF
  247.  30         CONTINUE
  248.          ELSEIF (NUMOPT.EQ.2) THEN
  249.             DO 31 I=1,JG
  250.                READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  251.                IF (IOS.NE.0) THEN
  252.                   READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  253.                   LECT(I)=FLOOR(XVAL1)
  254.                ENDIF
  255.  31         CONTINUE
  256.          ELSEIF (NUMOPT.EQ.3) THEN
  257.             DO 32 I=1,JG
  258.                READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  259.                IF (IOS.NE.0) THEN
  260.                   READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  261.                   LECT(I)=CEILING(XVAL1)
  262.                ENDIF
  263.  32         CONTINUE
  264.          ELSEIF (NUMOPT.EQ.4) THEN
  265.             DO 33 I=1,JG
  266.                READ(MOTS(I),FMT='(I4)',IOSTAT=IOS) LECT(I)
  267.                IF (IOS.NE.0) THEN
  268.                   READ(MOTS(I),FMT='(F4.0)',ERR=999) XVAL1
  269.                   LECT(I)=NINT(XVAL1)
  270.                ENDIF
  271.  33         CONTINUE
  272.          ENDIF
  273. *
  274.          SEGDES,MLMOTS,MLENTI
  275. *
  276.          CALL ECROBJ('LISTENTI',MLENTI)
  277. *
  278.          RETURN
  279.       ENDIF
  280. *
  281. *
  282. *
  283. * /!\ ERREUR LORS DE LA CONVERSION MOT=>FLOTTANT
  284.  999  CALL ERREUR(21)
  285.       RETURN
  286. *
  287.       END
  288. *
  289.  
  290.  
  291.  
  292.  
  293.  

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