Télécharger la plaquette Cast3M


fr en

Télécharger evolin.eso

Retour à la liste

Numérotation des lignes : 

evolin

  1. C EVOLIN    SOURCE    CB215821  20/01/28    22:06:20     10508          
  2.       SUBROUTINE EVOLIN (IEV1,XX1,IEV2,XX2,IEV3)
  3. *____________________________________________________________________
  4. *
  5. *            Interpolation d'une courbe (type EVOLUTION)
  6. *        en fouction de deux autres courbes (type EVOLUTION)
  7. *
  8. *  ENTREES :
  9. *  ---------
  10. *
  11. *     IEV1   Pointeur sur un objet de type EVOLUTION
  12. *     IEV2   Pointeur sur le deuxieme objet de type EVOLUTION
  13. *     XX1    Flottant donnant le rapport entre la courbe
  14. *            a calculer et la courbe designee par IEV2
  15. *     XX2    Flottant donnant le rapport entre la courbe
  16. *            a calculer et la courbe designee par IEV1.
  17. *            Il existe la relation (XX1 + XX2)=1
  18. *
  19. *
  20. *  SORTIE :
  21. *  --------
  22. *
  23. *      IEV3  Pointeur sur l'objet EVOLUTION resultat
  24. *            =0 si operation impossible
  25. *
  26. *____________________________________________________________________
  27. *
  28.       IMPLICIT INTEGER(I-N)
  29.       IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC CCREEL
  35. -INC CCASSIS
  36. -INC SMEVOLL
  37. -INC SMLREEL
  38. -INC SMLENTI
  39.  
  40.       LOGICAL LOG0, LOG2
  41.       REAL*8  XNAN
  42. C             XNAN : Ne pas l'initialiser, c'est fait expres
  43.  
  44.       POINTEUR MREX.MLREEL,MREY.MLREEL,MREY2.MLREEL
  45.  
  46.       MEVOL1=IEV1
  47.       MEVOL2=IEV2
  48.       IF(MEVOL1.EQ.0 .OR. MEVOL2.EQ.0) THEN
  49.         MOTERR(1:8)='EVOLUTIO'
  50.         CALL ERREUR(37)
  51.         IEV3=0
  52.         RETURN
  53.       ENDIF
  54.  
  55.       N1=MEVOL1.IEVOLL(/1)
  56.       N2=MEVOL2.IEVOLL(/1)
  57.  
  58. C  QUELQUES TESTS SUR LES EVOLUTIONS
  59.       IF(N1.NE.1) THEN
  60.          MOTERR(1:8)='EVOLUTIO'
  61.          INTERR(1)=MEVOL1
  62.          CALL ERREUR(110)
  63.          IEV3=0
  64.          RETURN
  65.       ENDIF
  66.  
  67.       IF(N2.NE.1) THEN
  68.          MOTERR(1:8)='EVOLUTIO'
  69.          INTERR(1)=MEVOL2
  70.          CALL ERREUR(110)
  71.          IEV3=0
  72.          RETURN
  73.       ENDIF
  74.  
  75.       IF(MEVOL1.ITYEVO.NE.'REEL    '.OR.
  76.      $   MEVOL2.ITYEVO.NE.'REEL    ') THEN
  77.          MOTERR(1:8)='EVOLUTIO'
  78.          MOTERR(9:16)='REEL    '
  79.          CALL ERREUR(79)
  80.          IEV3=0
  81.          RETURN
  82.       ENDIF
  83.  
  84.       KEVOL1=MEVOL1.IEVOLL(1)
  85.       KEVOL2=MEVOL2.IEVOLL(1)
  86.       IF(KEVOL1.TYPX.NE.'LISTREEL'.OR.KEVOL1.TYPY.NE.'LISTREEL')THEN
  87.          MOTERR(1:8)='EVOLUTIO'
  88.          MOTERR(9:16)='LISTREEL'
  89.          INTERR(1)=MEVOL1
  90.          CALL ERREUR(630)
  91.          IEV3=0
  92.          RETURN
  93.       ENDIF
  94.       IF(KEVOL2.TYPX.NE.'LISTREEL'.OR.KEVOL2.TYPY.NE.'LISTREEL')THEN
  95.          MOTERR(1:8)='EVOLUTIO'
  96.          MOTERR(9:16)='LISTREEL'
  97.          INTERR(1)=MEVOL2
  98.          CALL ERREUR(630)
  99.          IEV3=0
  100.          RETURN
  101.       ENDIF
  102.       IF(KEVOL1.NOMEVX.NE.KEVOL2.NOMEVX) THEN
  103.          MOTERR(1:9)='abscisses'
  104.          MOTERR(10:17)='EVOLUTIO'
  105.          INTERR(1)=MEVOL1
  106.          INTERR(2)=MEVOL2
  107.          CALL ERREUR(631)
  108.          IEV3=0
  109.          RETURN
  110.       ENDIF
  111.       IF(KEVOL1.NOMEVY.NE.KEVOL2.NOMEVY) THEN
  112.          MOTERR(1:9)='ordonnees'
  113.          MOTERR(10:17)='EVOLUTIO'
  114.          INTERR(1)=MEVOL1
  115.          INTERR(2)=MEVOL2
  116.          CALL ERREUR(631)
  117.          IEV3=0
  118.          RETURN
  119.       ENDIF
  120.  
  121.       MLREEL=KEVOL1.IPROGX
  122.       MLREE1=KEVOL1.IPROGY
  123.       MLREE2=KEVOL2.IPROGX
  124.       MLREE3=KEVOL2.IPROGY
  125.  
  126. C     Recherche de la precision pour fusionner des ABSCISSES
  127.       JG0=MLREEL.PROG(/1)
  128.       JG2=MLREE2.PROG(/1)
  129.       XPRECR=XZPREC * 100.D0
  130.       XMIN= 1.D0/XPETIT
  131.       XMAX=-XMIN
  132.       DO III=1,JG0
  133.         XV0 =MLREEL.PROG(III)
  134.         XMIN=MIN(XMIN,XV0)
  135.         XMAX=MAX(XMAX,XV0)
  136.       ENDDO
  137.       DO III=1,JG2
  138.         XV2 =MLREE2.PROG(III)
  139.         XMIN=MIN(XMIN,XV2)
  140.         XMAX=MAX(XMAX,XV2)
  141.       ENDDO
  142.       XPREC=MAX(XPRECR*(XMAX-XMIN),XPETIT)
  143.  
  144. C  DECOMPTE pour trouver la taille des LISTREELS sans faire de SEGADJ
  145.       JGMAX=JG0+JG2
  146.       JG   =0
  147.       IJ0  =1
  148.       IJ2  =1
  149.       DO III=1,JGMAX
  150.         IF(IJ0.EQ.1)THEN
  151.           XV0 = MLREEL.PROG(1)
  152.           IF(IJ2.LE.JG2)THEN
  153.             XV2 = MLREE2.PROG(IJ2)
  154.             IF    (XV0 .GT. XV2+XPREC)THEN
  155.               LOG0=.FALSE.
  156.               XV0 = XNAN
  157.             ELSE
  158.               LOG0=.TRUE.
  159.             ENDIF
  160.           ELSE
  161.             LOG0=.TRUE.
  162.           ENDIF
  163.         ELSEIF(IJ0 .LE. JG0)THEN
  164.           XV0 = MLREEL.PROG(IJ0)
  165.           LOG0=.TRUE.
  166.         ELSE
  167.           XV0 = XNAN
  168.           LOG0=.FALSE.
  169.         ENDIF
  170.  
  171.         IF(IJ2.EQ.1)THEN
  172.           XV2 = MLREE2.PROG(1)
  173.           IF(IJ0.LE.JG0)THEN
  174.             IF(LOG0)THEN
  175.               XV0 = MLREEL.PROG(IJ0)
  176.               IF    (XV2 .GT. XV0+XPREC)THEN
  177.                 LOG2=.FALSE.
  178.                 XV2 = XNAN
  179.               ELSE
  180.                 LOG2=.TRUE.
  181.               ENDIF
  182.             ELSE
  183.               LOG2=.TRUE.
  184.             ENDIF
  185.           ELSE
  186.             LOG2=.TRUE.
  187.           ENDIF
  188.         ELSEIF(IJ2 .LE. JG2)THEN
  189.           XV2 = MLREE2.PROG(IJ2)
  190.           LOG2=.TRUE.
  191.         ELSE
  192.           XV2 = XNAN
  193.           LOG2=.FALSE.
  194.         ENDIF
  195.  
  196.         IF    (.NOT. LOG0 .AND. .NOT. LOG2)THEN
  197. C         Plus aucun points : on quitte
  198.           GOTO 101
  199.         ELSEIF(      LOG0 .AND. .NOT. LOG2)THEN
  200. C         Ajout du pt de la 1ere courbe
  201.           JG  = JG +1
  202.           IJ0 = IJ0+1
  203.         ELSEIF(.NOT. LOG0 .AND.       LOG2)THEN
  204. C         Ajout du pt de la 2eme courbe
  205.           JG  = JG +1
  206.           IJ2 = IJ2+1
  207.         ELSE
  208.           IF    (ABS(XV2-XV0) .LT. XPREC)THEN
  209. C           Pts confondus
  210.             JG  = JG +1
  211.             IJ0 = IJ0+1
  212.             IJ2 = IJ2+1
  213.           ELSEIF(XV0 .LT. XV2)THEN
  214. C           Ajout du pt de la 1ere courbe
  215.             JG  = JG +1
  216.             IJ0 = IJ0+1
  217.           ELSE
  218. C           Ajout du pt de la 2eme courbe
  219.             JG  = JG +1
  220.             IJ2 = IJ2+1
  221.           ENDIF
  222.         ENDIF
  223.  
  224.       ENDDO
  225.  101  CONTINUE
  226.  
  227. C     Creation du resultat
  228.       N=1
  229.       IF(nbesc.NE.0)CALL oooprl(1)
  230.       SEGINI,MEVOLL,KEVOLL,MREX,MREY
  231.       IF(nbesc.NE.0)CALL oooprl(0)
  232.  
  233. C     Remplissage du resultat
  234.       MEVOLL.ITYEVO   =MEVOL1.ITYEVO
  235.       MEVOLL.IEVTEX   =MEVOL1.IEVTEX
  236.       MEVOLL.IEVOLL(1)=KEVOLL
  237.       KEVOLL.IPROGX   =MREX
  238.       KEVOLL.IPROGY   =MREY
  239.       KEVOLL.NUMEVX   =KEVOL1.NUMEVX
  240.       KEVOLL.NUMEVY   =KEVOL1.NUMEVY
  241.       KEVOLL.TYPX     =KEVOL1.TYPX
  242.       KEVOLL.TYPY     =KEVOL1.TYPY
  243.       KEVOLL.NOMEVX   =KEVOL1.NOMEVX
  244.       KEVOLL.NOMEVY   =KEVOL1.NOMEVY
  245.       KEVOLL.KEVTEX   =KEVOL1.KEVTEX
  246.       IEV3=MEVOLL
  247.  
  248.       JGMAX=JG
  249.       JG   =0
  250.       IJ0  =1
  251.       IJ2  =1
  252.       DO III=1,JGMAX
  253.         IF(IJ0.EQ.1)THEN
  254.           XV0 = MLREEL.PROG(1)
  255.           YV0 = MLREE1.PROG(1)
  256.           IF(IJ2.LE.JG2)THEN
  257.             XV2 = MLREE2.PROG(IJ2)
  258.             IF    (XV0 .GT. XV2+XPREC)THEN
  259.               LOG0=.FALSE.
  260.               XV0 = XNAN
  261.             ELSE
  262.               LOG0=.TRUE.
  263.             ENDIF
  264.           ELSE
  265.             LOG0=.TRUE.
  266.           ENDIF
  267.         ELSEIF(IJ0 .LE. JG0)THEN
  268.           XV0 = MLREEL.PROG(IJ0)
  269.           YV0 = MLREE1.PROG(IJ0)
  270.           LOG0=.TRUE.
  271.         ELSE
  272.           XV0 = XNAN
  273.           YV0 = MLREE1.PROG(JG0)
  274.           LOG0=.FALSE.
  275.         ENDIF
  276.  
  277.         IF(IJ2.EQ.1)THEN
  278.           XV2 = MLREE2.PROG(1)
  279.           YV2 = MLREE3.PROG(1)
  280.           IF(IJ0.LE.JG0)THEN
  281.             IF(LOG0)THEN
  282.               XV0 = MLREEL.PROG(IJ0)
  283.               IF    (XV2 .GT. XV0+XPREC)THEN
  284.                 LOG2=.FALSE.
  285.                 XV2 = XNAN
  286.               ELSE
  287.                 LOG2=.TRUE.
  288.               ENDIF
  289.             ELSE
  290.               LOG2=.TRUE.
  291.             ENDIF
  292.           ELSE
  293.             LOG2=.TRUE.
  294.           ENDIF
  295.         ELSEIF(IJ2 .LE. JG2)THEN
  296.           XV2 = MLREE2.PROG(IJ2)
  297.           YV2 = MLREE3.PROG(IJ2)
  298.           LOG2=.TRUE.
  299.         ELSE
  300.           XV2 = XNAN
  301.           YV2 = MLREE3.PROG(JG2)
  302.           LOG2=.FALSE.
  303.         ENDIF
  304.  
  305.         IF    (.NOT. LOG0 .AND. .NOT. LOG2)THEN
  306. C         Plus aucun points : on a mal compte ??
  307.           CALL ERREUR(5)
  308.         ELSEIF(      LOG0 .AND. .NOT. LOG2)THEN
  309. C         Ajout du pt de la 1ere courbe
  310.           JG  = JG +1
  311.           MREX.PROG(JG)=XV0
  312.           MREY.PROG(JG)=XX1*YV0+XX2*YV2
  313.           IJ0 = IJ0+1
  314.         ELSEIF(.NOT. LOG0 .AND.       LOG2)THEN
  315. C         Ajout du pt de la 2eme courbe
  316.           JG  = JG +1
  317.           MREX.PROG(JG)=XV2
  318.           MREY.PROG(JG)=XX1*YV0+XX2*YV2
  319.           IJ2 = IJ2+1
  320.         ELSE
  321.           IF    (ABS(XV2-XV0) .LT. XPREC)THEN
  322. C           Pts confondus
  323.             JG  = JG +1
  324.             MREX.PROG(JG)=0.5D0*(XV0+XV2)
  325.             MREY.PROG(JG)=XX1*YV0+XX2*YV2
  326.             IJ0 = IJ0+1
  327.             IJ2 = IJ2+1
  328.           ELSEIF(XV0 .LT. XV2)THEN
  329. C           Ajout du pt de la 1ere courbe
  330.             JG  = JG +1
  331.             MREX.PROG(JG)=XV0
  332.             Xd   =MLREE2.PROG(IJ2-1)
  333.             Yd   =MLREE3.PROG(IJ2-1)
  334.             YIPOL=Yd+(YV2-Yd)*((XV0-Xd)/(XV2-Xd))
  335.             MREY.PROG(JG)=XX1*YV0+XX2*YIPOL
  336.             IJ0 = IJ0+1
  337.           ELSE
  338. C           Ajout du pt de la 2eme courbe
  339.             JG  = JG +1
  340.             MREX.PROG(JG)=XV2
  341.             Xd   =MLREEL.PROG(IJ0-1)
  342.             Yd   =MLREE1.PROG(IJ0-1)
  343.             YIPOL=Yd+(YV0-Yd)*((XV2-Xd)/(XV0-Xd))
  344.             MREY.PROG(JG)=XX1*YV0+XX2*YIPOL
  345.             MREY.PROG(JG)=XX2*YV2 + XX1*YIPOL
  346.             IJ2 = IJ2+1
  347.           ENDIF
  348.         ENDIF
  349.       ENDDO
  350.       END
  351.  
  352.  
  353.  

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