Télécharger la plaquette Cast3M


fr en

Télécharger adevor.eso

Retour à la liste

Numérotation des lignes : 

adevor

  1. C ADEVOR    SOURCE    PV        19/02/07    21:15:00     10108          
  2.       SUBROUTINE ADEVOR(IPO1,IPO2,IRET,IPM)
  3. C
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6. C
  7. C  ===================================================================
  8. C  =  OPERATEUR :                                                    =
  9. C  =        SOMME (OU DIFFERENCE) DE DEUX OBJETS DE TYPE EVOLUTION   =
  10. C  =              - X1 ET X2 VARIENT DE FACON STRICTEMENT CROISSANTE =
  11. C  =              - Y1 ET Y2 SONT DE MEME NATURE                     =
  12. C  =  APPELE PAR ADEVOL                                              =
  13. C  =                                                                 =
  14. C  =  REECRITURE DE L'ADDITION D'OBJETS EVOLUTION DE SOUS-TYPE REELS =
  15. C  =  MODIFICATION AOUT 1997 ELOI                                    =
  16. C  =  MODIFICATION DECE 2018 CB                                      =
  17. C  ===================================================================
  18. -INC SMEVOLL
  19. -INC SMLREEL
  20.       POINTEUR MLRE1X.MLREEL,MLRE1Y.MLREEL
  21.       POINTEUR MLRE2X.MLREEL,MLRE2Y.MLREEL
  22.       POINTEUR MLREEX.MLREEL,MLREEY.MLREEL
  23.       POINTEUR MLREE4.MLREEL
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC CCREEL
  28.       SEGMENT ILIS1(NL1)
  29.       SEGMENT ILIS2(NL2)
  30.  
  31.       SEGMENT SPOI
  32.         INTEGER IPOIX(NL1,3)
  33.         INTEGER IPOIY(NL1,3)
  34. C       IPOIX : Liste des LISTREELS en ABSCISSES pour EVOL1, EVOL2 et EVOL_resultat
  35. C       IPOIY : Liste des LISTREELS en ORDONNEES pour EVOL1, EVOL2 et EVOL_resultat
  36.       ENDSEGMENT
  37. C
  38.       PARAMETER (NCR=2,NOA=3)
  39.       CHARACTER*72 TI
  40.       CHARACTER*4 COMREEL(NCR),OKADI(NOA)
  41.  
  42.       COMREEL(1)='REEL'
  43.       COMREEL(2)='HIST'
  44.       OKADI(1)  ='REEL'
  45.       OKADI(2)  ='HIST'
  46.       OKADI(3)  ='MARQ'
  47. C
  48.       IRET=0
  49. C
  50.       MEVOL1=IPO1
  51.       SEGACT MEVOL1
  52.       MEVOL2=IPO2
  53.       SEGACT MEVOL2
  54. C
  55. C ON TRAITE LE CAS DES OBJETS EVOLUTION DE SOUS-TYPE "REEL"
  56. C
  57. C   LES DIFFERENTES COURBES DOIVENT ETRE DE SOIT DE TYPE "REEL",
  58. C                                           SOIT DE TYPE "MARQ",
  59. C                                           SOIT DE TYPE "HIST"
  60. C
  61.       N1  = MEVOL1.IEVOLL(/1)
  62.       NL1 = N1
  63.       N2  = MEVOL2.IEVOLL(/1)
  64.       NL2 = N2
  65.  
  66.       SEGINI,ILIS1
  67.       SEGINI,ILIS2
  68.       NRES10=0
  69.       NRES20=0
  70.       NDIF12=0
  71. C
  72. C  ILIS1 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 1ERE EVOL
  73. C
  74.       DO I0=1,NCR
  75.         NRES1=0
  76.         DO 1 I1=1,N1
  77.           KEVOL1=MEVOL1.IEVOLL(I1)
  78.           SEGACT KEVOL1
  79.           CALL PLACE(OKADI,3,IPLAC,KEVOL1.NUMEVY)
  80.           IF (IPLAC.EQ.0) THEN
  81.             SEGSUP ILIS1
  82.             CALL ERREUR(871)
  83.             RETURN
  84.           ENDIF
  85.           IF (KEVOL1.NUMEVY.EQ.COMREEL(I0)) THEN
  86.             NRES1=NRES1+1
  87.             NRES10=NRES10+1
  88.             ILIS1(NRES10)=I1
  89.           ENDIF
  90.     1   CONTINUE
  91. C
  92. C  ILIS2 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 2ND EVOL
  93. C
  94.         NRES2=0
  95.         DO 2 I2=1,N2
  96.           KEVOL2=MEVOL2.IEVOLL(I2)
  97.           SEGACT KEVOL2
  98.           CALL PLACE(OKADI,3,IPLAC,KEVOL2.NUMEVY)
  99.           IF (IPLAC.EQ.0) THEN
  100.             SEGSUP ILIS2
  101.             CALL ERREUR(871)
  102.             RETURN
  103.           ENDIF
  104.           IF (KEVOL2.NUMEVY.EQ.COMREEL(I0)) THEN
  105.             NRES2=NRES2+1
  106.             NRES20=NRES20+1
  107.             ILIS2(NRES20)=I2
  108.           ENDIF
  109.     2   CONTINUE
  110.         IF (NRES1.NE.NRES2) THEN
  111.           NDIF12=1
  112.         ENDIF
  113.       ENDDO
  114.       NL1=NRES10
  115.       NL2=NRES20
  116.       SEGADJ,ILIS1,ILIS2
  117. C
  118. C   LES DEUX EVOLUTIONS DOIVENT AVOIR LE MEME NOMBRE DE COURBES DE TYPE
  119. C   "REEL" OU "HIST"
  120. C
  121.       IF (NDIF12.NE.0) THEN
  122. C        SEGDES MEVOL1,MEVOL2
  123.         SEGSUP ILIS1,ILIS2
  124.         IF (NRES10.EQ.NRES20) THEN
  125.           CALL ERREUR(871)
  126.         ELSE
  127.           CALL ERREUR(870)
  128.         ENDIF
  129.         RETURN
  130.       ENDIF
  131.  
  132.       N=NL1
  133.       SEGINI,SPOI,MEVOLL
  134.       MEVOLL.ITYEVO=MEVOL1.ITYEVO
  135.       MEVOLL.IEVTEX=TITREE
  136. C
  137. C   LES ABSCISSES DES COURBES ELIGIBLES DOIVENT ETRE DES PROGRESSIONS STRICTEMENT CROISSANTES
  138. C
  139.       DO 3 IL1=1,NL1
  140.         KEVOL1=MEVOL1.IEVOLL(ILIS1(IL1))
  141.         KEVOL2=MEVOL2.IEVOLL(ILIS2(IL1))
  142.         SEGINI,KEVOLL=KEVOL1
  143.         MEVOLL.IEVOLL(IL1)=KEVOLL
  144.         MLREE1=KEVOL1.IPROGX
  145.         MLREE2=KEVOL2.IPROGX
  146.         MLREE3=KEVOL1.IPROGY
  147.         MLREE4=KEVOL2.IPROGY
  148.         SEGACT,MLREE1,MLREE2,MLREE3,MLREE4
  149.         SPOI.IPOIX(IL1,1)=MLREE1
  150.         SPOI.IPOIX(IL1,2)=MLREE2
  151.         SPOI.IPOIY(IL1,1)=KEVOL1.IPROGY
  152.         SPOI.IPOIY(IL1,2)=KEVOL2.IPROGY
  153.  
  154. C       Test EVOLUTION N°1
  155.         NJG1  =MLREE1.PROG(/1)
  156.         IF (NJG1.GT.1) THEN
  157.           VAL1=MLREE1.PROG(1)
  158.           DO 41 IJG=2,NJG1
  159.             VAL2=MLREE1.PROG(IJG)
  160.             IF (VAL2.LE.VAL1) THEN
  161.               SEGSUP,SPOI
  162.               CALL ERREUR(872)
  163.               RETURN
  164.             ENDIF
  165.             VAL1=VAL2
  166.    41     CONTINUE
  167.         ENDIF
  168.  
  169. C       Test EVOLUTION N°2
  170.         NJG2  =MLREE2.PROG(/1)
  171.         IF(MLREE2 .EQ. MLREE1) THEN
  172. C          PRINT *,'ADEVOR:POINTEURS IDENTIQUES',IL1,MLREE1,MLREE2
  173.           SPOI.IPOIX(IL1,3)=MLREE1
  174.  
  175.         ELSE
  176. C          PRINT *,'ADEVOR:POINTEURS DIFFERENTS',IL1,MLREE1,MLREE2
  177.           IF (NJG2.GT.1) THEN
  178.             VAL1=MLREE2.PROG(1)
  179.             DO 42 IJG=2,NJG2
  180.               VAL2=MLREE2.PROG(IJG)
  181.               IF (VAL2.LE.VAL1) THEN
  182.                 SEGSUP,SPOI
  183.                 CALL ERREUR(872)
  184.                 RETURN
  185.               ENDIF
  186.               VAL1=VAL2
  187.    42       CONTINUE
  188.           ENDIF
  189.  
  190.           IF(NJG1 .NE. NJG2)THEN
  191. C            PRINT *,'-ADEVOR:TAILLE DIFFERENTS',NJG1,NJG2
  192.             GOTO 410
  193.  
  194.           ELSE
  195. C            PRINT *,'-ADEVOR:TAILLE IDENTIQUE',NJG1,NJG2
  196. C           Meme taille ==> Est-ce les memes valeurs a XSZPRE pres ?
  197. C           Critère volontairement laxiste
  198.             DO II=1,NJG1
  199.               VAL1 = ABS(MLREE2.PROG(II) - MLREE1.PROG(II))
  200.               VAL2 = MAX(ABS(MLREE2.PROG(II))*XSZPRE,
  201.      &                   ABS(MLREE1.PROG(II))*XSZPRE )
  202. C             PRINT *,'--ADEVOR:',II,MLREE1.PROG(II),MLREE2.PROG(II),VAL1
  203.               IF(VAL1 .GT. VAL2) GOTO 410
  204.             ENDDO
  205. C            PRINT *,'-ADEVOR:FINALEMENT MEME VALEURS'
  206.             SPOI.IPOIX(IL1,3)=MLREE1
  207.             GOTO 411
  208.           ENDIF
  209.  
  210.  410      CONTINUE
  211. C          PRINT *,'-ADEVOR:CONSTRUCTION NOUVEAU LISTREEL ABSCISSES'
  212.           JG=NJG1+NJG2
  213.           SEGINI,MLREE3
  214.           SPOI.IPOIX(IL1,3)=MLREE3
  215.  
  216. C         Construction nouveau LISTREEL ABSCISSES
  217.           II1    = 0
  218.           II2    = 0
  219.           ICOUNT = 0
  220.           DO II=1,JG
  221.             IF    ( II1.EQ.NJG1 .AND. II2.EQ.NJG2)THEN
  222.               GOTO 413
  223.  
  224.             ELSEIF( II1.EQ.NJG1 )THEN
  225.               II2  = II2 + 1
  226.               ICOUNT   = ICOUNT  + 1
  227.               MLREE3.PROG(ICOUNT)=MLREE2.PROG(II2)
  228.  
  229.             ELSEIF( II2.EQ.NJG2 )THEN
  230.               II1  = II1 + 1
  231.               ICOUNT   = ICOUNT  + 1
  232.               MLREE3.PROG(ICOUNT)=MLREE1.PROG(II1)
  233.  
  234.             ELSEIF(MLREE1.PROG(II1+1) .LT. MLREE2.PROG(II2+1))THEN
  235.               II1  = II1 + 1
  236.               ICOUNT   = ICOUNT  + 1
  237.               MLREE3.PROG(ICOUNT)=MLREE1.PROG(II1)
  238.             ELSE
  239.               II2  = II2 + 1
  240.               ICOUNT   = ICOUNT  + 1
  241.               MLREE3.PROG(ICOUNT)=MLREE2.PROG(II2)
  242.             ENDIF
  243.           ENDDO
  244.  
  245.  413      CONTINUE
  246.  
  247. C         Retrait des DOUBLONS
  248.           IDEC   = 0
  249.           VAL1   = MLREE3.PROG(1)
  250.           DO II=2,JG
  251.             VAL2=MLREE3.PROG(II)
  252.             IF    (VAL2 .EQ. VAL1)THEN
  253.               IDEC = IDEC + 1
  254.  
  255.             ELSEIF(ABS(VAL2-VAL1) .LE.
  256.      &             MAX(ABS(VAL2*XSZPRE),ABS(VAL1*XSZPRE)))THEN
  257.               IDEC = IDEC + 1
  258.  
  259.             ELSE
  260.               MLREE3.PROG(II - IDEC)=VAL2
  261.               VAL1 = VAL2
  262.             ENDIF
  263.           ENDDO
  264.           IF (IDEC .GT. 0) THEN
  265.             JG = JG - IDEC
  266.             SEGADJ,MLREE3
  267.           ENDIF
  268.           SEGACT,MLREE3*NOMOD
  269.  
  270. C         Interpolation des ORDONNEES aux nouvelles ABSCISSES MLREE3
  271.           MLREEL = SPOI.IPOIX(IL1,1)
  272.           MLREE1 = SPOI.IPOIY(IL1,1)
  273.           SEGINI,MLREE2
  274.           SPOI.IPOIY(IL1,1)=MLREE2
  275.           XMIN=MLREEL.PROG(1)
  276.           XMAX=MLREEL.PROG(MLREEL.PROG(/1))
  277.           DO II=1,JG
  278.             XABSCI=MLREE3.PROG(II)
  279.             IF(XABSCI.LT.XMIN .OR. XABSCI.GT.XMAX)THEN
  280.               MLREE2.PROG(II)=0.D0
  281.             ELSE
  282. C             interpolation
  283.               CALL INTER5(XABSCI,MLREEL,MLREE1,FT0,0,0,1,IRET)
  284.               IF(IRET .EQ. 0)THEN
  285.                 CALL ERREUR(21)
  286.                 RETURN
  287.               ENDIF
  288.               MLREE2.PROG(II)=FT0
  289.             ENDIF
  290.           ENDDO
  291.           SEGACT,MLREE2*NOMOD
  292.  
  293.           MLREEL = SPOI.IPOIX(IL1,2)
  294.           MLREE1 = SPOI.IPOIY(IL1,2)
  295.           SEGINI,MLREE4
  296.           SPOI.IPOIY(IL1,2)=MLREE4
  297.           XMIN=MLREEL.PROG(1)
  298.           XMAX=MLREEL.PROG(MLREEL.PROG(/1))
  299.           DO II=1,JG
  300.             XABSCI=MLREE3.PROG(II)
  301.             IF(XABSCI.LT.XMIN .OR. XABSCI.GT.XMAX)THEN
  302.               MLREE4.PROG(II)=0.D0
  303.             ELSE
  304. C             interpolation
  305.               CALL INTER5(XABSCI,MLREEL,MLREE1,FT0,0,0,1,IRET)
  306.               IF(IRET .EQ. 0)THEN
  307.                 CALL ERREUR(21)
  308.                 RETURN
  309.               ENDIF
  310.               MLREE4.PROG(II)=FT0
  311.             ENDIF
  312.           ENDDO
  313.           SEGACT,MLREE4*NOMOD
  314.         ENDIF
  315.  
  316.  411    CONTINUE
  317. C       ICI on va realiser l'ADDITION ou la SOUSTRACTION des ORDONNEES
  318.         MLREEL=SPOI.IPOIX(IL1,3)
  319.         MLREE1=SPOI.IPOIY(IL1,1)
  320.         MLREE2=SPOI.IPOIY(IL1,2)
  321.         JG=MLREEL.PROG(/1)
  322.         SEGINI,MLREE3
  323.         SPOI.IPOIY(IL1,3)=MLREE3
  324.         IF     (IPM.EQ. 1) THEN
  325.           DO II=1,JG
  326.             MLREE3.PROG(II) = MLREE1.PROG(II) + MLREE2.PROG(II)
  327.           ENDDO
  328.         ELSEIF (IPM.EQ.-1) THEN
  329.           DO II=1,JG
  330.             MLREE3.PROG(II) = MLREE1.PROG(II) - MLREE2.PROG(II)
  331.           ENDDO
  332.         ELSE
  333.           CALL ERREUR(21)
  334.           RETURN
  335.         ENDIF
  336.         SEGACT,MLREE3*NOMOD
  337.  
  338. C        DO II=1,JG
  339. C          X1=MLREEL.PROG(II)
  340. C          Y1=MLREE1.PROG(II)
  341. C          Y2=MLREE2.PROG(II)
  342. C          Y3=MLREE3.PROG(II)
  343. C          PRINT *,'ADEVOR:',II,X1,Y1,Y2,Y3
  344. C        ENDDO
  345.  3    CONTINUE
  346.  
  347.  
  348. C     Reconstitution de l'EVOLUTION solution
  349.       DO II=1,N
  350.         KEVOLL=MEVOLL.IEVOLL(II)
  351.         KEVOLL.IPROGX=SPOI.IPOIX(II,3)
  352.         KEVOLL.IPROGY=SPOI.IPOIY(II,3)
  353.         SEGACT,KEVOLL*NOMOD
  354.       ENDDO
  355.       SEGACT,MEVOLL*NOMOD
  356.       IRET=MEVOLL
  357.  
  358.       END
  359.  
  360.  
  361.  
  362.  

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