Télécharger la plaquette Cast3M


fr en

Télécharger tevolu.eso

Retour à la liste

Numérotation des lignes : 

tevolu

  1. C TEVOLU    SOURCE    CB215821  23/07/12    21:15:12     11704          
  2.       SUBROUTINE TEVOLU(IEVO,TI)
  3. C
  4. C  =====================================================================
  5. C
  6. C     Options (PAS) AVANT et APRES à l'opération EXTR EVOL1
  7. C     (aggiunta opzione INDI per mots AVAN, APRE; arede 14.09.94)---
  8. C
  9. C  =====================================================================
  10. C
  11. C   CREATION     : 14.09.94
  12. C   PROGRAMMEUR  : ?
  13. C   Modification : PM 12/09/2007,
  14. C                  définition de la couleur et du type  de l'évolution
  15. C                  extraite
  16. C                  BP, 2015-10-16 : ajout option COMPris
  17. C
  18. C  =====================================================================
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8(A-H,O-Z)
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMEVOLL
  25. -INC SMLREEL
  26.       CHARACTER*(*) TI
  27.       CHARACTER*(4)  TI_4
  28.       SEGMENT        WEVOX(0)
  29.       SEGMENT        WEVOY(0)
  30. C
  31.       PARAMETER      (IOPZ=4)
  32.       CHARACTER*(4)  MOPZ(IOPZ)
  33.       CHARACTER*(4)  MOINDI(1)
  34.       CHARACTER*(4)  MOZERO(1)
  35.       DATA           MOPZ /'PAS ','AVAN','APRE','COMP'/
  36.       DATA           MOINDI/'INDI'/
  37.       DATA           MOZERO/'ZERO'/
  38.  
  39. ************************************************************************
  40. *     Activation et aiguillage
  41. ************************************************************************
  42.  
  43.       TI_4  = TI(1:4)
  44.       MEVOL1=IEVO
  45.       DO IMOT=1,IOPZ
  46.         IF(TI_4.EQ.MOPZ(IMOT)) GOTO (10,20,20,30),IMOT
  47.       ENDDO
  48.       CALL ERREUR(5)
  49.       GOTO 900
  50.  
  51. ************************************************************************
  52. *     option 'PAS'
  53. *     Extraction d'une valeur toutes les J
  54. ************************************************************************
  55. *
  56.    10 CONTINUE
  57. *     Lecture du pas
  58.       CALL LIRENT(J,1,IRETOU)
  59.       IF(IERR.NE.0) GOTO 900
  60.  
  61.       NW=0
  62.       N =0
  63.       SEGINI MEVOLL
  64.       JMEVO=MEVOLL
  65.       IEVTEX=MEVOL1.IEVTEX
  66.       ITYEVO=MEVOL1.ITYEVO
  67.       DO 11 KE=1,MEVOL1.IEVOLL(/1)
  68.         SEGINI WEVOX,WEVOY
  69.         KEVOL1=MEVOL1.IEVOLL(KE)
  70.         MLREE1=KEVOL1.IPROGX
  71.         MLREE2=KEVOL1.IPROGY
  72.         DO KN=1,MLREE1.PROG(/1),J
  73.           WEVOX(**)=MLREE1.PROG(KN)
  74.           WEVOY(**)=MLREE2.PROG(KN)
  75.         ENDDO
  76.  
  77. *       création évolution résultat
  78.         SEGINI KEVOLL
  79.         IEVOLL(**)=KEVOLL
  80.         NUMEVY=KEVOL1.NUMEVY
  81.         TYPX  ='LISTREEL'
  82.         TYPY  ='LISTREEL'
  83.         NOMEVX=KEVOL1.NOMEVX
  84.         NOMEVY=KEVOL1.NOMEVY
  85.         KEVTEX=KEVOL1.KEVTEX
  86.         NUMEVX=KEVOL1.NUMEVX
  87.         LPROG=WEVOX(/1)
  88.         JG=LPROG
  89.         SEGINI MLREE1
  90.         SEGINI MLREE2
  91.         IPROGX=MLREE1
  92.         IPROGY=MLREE2
  93.         DO KN=1,LPROG
  94.           MLREE1.PROG(KN)=WEVOX(KN)
  95.           MLREE2.PROG(KN)=WEVOY(KN)
  96.         ENDDO
  97.         SEGSUP WEVOX,WEVOY
  98.    11 CONTINUE
  99.       GOTO 777
  100.  
  101.  
  102. ************************************************************************
  103. *     Options AVANT / APRES [INDI] ['ZERO']
  104. ************************************************************************
  105.  
  106.    20 CONTINUE
  107.       CALL LIRMOT(MOINDI,1,IINDI,0)
  108.       IF(IERR.NE.0) GOTO 900
  109.       IF(IINDI.NE.0) THEN
  110.         CALL LIRENT(KKK,1,IRETOU)
  111.         IF(IERR.NE.0) GOTO 900
  112.       ELSE
  113.         CALL LIRREE(FLT,1,IRETOU)
  114.         IF(IERR.NE.0) GOTO 900
  115.       ENDIF
  116.       NW =0
  117.       N  =0
  118.       IZE=0
  119.       SEGINI MEVOLL
  120.       JMEVO=MEVOLL
  121.       IEVTEX=MEVOL1.IEVTEX
  122.       ITYEVO=MEVOL1.ITYEVO
  123.       DO 21 KE=1,MEVOL1.IEVOLL(/1)
  124.         SEGINI WEVOX,WEVOY
  125.         KEVOL1=MEVOL1.IEVOLL(KE)
  126.         MLREE1=KEVOL1.IPROGX
  127.         MLREE2=KEVOL1.IPROGY
  128. C
  129.         IF(IINDI.EQ.0) THEN
  130. *         comparaison de la valeur avec le seuil
  131.           IF(IMOT.EQ.2) THEN
  132.             DO KN=1,MLREE1.PROG(/1)
  133.               IF(FLT.GE.MLREE1.PROG(KN)) THEN
  134.                 WEVOX(**)=MLREE1.PROG(KN)
  135.                 WEVOY(**)=MLREE2.PROG(KN)
  136.               ENDIF
  137.             ENDDO
  138.           ELSEIF(IMOT.EQ.3) THEN
  139.             DO KN=1,MLREE1.PROG(/1)
  140.               IF(FLT.LE.MLREE1.PROG(KN)) THEN
  141.                 WEVOX(**)=MLREE1.PROG(KN)
  142.                 WEVOY(**)=MLREE2.PROG(KN)
  143.               ENDIF
  144.             ENDDO
  145.           ENDIF
  146.         ELSE
  147. *         comparaison de l'indice avec le seuil
  148.           IF(IMOT.EQ.2) THEN
  149.             DO KN=1,KKK
  150.                WEVOX(**)=MLREE1.PROG(KN)
  151.                WEVOY(**)=MLREE2.PROG(KN)
  152.             ENDDO
  153.           ELSEIF(IMOT.EQ.3) THEN
  154.             DO KN=KKK,MLREE1.PROG(/1)
  155.                WEVOX(**)=MLREE1.PROG(KN)
  156.                WEVOY(**)=MLREE2.PROG(KN)
  157.             ENDDO
  158.           ENDIF
  159.         ENDIF
  160.  
  161. C       changement de l'origine des abscisses à zéro ?
  162.         LPROG=WEVOX(/1)
  163.         CALL LIRMOT(MOZERO,1,IVAL,0)
  164.         IF(IERR.NE.0) GOTO 900
  165.         IF(IVAL.NE.0) THEN
  166.           IZE=1
  167.           FLT=WEVOX(1)
  168.         ENDIF
  169.  
  170. *       création évolution résultat
  171.         SEGINI KEVOLL
  172.         IEVOLL(**)=KEVOLL
  173.         NUMEVY=KEVOL1.NUMEVY
  174.         TYPX  ='LISTREEL'
  175.         TYPY  ='LISTREEL'
  176.         NOMEVX=KEVOL1.NOMEVX
  177.         NOMEVY=KEVOL1.NOMEVY
  178.         KEVTEX=KEVOL1.KEVTEX
  179.         NUMEVX=KEVOL1.NUMEVX
  180.         JG=LPROG
  181.         SEGINI MLREE1
  182.         SEGINI MLREE2
  183.         IPROGX=MLREE1
  184.         IPROGY=MLREE2
  185.         IF(IZE.EQ.0) THEN
  186.           DO KN=1,LPROG
  187.             MLREE1.PROG(KN)=WEVOX(KN)
  188.             MLREE2.PROG(KN)=WEVOY(KN)
  189.           ENDDO
  190.         ELSE
  191.           DO KN=1,LPROG
  192.             MLREE1.PROG(KN)=WEVOX(KN)-FLT
  193.             MLREE2.PROG(KN)=WEVOY(KN)
  194.           ENDDO
  195.         ENDIF
  196.         SEGSUP WEVOX,WEVOY
  197.    21 CONTINUE
  198.       GOTO 777
  199.  
  200.  
  201.  
  202. ************************************************************************
  203. *     Option COMP [INDI] ['ZERO']
  204. ************************************************************************
  205.    30 CONTINUE
  206.  
  207. c     lectures
  208.       CALL LIRMOT(MOINDI,1,IINDI,0)
  209.       IF(IERR.NE.0) GOTO 900
  210.       IF(IINDI.NE.0) THEN
  211.         CALL LIRENT(KKK1,1,IRETOU)
  212.         IF(IERR.NE.0) GOTO 900
  213.         CALL LIRENT(KKK2,1,IRETOU)
  214.         IF(IERR.NE.0) GOTO 900
  215.         IF(KKK1.GT.KKK2.or.KKK1.le.0.or.KKK2.le.0) THEN
  216.           INTERR(1)=KKK1
  217.           INTERR(2)=KKK2
  218.           CALL ERREUR(190)
  219.           GOTO 900
  220.         ENDIF
  221. c         write(ioimp,*) 'KKK1,KKK2=',KKK1,KKK2
  222.       ELSE
  223.         CALL LIRREE(FLT1,1,IRETOU)
  224.         IF(IERR.NE.0) GOTO 900
  225.         CALL LIRREE(FLT2,1,IRETOU)
  226.         IF(IERR.NE.0) GOTO 900
  227.         IF(FLT1.GT.FLT2) THEN
  228.           REAERR(1)=FLT1
  229.           REAERR(2)=FLT2
  230.           CALL ERREUR(191)
  231.           GOTO 900
  232.         ENDIF
  233. c         write(ioimp,*) 'FLT1,FLT2=',FLT1,FLT2
  234.       ENDIF
  235.  
  236. c     travail
  237.       NW =0
  238.       N  =0
  239.       IZE=0
  240.       SEGINI MEVOLL
  241.       JMEVO=MEVOLL
  242.       IEVTEX=MEVOL1.IEVTEX
  243.       ITYEVO=MEVOL1.ITYEVO
  244.       DO 31 KE=1,MEVOL1.IEVOLL(/1)
  245.         SEGINI WEVOX,WEVOY
  246.         KEVOL1=MEVOL1.IEVOLL(KE)
  247.         MLREE1=KEVOL1.IPROGX
  248.         MLREE2=KEVOL1.IPROGY
  249. C
  250.         IF(IINDI.EQ.0) THEN
  251. *         comparaison de la valeur avec le seuil
  252.           DO 32 KN=1,MLREE1.PROG(/1)
  253.               IF(MLREE1.PROG(KN).LT.FLT1) GOTO 32
  254.               IF(MLREE1.PROG(KN).GT.FLT2) GOTO 32
  255.               WEVOX(**)=MLREE1.PROG(KN)
  256.               WEVOY(**)=MLREE2.PROG(KN)
  257.  32       CONTINUE
  258.         ELSE
  259. *         comparaison de l'indice avec le seuil
  260.           if(KKK2.gt.MLREE1.PROG(/1)) then
  261.             INTERR(1)=KKK2
  262.             CALL ERREUR(36)
  263.             GOTO 900
  264.           endif
  265.           DO KN=KKK1,KKK2
  266.               WEVOX(**)=MLREE1.PROG(KN)
  267.               WEVOY(**)=MLREE2.PROG(KN)
  268.           ENDDO
  269.         ENDIF
  270.  
  271. C       changement de l'origine des abscisses à zéro ?
  272.         LPROG=WEVOX(/1)
  273.         CALL LIRMOT(MOZERO,1,IVAL,0)
  274.         IF(IERR.NE.0) GOTO 900
  275.         IF(IVAL.NE.0) THEN
  276.           IZE=1
  277.           FLT=WEVOX(1)
  278.         ENDIF
  279.  
  280. *       création évolution résultat
  281.         SEGINI KEVOLL
  282.         IEVOLL(**)=KEVOLL
  283.         NUMEVY=KEVOL1.NUMEVY
  284.         TYPX  ='LISTREEL'
  285.         TYPY  ='LISTREEL'
  286.         NOMEVX=KEVOL1.NOMEVX
  287.         NOMEVY=KEVOL1.NOMEVY
  288.         KEVTEX=KEVOL1.KEVTEX
  289.         NUMEVX=KEVOL1.NUMEVX
  290.         JG=LPROG
  291.         SEGINI MLREE1
  292.         SEGINI MLREE2
  293.         IPROGX=MLREE1
  294.         IPROGY=MLREE2
  295.         IF(IZE.EQ.0) THEN
  296.           DO KN=1,LPROG
  297.             MLREE1.PROG(KN)=WEVOX(KN)
  298.             MLREE2.PROG(KN)=WEVOY(KN)
  299.           ENDDO
  300.         ELSE
  301.           DO KN=1,LPROG
  302.             MLREE1.PROG(KN)=WEVOX(KN)-FLT
  303.             MLREE2.PROG(KN)=WEVOY(KN)
  304.           ENDDO
  305.         ENDIF
  306.         SEGSUP WEVOX,WEVOY
  307.    31 CONTINUE
  308.       GOTO 777
  309.  
  310.  
  311. ************************************************************************
  312. *     Ecriture du resultat
  313. ************************************************************************
  314.  
  315.   777 CONTINUE
  316.       CALL ACTOBJ('EVOLUTIO',JMEVO,1)
  317.       CALL ECROBJ('EVOLUTIO',JMEVO)
  318.  
  319.  
  320. ************************************************************************
  321. *     si erreur 5, on quitte proprement ...
  322. ************************************************************************
  323.  
  324.   900 CONTINUE
  325.  
  326.       RETURN
  327.       END
  328.  
  329.  
  330.  
  331.  

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