C ADEVOR SOURCE OF166741 25/02/20 21:15:08 12165 SUBROUTINE ADEVOR(IPO1,IPO2,IRET,IPM) C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C C =================================================================== C = OPERATEUR : = C = SOMME (OU DIFFERENCE) DE DEUX OBJETS DE TYPE EVOLUTION = C = - X1 ET X2 VARIENT DE FACON STRICTEMENT CROISSANTE = C = - Y1 ET Y2 SONT DE MEME NATURE = C = APPELE PAR ADEVOL = C = = C = REECRITURE DE L'ADDITION D'OBJETS EVOLUTION DE SOUS-TYPE REELS = C = MODIFICATION AOUT 1997 ELOI = C = MODIFICATION DECE 2018 CB = C =================================================================== -INC SMEVOLL -INC SMLREEL POINTEUR MLRE1X.MLREEL,MLRE1Y.MLREEL POINTEUR MLRE2X.MLREEL,MLRE2Y.MLREEL POINTEUR MLREEX.MLREEL,MLREEY.MLREEL POINTEUR MLREE4.MLREEL -INC PPARAM -INC CCOPTIO -INC CCREEL SEGMENT ILIS1(NL1) SEGMENT ILIS2(NL2) SEGMENT SPOI INTEGER IPOIX(NL1,3) INTEGER IPOIY(NL1,3) C IPOIX : Liste des LISTREELS en ABSCISSES pour EVOL1, EVOL2 et EVOL_resultat C IPOIY : Liste des LISTREELS en ORDONNEES pour EVOL1, EVOL2 et EVOL_resultat ENDSEGMENT C PARAMETER (NCR=2,NOA=3) CHARACTER*72 TI CHARACTER*4 COMREEL(NCR),OKADI(NOA) COMREEL(1)='REEL' COMREEL(2)='HIST' OKADI(1) ='REEL' OKADI(2) ='HIST' OKADI(3) ='MARQ' C IRET=0 C MEVOL1=IPO1 SEGACT MEVOL1 MEVOL2=IPO2 SEGACT MEVOL2 C C ON TRAITE LE CAS DES OBJETS EVOLUTION DE SOUS-TYPE "REEL" C C LES DIFFERENTES COURBES DOIVENT ETRE DE SOIT DE TYPE "REEL", C SOIT DE TYPE "MARQ", C SOIT DE TYPE "HIST" C N1 = MEVOL1.IEVOLL(/1) NL1 = N1 N2 = MEVOL2.IEVOLL(/1) NL2 = N2 SEGINI,ILIS1 SEGINI,ILIS2 NRES10=0 NRES20=0 NDIF12=0 C C ILIS1 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 1ERE EVOL C DO I0=1,NCR NRES1=0 DO 1 I1=1,N1 KEVOL1=MEVOL1.IEVOLL(I1) SEGACT KEVOL1 CALL PLACE(OKADI,3,IPLAC,KEVOL1.NUMEVY) IF (IPLAC.EQ.0) THEN SEGSUP ILIS1 CALL ERREUR(871) RETURN ENDIF IF (KEVOL1.NUMEVY.EQ.COMREEL(I0)) THEN NRES1=NRES1+1 NRES10=NRES10+1 ILIS1(NRES10)=I1 ENDIF 1 CONTINUE C C ILIS2 : INDICES DES COURBES DE TYPE "REEL" OU "HIST" DE LA 2ND EVOL C NRES2=0 DO 2 I2=1,N2 KEVOL2=MEVOL2.IEVOLL(I2) SEGACT KEVOL2 CALL PLACE(OKADI,3,IPLAC,KEVOL2.NUMEVY) IF (IPLAC.EQ.0) THEN SEGSUP ILIS2 CALL ERREUR(871) RETURN ENDIF IF (KEVOL2.NUMEVY.EQ.COMREEL(I0)) THEN NRES2=NRES2+1 NRES20=NRES20+1 ILIS2(NRES20)=I2 ENDIF 2 CONTINUE IF (NRES1.NE.NRES2) THEN NDIF12=1 ENDIF ENDDO NL1=NRES10 NL2=NRES20 SEGADJ,ILIS1,ILIS2 C C LES DEUX EVOLUTIONS DOIVENT AVOIR LE MEME NOMBRE DE COURBES DE TYPE C "REEL" OU "HIST" C IF (NDIF12.NE.0) THEN C SEGDES MEVOL1,MEVOL2 SEGSUP ILIS1,ILIS2 IF (NRES10.EQ.NRES20) THEN CALL ERREUR(871) ELSE CALL ERREUR(870) ENDIF RETURN ENDIF N=NL1 SEGINI,SPOI,MEVOLL MEVOLL.ITYEVO=MEVOL1.ITYEVO MEVOLL.IEVTEX=TITREE C C LES ABSCISSES DES COURBES ELIGIBLES DOIVENT ETRE DES PROGRESSIONS STRICTEMENT CROISSANTES C DO 3 IL1=1,NL1 KEVOL1=MEVOL1.IEVOLL(ILIS1(IL1)) KEVOL2=MEVOL2.IEVOLL(ILIS2(IL1)) SEGINI,KEVOLL=KEVOL1 MEVOLL.IEVOLL(IL1)=KEVOLL MLREE1=KEVOL1.IPROGX MLREE2=KEVOL2.IPROGX MLREE3=KEVOL1.IPROGY MLREE4=KEVOL2.IPROGY SEGACT,MLREE1,MLREE2,MLREE3,MLREE4 SPOI.IPOIX(IL1,1)=MLREE1 SPOI.IPOIX(IL1,2)=MLREE2 SPOI.IPOIY(IL1,1)=KEVOL1.IPROGY SPOI.IPOIY(IL1,2)=KEVOL2.IPROGY C Test EVOLUTION N°1 NJG1 =MLREE1.PROG(/1) IF (NJG1.GT.1) THEN VAL1=MLREE1.PROG(1) DO 41 IJG=2,NJG1 VAL2=MLREE1.PROG(IJG) IF (VAL2.LE.VAL1) THEN SEGSUP,SPOI CALL ERREUR(872) RETURN ENDIF VAL1=VAL2 41 CONTINUE ENDIF C Test EVOLUTION N°2 NJG2 =MLREE2.PROG(/1) IF(MLREE2 .EQ. MLREE1) THEN C PRINT *,'ADEVOR:POINTEURS IDENTIQUES',IL1,MLREE1,MLREE2 SPOI.IPOIX(IL1,3)=MLREE1 ELSE C PRINT *,'ADEVOR:POINTEURS DIFFERENTS',IL1,MLREE1,MLREE2 IF (NJG2.GT.1) THEN VAL1=MLREE2.PROG(1) DO 42 IJG=2,NJG2 VAL2=MLREE2.PROG(IJG) IF (VAL2.LE.VAL1) THEN SEGSUP,SPOI CALL ERREUR(872) RETURN ENDIF VAL1=VAL2 42 CONTINUE ENDIF IF(NJG1 .NE. NJG2)THEN C PRINT *,'-ADEVOR:TAILLE DIFFERENTS',NJG1,NJG2 GOTO 410 ELSE C PRINT *,'-ADEVOR:TAILLE IDENTIQUE',NJG1,NJG2 C Meme taille ==> Est-ce les memes valeurs a XSZPRE pres ? C Critère volontairement laxiste DO II=1,NJG1 VAL1 = ABS(MLREE2.PROG(II) - MLREE1.PROG(II)) VAL2 = MAX(ABS(MLREE2.PROG(II))*XSZPRE, & ABS(MLREE1.PROG(II))*XSZPRE ) C PRINT *,'--ADEVOR:',II,MLREE1.PROG(II),MLREE2.PROG(II),VAL1 IF(VAL1 .GT. VAL2) GOTO 410 ENDDO C PRINT *,'-ADEVOR:FINALEMENT MEME VALEURS' SPOI.IPOIX(IL1,3)=MLREE1 GOTO 411 ENDIF 410 CONTINUE C PRINT *,'-ADEVOR:CONSTRUCTION NOUVEAU LISTREEL ABSCISSES' JG=NJG1+NJG2 SEGINI,MLREE3 SPOI.IPOIX(IL1,3)=MLREE3 C Construction nouveau LISTREEL ABSCISSES II1 = 0 II2 = 0 ICOUNT = 0 DO II=1,JG IF ( II1.EQ.NJG1 .AND. II2.EQ.NJG2)THEN GOTO 413 ELSEIF( II1.EQ.NJG1 )THEN II2 = II2 + 1 ICOUNT = ICOUNT + 1 MLREE3.PROG(ICOUNT)=MLREE2.PROG(II2) ELSEIF( II2.EQ.NJG2 )THEN II1 = II1 + 1 ICOUNT = ICOUNT + 1 MLREE3.PROG(ICOUNT)=MLREE1.PROG(II1) ELSEIF(MLREE1.PROG(II1+1) .LT. MLREE2.PROG(II2+1))THEN II1 = II1 + 1 ICOUNT = ICOUNT + 1 MLREE3.PROG(ICOUNT)=MLREE1.PROG(II1) ELSE II2 = II2 + 1 ICOUNT = ICOUNT + 1 MLREE3.PROG(ICOUNT)=MLREE2.PROG(II2) ENDIF ENDDO 413 CONTINUE C Retrait des DOUBLONS IDEC = 0 VAL1 = MLREE3.PROG(1) DO II=2,JG VAL2=MLREE3.PROG(II) IF (VAL2 .EQ. VAL1)THEN IDEC = IDEC + 1 ELSEIF(ABS(VAL2-VAL1) .LE. & MAX(ABS(VAL2*XSZPRE),ABS(VAL1*XSZPRE)))THEN IDEC = IDEC + 1 ELSE MLREE3.PROG(II - IDEC)=VAL2 VAL1 = VAL2 ENDIF ENDDO IF (IDEC .GT. 0) THEN JG = JG - IDEC SEGADJ,MLREE3 ENDIF SEGACT,MLREE3*NOMOD C Interpolation des ORDONNEES aux nouvelles ABSCISSES MLREE3 MLREEL = SPOI.IPOIX(IL1,1) MLREE1 = SPOI.IPOIY(IL1,1) SEGINI,MLREE2 SPOI.IPOIY(IL1,1)=MLREE2 XMIN=MLREEL.PROG(1) XMAX=MLREEL.PROG(MLREEL.PROG(/1)) DO II=1,JG XABSCI=MLREE3.PROG(II) IF(XABSCI.LT.XMIN .OR. XABSCI.GT.XMAX)THEN MLREE2.PROG(II)=0.D0 ELSE C interpolation CALL INTER5(XABSCI,MLREEL,MLREE1,FT0,0,0,1,IRET) IF(IRET .EQ. 0)THEN CALL ERREUR(21) RETURN ENDIF MLREE2.PROG(II)=FT0 ENDIF ENDDO SEGACT,MLREE2*NOMOD MLREEL = SPOI.IPOIX(IL1,2) MLREE1 = SPOI.IPOIY(IL1,2) SEGINI,MLREE4 SPOI.IPOIY(IL1,2)=MLREE4 XMIN=MLREEL.PROG(1) XMAX=MLREEL.PROG(MLREEL.PROG(/1)) DO II=1,JG XABSCI=MLREE3.PROG(II) IF(XABSCI.LT.XMIN .OR. XABSCI.GT.XMAX)THEN MLREE4.PROG(II)=0.D0 ELSE C interpolation CALL INTER5(XABSCI,MLREEL,MLREE1,FT0,0,0,1,IRET) IF(IRET .EQ. 0)THEN CALL ERREUR(21) RETURN ENDIF MLREE4.PROG(II)=FT0 ENDIF ENDDO SEGACT,MLREE4*NOMOD ENDIF 411 CONTINUE C ICI on va realiser l'ADDITION ou la SOUSTRACTION des ORDONNEES MLREEL=SPOI.IPOIX(IL1,3) MLREE1=SPOI.IPOIY(IL1,1) MLREE2=SPOI.IPOIY(IL1,2) JG=MLREEL.PROG(/1) SEGINI,MLREE3 SPOI.IPOIY(IL1,3)=MLREE3 IF (IPM.EQ. 1) THEN DO II=1,JG MLREE3.PROG(II) = MLREE1.PROG(II) + MLREE2.PROG(II) ENDDO ELSEIF (IPM.EQ.-1) THEN DO II=1,JG MLREE3.PROG(II) = MLREE1.PROG(II) - MLREE2.PROG(II) ENDDO ELSE CALL ERREUR(21) RETURN ENDIF SEGACT,MLREE3*NOMOD C DO II=1,JG C X1=MLREEL.PROG(II) C Y1=MLREE1.PROG(II) C Y2=MLREE2.PROG(II) C Y3=MLREE3.PROG(II) C PRINT *,'ADEVOR:',II,X1,Y1,Y2,Y3 C ENDDO 3 CONTINUE C Reconstitution de l'EVOLUTION solution DO II=1,N KEVOLL=MEVOLL.IEVOLL(II) KEVOLL.IPROGX=SPOI.IPOIX(II,3) KEVOLL.IPROGY=SPOI.IPOIY(II,3) SEGACT,KEVOLL*NOMOD ENDDO SEGACT,MEVOLL*NOMOD IRET=MEVOLL END