C ADEVO SOURCE CHAT 05/01/12 21:17:58 5004 SUBROUTINE ADEVO(IPEV1,IPEV2,IRET,INV) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C C======================================================================= C = = C = APPELE PAR ADEVOL = C = = C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LA SOMME OU LA = C = DIFFERENCE TERME A TERME DE DEUX OBJETS EVOLUTION = C = DE MEMES ABSCISSES = C = = C = SYNTAXE : PROD = EVOLF + EVOLV = C = = C = ON EXECUTE LA SOMME TERME A TERME DES ORDONNEES DES DEUX = C = OBJETS DE TYPE EVOLUTIO EVOLF ET EVOLV. LES ABSCISSES DE PROD, = C = L'OBJET AINSI CREE, RESTENT CELLES DE EVOLF ET EVOLV. = C = = C = = C = = C = MEVOL1 : POINTEUR SUR MEVOLF (OBJET EVOLUTION) = C = MEVOL2 : POINTEUR SUR MEVOLV " " = C = KEVOL1 : POINTEUR SUR KEVOLF = C = KEVOL2 : POINTEUR SUR KEVOLV = C = MLREE1 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLF = C = MLREE2 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLV = C = = C = CREATION : 4/12/87 = C = F.ROULLIER = C======================================================================= C -INC CCOPTIO -INC SMEVOLL -INC SMLREEL C SEGMENT TEMPP IMPLIED DR1(NPT),DI1(NPT),DM1(NPT),DP1(NPT) IMPLIED DR2(NPT),DI2(NPT),DM2(NPT),DP2(NPT) ENDSEGMENT CHARACTER *72 TI CHARACTER*4 ITYP1,ITYP2 C C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE MEME SOUS-TYPE C ET DE MEME LONGUEUR C MEVOL1=IPEV1 MEVOL2=IPEV2 SEGACT MEVOL1,MEVOL2 ITYP1=MEVOL1.ITYEVO ITYP2=MEVOL2.ITYEVO ICMP=1 IF (ITYP1.EQ.'COMP'.AND.ITYP2.EQ.'COMP') GO TO 198 IF (ITYP1.EQ.'REEL'.AND.ITYP2.EQ.'REEL') GO TO 199 197 MOTERR(1:8)='EVOLUTIO' CALL ERREUR(302) RETURN 198 ICMP=2 199 CONTINUE C C BOUCLE SUR LES COURBES C NC1=MEVOL1.IEVOLL(/1) NC2=MEVOL2.IEVOLL(/1) IF(NC1.EQ.NC2) GOTO 200 CALL ERREUR(111) RETURN C 200 CONTINUE N=NC1 NC=NC1/ICMP SEGINI MEVOLL IRET=MEVOLL TI=TITREE IEVTEX=TI ITYEVO=MEVOL1.ITYEVO C C DO 201 IC=1,NC,ICMP KEVOL1=MEVOL1.IEVOLL(IC) KEVOL2=MEVOL2.IEVOLL(IC) SEGACT KEVOL1,KEVOL2 ITYP1=KEVOL1.NUMEVY ITYP2=KEVOL2.NUMEVY MLREE1=KEVOL1.IPROGX MLREE2=KEVOL2.IPROGX SEGACT MLREE1,MLREE2 L2=MLREE2.PROG(/1) L1=MLREE1.PROG(/1) C C LES LISTREEL ONT-ILS MEME LONGUEUR ? IF(L1.EQ.L2)GOTO 10 CALL ERREUR(337) GOTO 100 10 CONTINUE C C LES LISTREEL DES ABSCISSES SONT ILS IDENTIQUES ? CALL VERIPR(MLREE1.PROG,MLREE2.PROG,L1,IRETOU,1.D-2) IF(IRETOU.EQ.0) THEN CALL ERREUR(394) RETURN ENDIF C SEGINI KEVOLL IEVOLL(IC)=KEVOLL KEVTEX=TI NOMEVX=KEVOL1.NOMEVX NOMEVY=KEVOL1.NOMEVY NUMEVX=KEVOL1.NUMEVX NUMEVY=KEVOL1.NUMEVY TYPX=KEVOL1.TYPX TYPY=KEVOL1.TYPY JG=L1 SEGINI MLREEL IPROGX=MLREEL DO 31 I=1,L1 PROG(I)=MLREE1.PROG(I) 31 CONTINUE SEGDES MLREEL,KEVOLL,MLREE1,MLREE2 C MLREE1=KEVOL1.IPROGY MLREE2=KEVOL2.IPROGY SEGACT MLREE1,MLREE2 C NPT=L1 SEGINI TEMPP IMOD1=0 IMOD2=0 IF (ITYP1.EQ.'MODU') THEN IMOD1=1 DO 180 I=1,L1 DM1(I)=MLREE1.PROG(I) 180 CONTINUE ELSE DO 181 I=1,L1 DR1(I)=MLREE1.PROG(I) 181 CONTINUE ENDIF C IF (ITYP2.EQ.'MODU') THEN IMOD2=1 DO 182 I=1,L1 DM2(I)=MLREE2.PROG(I) 182 CONTINUE ELSE DO 183 I=1,L1 DR2(I)=MLREE2.PROG(I) 183 CONTINUE ENDIF SEGDES MLREE1,MLREE2 SEGDES KEVOL1,KEVOL2 C IF (ICMP.EQ.1) GO TO 170 C KEVOL1=MEVOL1.IEVOLL(IC+1) KEVOL2=MEVOL2.IEVOLL(IC+1) SEGACT KEVOL1,KEVOL2 MLREE1=KEVOL1.IPROGX SEGACT MLREE1 L1=MLREE1.PROG(/1) C SEGINI KEVOLL IEVOLL(IC+1)=KEVOLL KEVTEX=TI NOMEVX=KEVOL1.NOMEVX NOMEVY=KEVOL1.NOMEVY NUMEVX=KEVOL1.NUMEVX NUMEVY=KEVOL1.NUMEVY TYPX=KEVOL1.TYPX TYPY=KEVOL1.TYPY C JG=L1 SEGINI MLREEL IPROGX=MLREEL DO 35 I=1,L1 PROG(I)=MLREE1.PROG(I) 35 CONTINUE SEGDES MLREEL,KEVOLL,MLREE1 C MLREE1=KEVOL1.IPROGY MLREE2=KEVOL2.IPROGY SEGACT MLREE1,MLREE2 C IF (IMOD1.EQ.1) THEN DO 190 I=1,L1 DP1(I)=MLREE1.PROG(I) 190 CONTINUE ELSE DO 191 I=1,L1 DI1(I)=MLREE1.PROG(I) 191 CONTINUE ENDIF IF (IMOD2.EQ.1) THEN DO 192 I=1,L1 DP2(I)=MLREE2.PROG(I) 192 CONTINUE ELSE DO 193 I=1,L1 DI2(I)=MLREE2.PROG(I) 193 CONTINUE ENDIF SEGDES MLREE1,MLREE2 SEGDES KEVOL1,KEVOL2 C IF (IMOD1.EQ.1) THEN CALL CONVCP(DR1,DI1,DM1,DP1,L1,-1) ENDIF C IF (IMOD2.EQ.1) THEN CALL CONVCP(DR2,DI2,DM2,DP2,L2,-1) ENDIF C 17 IF(INV.EQ.1) THEN DO 20 I=1,L1 DR1(I)=DR1(I)+DR2(I) DI1(I)=DI1(I)+DI2(I) 20 CONTINUE ELSE DO 21 I=1,L1 DR1(I)=DR1(I)-DR2(I) DI1(I)=DI1(I)-DI2(I) 21 CONTINUE ENDIF C KEVOL1=IEVOLL(IC) KEVOL2=IEVOLL(IC+1) SEGACT KEVOL1*MOD,KEVOL2*MOD JG=L1 SEGINI MLREE1,MLREE2 KEVOL1.IPROGY=MLREE1 KEVOL2.IPROGY=MLREE2 C IF (IMOD1.EQ.1) THEN CALL CONVCP(DR1,DI1,DM1,DP1,L1,1) DO 22 I=1,L1 MLREE1.PROG(I)=DM1(I) MLREE2.PROG(I)=DP1(I) 22 CONTINUE ELSE DO 23 I=1,L1 MLREE1.PROG(I)=DR1(I) MLREE2.PROG(I)=DI1(I) 23 CONTINUE ENDIF C SEGDES MLREE1,MLREE2,KEVOL1,KEVOL2 GO TO 196 C 170 CONTINUE IF(INV.EQ.1) THEN DO 171 I=1,L1 DR1(I)=DR1(I)+DR2(I) 171 CONTINUE ELSE DO 172 I=1,L1 DR1(I)=DR1(I)-DR2(I) 172 CONTINUE ENDIF C KEVOL1=IEVOLL(IC) SEGACT KEVOL1 JG=L1 SEGINI MLREE1 KEVOL1.IPROGY=MLREE1 C IF (IMOD1.EQ.1) THEN CALL CONVCP(DR1,DI1,DM1,DP1,L1,1) DO 173 I=1,L1 MLREE1.PROG(I)=DM1(I) 173 CONTINUE ELSE DO 174 I=1,L1 MLREE1.PROG(I)=DR1(I) 174 CONTINUE ENDIF C SEGDES MLREE1,KEVOL1 C 196 SEGSUP TEMPP 201 CONTINUE C SEGDES MEVOLL,MEVOL1,MEVOL2 C 100 CONTINUE RETURN END