C EVOLIN SOURCE CHAT 05/01/12 23:47:22 5004 SUBROUTINE EVOLIN (IEV1,XX1,IEV2,XX2,IEV3) *____________________________________________________________________ * * Interpolation d'une courbe (type EVOLUTION) * en fouction de deux autres courbes (type EVOLUTION) * * ENTREES : * --------- * * IEV1 Pointeur sur un objet de type EVOLUTION * IEV2 Pointeur sur le deuxieme objet de type EVOLUTION * XX1 Flottant donnant le rapport entre la courbe * a calculer et la courbe designee par IEV2 * XX2 Flottant donnant le rapport entre la courbe * a calculer et la courbe designee par IEV1. * Il existe la relation (XX1 + XX2)=1 * * * SORTIE : * -------- * * IEV3 Pointeur sur l'objet EVOLUTION resultat * =0 si operation impossible * *____________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO -INC SMEVOLL -INC SMLREEL -INC SMLENTI POINTEUR MREX.MLREEL,MREY.MLREEL,MREY2.MLREEL MEVOL1=IEV1 MEVOL2=IEV2 IF(MEVOL1.EQ.0.OR.MEVOL2.EQ.0) THEN MOTERR(1:8)='EVOLUTIO' CALL ERREUR(37) IEV3=0 RETURN ENDIF C C ACTIVATION DES EVOLUTIONS C SEGACT MEVOL1,MEVOL2 N1=MEVOL1.IEVOLL(/1) N2=MEVOL2.IEVOLL(/1) C C ON TETSTE LES OBJETS EVOLUTION C IF(N1.NE.1) THEN MOTERR(1:8)='EVOLUTIO' INTERR(1)=MEVOL1 CALL ERREUR(110) SEGDES MEVOL1,MEVOL2 IEV3=0 RETURN ENDIF IF(N2.NE.1) THEN MOTERR(1:8)='EVOLUTIO' INTERR(1)=MEVOL2 CALL ERREUR(110) SEGDES MEVOL1,MEVOL2 IEV3=0 RETURN ENDIF IF(MEVOL1.ITYEVO.NE.'REEL '.OR. $ MEVOL2.ITYEVO.NE.'REEL ') THEN MOTERR(1:8)='EVOLUTIO' MOTERR(9:16)='REEL ' CALL ERREUR(79) SEGDES MEVOL1,MEVOL2 IEV3=0 RETURN ENDIF KEVOL1=MEVOL1.IEVOLL(1) KEVOL2=MEVOL2.IEVOLL(1) SEGACT KEVOL1,KEVOL2 IF(KEVOL1.TYPX.NE.'LISTREEL'.OR.KEVOL1.TYPY.NE.'LISTREEL')THEN MOTERR(1:8)='EVOLUTIO' MOTERR(9:16)='LISTREEL' INTERR(1)=MEVOL1 CALL ERREUR(630) SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 IEV3=0 RETURN ENDIF IF(KEVOL2.TYPX.NE.'LISTREEL'.OR.KEVOL2.TYPY.NE.'LISTREEL')THEN MOTERR(1:8)='EVOLUTIO' MOTERR(9:16)='LISTREEL' INTERR(1)=MEVOL2 CALL ERREUR(630) SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 IEV3=0 RETURN ENDIF IF(KEVOL1.NOMEVX.NE.KEVOL2.NOMEVX) THEN MOTERR(1:9)='abscisses' MOTERR(10:17)='EVOLUTIO' INTERR(1)=MEVOL1 INTERR(2)=MEVOL2 CALL ERREUR(631) SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 IEV3=0 RETURN ENDIF IF(KEVOL1.NOMEVY.NE.KEVOL2.NOMEVY) THEN MOTERR(1:9)='ordonnees' MOTERR(10:17)='EVOLUTIO' INTERR(1)=MEVOL1 INTERR(2)=MEVOL2 CALL ERREUR(631) SEGDES MEVOL1,MEVOL2,KEVOL1,KEVOL2 IEV3=0 RETURN ENDIF C C ON ACTIVE LES 4 LISTREEL DE DEUX COURBES C SEGDES MEVOL1,MEVOL2 MLREEL=KEVOL1.IPROGX MLREE1=KEVOL1.IPROGY MLREE2=KEVOL2.IPROGX MLREE3=KEVOL2.IPROGY SEGDES KEVOL1,KEVOL2 SEGACT MLREEL,MLREE1,MLREE2,MLREE3 JG=PROG(/1)+MLREE2.PROG(/1) C C ON DETERNIME LA VARIATION EN X DE DEUX COURBES C XMIN=1.E32 XMAX=-1.E32 DO 1 I=1,PROG(/1) IF(PROG(I).LT.XMIN) XMIN=PROG(I) IF(PROG(I).GT.XMAX) XMAX=PROG(I) 1 CONTINUE DO 2 I=1,MLREE2.PROG(/1) IF(MLREE2.PROG(I).LT.XMIN) XMIN=MLREE2.PROG(I) IF(MLREE2.PROG(I).GT.XMAX) XMAX=MLREE2.PROG(I) 2 CONTINUE C C ON CALCULE LA PRECISION C XPRE=(XMAX-XMIN)/1.D12 SEGINI MREX IJ=0 I1=1 I2=1 3 CONTINUE IF(PROG(I1).LE.MLREE2.PROG(I2)) THEN IJ=IJ+1 MREX.PROG(IJ)=PROG(I1) I1=I1+1 IF(MLREE2.PROG(I2)-XPRE.LT.MREX.PROG(IJ)) I2=I2+1 ELSE IJ=IJ+1 MREX.PROG(IJ)=MLREE2.PROG(I2) I2=I2+1 IF(PROG(I1)-XPRE.LT.MREX.PROG(IJ)) I1=I1+1 ENDIF IF(I1.LE.PROG(/1).AND.I2.LE.MLREE2.PROG(/1)) GO TO 3 IF(I1.GT.PROG(/1)) THEN IF(I2.GT.MLREE2.PROG(/1)) GOTO 6 DO 4 I=I2,MLREE2.PROG(/1) IJ=IJ+1 MREX.PROG(IJ)=MLREE2.PROG(I) 4 CONTINUE ELSE DO 5 I=I1,PROG(/1) IJ=IJ+1 MREX.PROG(IJ)=PROG(I) 5 CONTINUE ENDIF 6 CONTINUE JG=IJ SEGADJ MREX SEGINI MREY,MLENTI,MREY2 JDEB=1 DO 7 I=1,PROG(/1) DO 8 J=JDEB,MREX.PROG(/1) XX=MREX.PROG(J) IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN LECT(J)=1 MREY.PROG(J)=MLREE1.PROG(I)*XX1 JDEB=J GO TO 7 ENDIF 8 CONTINUE 7 CONTINUE DO 9 J=1,MREX.PROG(/1) IF(LECT(J).EQ.1) GO TO 10 MREY.PROG(J)=MLREE1.PROG(1)*XX1 LECT(J)=1 9 CONTINUE 10 CONTINUE DO 11 J=MREX.PROG(/1),1,-1 IF(LECT(J).EQ.1) GO TO 12 MREY.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX1 LECT(J)=1 11 CONTINUE 12 CONTINUE DO 13 J=1,MREX.PROG(/1) IF(LECT(J).EQ.1) GO TO 13 DO 14 K=J+1,MREX.PROG(/1) J1=K IF(LECT(K).EQ.1) GO TO 15 14 CONTINUE 15 CONTINUE MREY.PROG(J)=MREY.PROG(J-1)+((MREY.PROG(J1)-MREY.PROG(J-1))* $(MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1))) 13 CONTINUE DO 16 I=1,LECT(/1) LECT(I)=0 16 CONTINUE SEGDES MLREEL,MLREE1 SEGDES MLREE2,MLREE3 MLREEL=MLREE2 MLREE1=MLREE3 SEGACT MLREEL,MLREE1 JDEB=1 DO 17 I=1,PROG(/1) DO 18 J=JDEB,MREX.PROG(/1) XX=MREX.PROG(J) IF(XX.GT.PROG(I)-XPRE.AND.XX.LT.PROG(I)+XPRE) THEN LECT(J)=1 MREY2.PROG(J)=MLREE1.PROG(I)*XX2 JDEB=J GO TO 17 ENDIF 18 CONTINUE 17 CONTINUE DO 19 J=1,MREX.PROG(/1) IF(LECT(J).EQ.1) GO TO 20 MREY2.PROG(J)=MLREE1.PROG(1)*XX2 LECT(J)=1 19 CONTINUE 20 CONTINUE DO 21 J=MREX.PROG(/1),1,-1 IF(LECT(J).EQ.1) GO TO 22 MREY2.PROG(J)=MLREE1.PROG(MLREE1.PROG(/1))*XX2 LECT(J)=1 21 CONTINUE 22 CONTINUE DO 23 J=1,MREX.PROG(/1) IF(LECT(J).EQ.1) GO TO 23 DO 24 K=J+1,MREX.PROG(/1) J1=K IF(LECT(K).EQ.1) GO TO 25 24 CONTINUE 25 CONTINUE MREY2.PROG(J)=MREY2.PROG(J-1)+((MREY2.PROG(J1)-MREY2.PROG(J-1))* $ (MREX.PROG(J)-MREX.PROG(J-1))/(MREX.PROG(J1)-MREX.PROG(J-1))) 23 CONTINUE DO 26 I=1,LECT(/1) MREY.PROG(I)=MREY.PROG(I)+MREY2.PROG(I) 26 CONTINUE SEGDES MLREEL,MLREE1,MREY,MREX SEGSUP MLENTI,MREY2 SEGINI,MEVOLL=MEVOL1 SEGINI,KEVOLL=KEVOL1 IEVOLL(1)=KEVOLL NUMEVX=2 IPROGX=MREX IPROGY=MREY SEGDES MEVOLL,KEVOLL IEV3=MEVOLL RETURN END