C PUISCP SOURCE OF166741 25/02/20 21:17:30 12165 SUBROUTINE PUISCP(IPEV1,IPEV2,IRET,INV,ICOUL) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C C======================================================================= C = = C = APPELE PAR PUIS = C = = C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LE PRODUIT OU LE = C = RAPPORT TERME A TERME DE DEUX OBJETS EVOLUTION DE SOUS-TYPE = C = COMPLEXE = C = = C = SYNTAXE : PROD = EVOLF * EVOLV (COUL) = C = = C = ON EXECUTE LE PRODUIT TERME A TERME DES ORDONNEES DES DEUX = C = OBJETS EVOLUTION DE SOUS-TYPE COMPLEXE EVOLF ET EVOLV. = C = LES ABSCISSES DE PROD, L'OBJET AINSI CREE, SONT CELLES = C = DE EVOLF ET EVOLV. = C = = C = = C = CREATION : 4/12/87 = C = F.ROULLIER = C = = C======================================================================= C -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL SEGMENT TEMPP IMPLIED DR(NPT),DI(NPT),DM(NPT),DP(NPT) IMPLIED AA(NPT),AB(NPT),BA(NPT),BB(NPT),DENOM(NPT) ENDSEGMENT C CHARACTER*72 TI CHARACTER*4 ITYP1,ITYP2 C C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE SOUS-TYPE COMPLEXE C MEVOL1=IPEV1 MEVOL2=IPEV2 SEGACT MEVOL1,MEVOL2 ITYP1=MEVOL1.ITYEVO ITYP2=MEVOL1.ITYEVO IF (ITYP1.EQ.'COMP') GO TO 198 197 MOTERR(1:8)='EVOLUTIO' CALL ERREUR(302) SEGDES MEVOL1,MEVOL2 RETURN C C BOUCLE SUR LES COURBES C 198 NC1=MEVOL1.IEVOLL(/1) NC2=MEVOL2.IEVOLL(/1) IF(NC1.NE.NC2) THEN CALL ERREUR(111) RETURN ENDIF NC=NC1 C C CREATION DE L'OBJET PRODUIT DE TYPE EVOLUTION (COMPLEXE) C N=NC1 SEGINI MEVOLL IRET=MEVOLL TI(1:72)=TITREE IEVTEX=TI ITYEVO=MEVOL1.ITYEVO C DO 201 IC=1,NC,2 KEVOL1=MEVOL1.IEVOLL(IC) KEVOL2=MEVOL2.IEVOLL(IC) SEGACT KEVOL1,KEVOL2 C C TEST DES SOUS-TYPES C ITYP1=KEVOL1.NUMEVY ITYP2=KEVOL2.NUMEVY C MLREE1=KEVOL1.IPROGX MLREE2=KEVOL2.IPROGX C C TEST DES LONGUEURS DES 2 SOUS-OBJETS EVOLUTION C SEGACT MLREE1,MLREE2 L1=MLREE1.PROG(/1) L2=MLREE2.PROG(/1) IF(L1.EQ.L2) GO TO 10 CALL ERREUR(337) GOTO 400 10 CONTINUE C C LES ABSCISSES DOIVENT ETRE IDENTIQUES C CALL VERIPR(MLREE1.PROG,MLREE2.PROG,L1,IRETOU,1.D-2) IF(IRETOU.NE.0) GO TO 11 CALL ERREUR(394) GO TO 400 11 CONTINUE SEGDES MLREE1,MLREE2 C C DEFINITION DES PARAMETRES POUR IC C SEGINI KEVOLL IEVOLL(IC)=KEVOLL TYPX='LISTREEL' TYPY='LISTREEL' c KEVTEX=TI KEVTEX=KEVOL1.KEVTEX C NOMEVX=KEVOL1.NOMEVX NOMEVY=KEVOL1.NOMEVY NUMEVX=ICOUL NUMEVY=KEVOL1.NUMEVY C C DEFINITION DE PROGX POUR IC C MLREE1=KEVOL1.IPROGX SEGACT MLREE1 JG=L1 SEGINI MLREEL IPROGX=MLREEL DO 20 I=1,L1 PROG(I)=MLREE1.PROG(I) 20 CONTINUE SEGDES KEVOLL,MLREEL,MLREE1 SEGDES KEVOL1 C C DEFINITION DES PARAMETRES POUR IC+1 C SEGINI KEVOLL TYPX='LISTREEL' TYPY='LISTREEL' IEVOLL(IC+1)=KEVOLL KEVOL1=MEVOL1.IEVOLL(IC+1) SEGACT KEVOL1 MLREE1=KEVOL1.IPROGX SEGACT MLREE1 KEVTEX=TI C NOMEVX=KEVOL1.NOMEVX NOMEVY=KEVOL1.NOMEVY NUMEVX=ICOUL NUMEVY=KEVOL1.NUMEVY C C DEFINITION DE PROGX POUR IC+1 C JG=L1 SEGINI MLREEL IPROGX=MLREEL DO 21 I=1,L1 PROG(I)=MLREE1.PROG(I) 21 CONTINUE SEGDES KEVOLL,MLREEL,KEVOL1,KEVOL2 C C NPT=L1 C C IF (ITYP1.EQ.'MODU') GO TO 200 C SEGINI TEMPP KEVOL1=MEVOL1.IEVOLL(IC) SEGACT KEVOL1 MLREE1=KEVOL1.IPROGY SEGACT MLREE1 DO 100 I=1,L1 AB(I)=MLREE1.PROG(I) 100 CONTINUE SEGDES KEVOL1,MLREE1 C KEVOL1=MEVOL1.IEVOLL(IC+1) SEGACT KEVOL1 MLREE1=KEVOL1.IPROGY SEGACT MLREE1 DO 120 I=1,L1 BB(I)=MLREE1.PROG(I) 120 CONTINUE SEGDES KEVOL1,MLREE1 C KEVOL1=MEVOL2.IEVOLL(IC) KEVOL2=MEVOL2.IEVOLL(IC+1) SEGACT KEVOL1,KEVOL2 MLREE1=KEVOL1.IPROGY MLREE2=KEVOL2.IPROGY SEGACT MLREE1,MLREE2 IF (ITYP2.EQ.'MODU') THEN DO 130 I=1,L1 DM(I)=MLREE1.PROG(I) DP(I)=MLREE2.PROG(I) 130 CONTINUE CALL CONVCP(DR,DI,DM,DP,L1,-1) ELSE DO 131 I=1,L1 DR(I)=MLREE1.PROG(I) DI(I)=MLREE2.PROG(I) 131 CONTINUE ENDIF DO 140 I=1,L1 AA(I)=AB(I)*DR(I) AB(I)=AB(I)*DI(I) BA(I)=BB(I)*DR(I) BB(I)=BB(I)*DI(I) 140 CONTINUE IF (INV.EQ.1) GO TO 142 DO 143 I=1,L1 A=MLREE1.PROG(I) B=MLREE2.PROG(I) DENOM(I)=A*A+B*B 143 CONTINUE 142 CONTINUE SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2 C C KEVOLL=MEVOLL.IEVOLL(IC) SEGACT KEVOLL*MOD JG=L1 SEGINI MLREEL IPROGY=MLREEL C IF(INV.EQ.1) THEN DO 30 I=1,L1 PROG(I)=AA(I)-BB(I) 30 CONTINUE ELSE DO 31 I=1,L1 IF(DENOM(I).GT.1.D-20) THEN PROG(I)=(AA(I)+BB(I))/DENOM(I) ELSE WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', & 'DIVISEUR : RESULTAT MIS A 0' PROG(I)=0.D0 GOTO 31 ENDIF 31 CONTINUE ENDIF C SEGDES KEVOLL,MLREEL C KEVOLL=MEVOLL.IEVOLL(IC+1) SEGACT KEVOLL*MOD JG=L1 SEGINI MLREEL IPROGY=MLREEL C C IF(INV.EQ.1) THEN DO 32 I=1,L1 PROG(I)=AB(I)+BA(I) 32 CONTINUE ELSE DO 33 I=1,L1 IF(DENOM(I).GT.1.D-20) THEN PROG(I)=(BA(I)-AB(I))/DENOM(I) ELSE WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', & 'DIVISEUR : RESULTAT MIS A 0' PROG(I)=0.D0 GOTO 33 ENDIF 33 CONTINUE ENDIF C SEGSUP TEMPP SEGDES KEVOLL,KEVOL1,KEVOL2 C GO TO 201 200 CONTINUE SEGINI TEMPP KEVOL1=MEVOL1.IEVOLL(IC) KEVOL2=MEVOL1.IEVOLL(IC+1) SEGACT KEVOL1,KEVOL2 MLREE1=KEVOL1.IPROGY MLREE2=KEVOL2.IPROGY SEGACT MLREE1,MLREE2 DO 210 I=1,L1 AA(I)=MLREE1.PROG(I) BB(I)=MLREE2.PROG(I) 210 CONTINUE SEGDES KEVOL1,MLREE1 SEGDES KEVOL2,MLREE2 C KEVOL1=MEVOL2.IEVOLL(IC) KEVOL2=MEVOL2.IEVOLL(IC+1) SEGACT KEVOL1,KEVOL2 MLREE1=KEVOL1.IPROGY MLREE2=KEVOL2.IPROGY SEGACT MLREE1,MLREE2 IF (ITYP2.EQ.'PREE') THEN DO 230 I=1,L1 DR(I)=MLREE1.PROG(I) DI(I)=MLREE2.PROG(I) 230 CONTINUE CALL CONVCP(DR,DI,DM,DP,L1,1) ELSE DO 231 I=1,L1 DM(I)=MLREE1.PROG(I) DP(I)=MLREE2.PROG(I) 231 CONTINUE ENDIF IF (INV.EQ.1) THEN DO 240 I=1,L1 AA(I)=AA(I)*DM(I) BB(I)=BB(I)+DP(I) 240 CONTINUE ELSE DO 243 I=1,L1 IF(DM(I).GT.1.D-20) THEN AA(I)=AA(I)/DM(I) ELSE WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', & 'DIVISEUR : RESULTAT MIS A 0' AA(I)=0.D0 ENDIF BB(I)=BB(I)-DP(I) 243 CONTINUE ENDIF DO 244 I=1,L1 IF (BB(I).GT.180.D0) THEN BB(I)=BB(I)-360.D0 ELSE IF(BB(I).LT.-180.D0) THEN BB(I)=BB(I)+360.D0 ENDIF 244 CONTINUE SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2 C KEVOLL=MEVOLL.IEVOLL(IC) SEGACT KEVOLL*MOD JG=L1 SEGINI MLREEL IPROGY=MLREEL C DO 330 I=1,L1 PROG(I)=AA(I) 330 CONTINUE SEGDES KEVOLL,MLREEL C KEVOLL=MEVOLL.IEVOLL(IC+1) SEGACT KEVOLL*MOD SEGINI MLREEL IPROGY=MLREEL C DO 332 I=1,L1 PROG(I)=BB(I) 332 CONTINUE SEGDES MLREEL C SEGSUP TEMPP SEGDES KEVOLL,KEVOL1,KEVOL2 C SEGDES MEVOLL,MEVOL1,MEVOL2 201 CONTINUE C 400 CONTINUE RETURN END