C PUIS SOURCE PASCAL 10/01/08 21:15:10 6604 SUBROUTINE PUIS(IPEV1,IPEV2,IRET,INV) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) CHARACTER *72 TI CHARACTER*4 ITYP1 CHARACTER*12 MOTX CHARACTER*4 MOTY(8),MOTY1,MOTY2,MOTY3,MOTY4 C C======================================================================= C = = C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LE PRODUIT OU LE = C = RAPPORT TERME A TERME DE DEUX OBJETS EVOLUTIO = C = = C = SYNTAXE : PROD = EVOLF * EVOLV (COUL) = C = = C = ON EXECUTE LE PRODUIT 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 = = C = ADAPTE AUX OBJETS "EVOLUTION" DE TYPE SOUS-TYPE "COMPLEXE" = C = PAR APPEL A PUISCP PAR F.ROULLIER C======================================================================= C -INC CCGEOME -INC CCOPTIO -INC SMEVOLL -INC SMLREEL -INC SMLMOTS POINTEUR MLREE4.MLREEL,MLREE5.MLREEL C DATA MOTY2,MOTY4/' * ',' / '/ DATA MOTY(1),MOTY(2),MOTY(3),MOTY(4)/'DEPL','VITE','ACCE','FORC'/ DATA MOTY(5),MOTY(6),MOTY(7),MOTY(8)/'BRUI','REEL','IMAG','LIAI'/ C CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) IF(ICOUL.EQ.0) ICOUL=IDCOUL+1 ICOUL=ICOUL-1 C C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR C L'UN EST UNE FORCE, L'AUTRE UNE VITESSE C MEVOL1=IPEV1 SEGACT MEVOL1 MEVOL2=IPEV2 SEGACT MEVOL2 C C TEST SUR LE SOUS-TYPE C ITYP1=MEVOL1.ITYEVO IF (ITYP1.NE.'COMP') GO TO 199 SEGDES MEVOL1,MEVOL2 CALL PUISCP(IPEV1,IPEV2,IRET,INV,ICOUL) RETURN 199 CONTINUE C C BOUCLE SUR LES COURBES, SI LES 2 EVOL EN ONT AUTANT C NC1=MEVOL1.IEVOLL(/1) NC2=MEVOL2.IEVOLL(/1) IF(NC1.EQ.NC2) GOTO 200 CALL ERREUR(111) RETURN C 200 CONTINUE N=NC1 SEGINI MEVOLL IRET=MEVOLL TI(1:72)=TITREE IEVTEX=TI ITYEVO='REEL' DO 201 IC=1,NC1 C KEVOL1=MEVOL1.IEVOLL(IC) SEGACT KEVOL1 DO 50 I=1,3 DO 50 J=1,8 IF(KEVOL1.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN MOTY1=KEVOL1.NOMEVY(I*4-3:I*4) GOTO 51 ENDIF 50 CONTINUE MOTY1=KEVOL1.NOMEVY(1:4) C C 51 MLREE1=KEVOL1.IPROGY IF (KEVOL1.NUMEVY.NE.'REEL'.AND.KEVOL1.NUMEVY.NE.'HIST') GOTO 1000 SEGACT MLREE1 IF(KEVOL1.TYPY.NE.'LISTMOTS')THEN L1=MLREE1.PROG(/1) ELSE MLMOT1=KEVOL1.IPROGY SEGACT MLMOT1 L1=MLMOT1.MOTS(/2) SEGDES MLMOT1 ENDIF C KEVOL2=MEVOL2.IEVOLL(IC) SEGACT KEVOL2 MOTX=KEVOL2.NOMEVX DO 52 I=1,3 DO 52 J=1,8 IF(KEVOL2.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN MOTY3=KEVOL2.NOMEVY(I*4-3:I*4) GOTO 53 ENDIF 52 CONTINUE MOTY3=KEVOL2.NOMEVY(1:4) C C 53 MLREE2=KEVOL2.IPROGY IF (KEVOL2.NUMEVY.NE.'REEL'.AND.KEVOL2.NUMEVY.NE.'HIST') GOTO 1001 SEGACT MLREE2 IF(KEVOL2.TYPY.NE.'LISTMOTS')THEN L2=MLREE2.PROG(/1) ELSE MLMOT2=KEVOL2.IPROGY SEGACT MLMOT2 L2=MLMOT2.MOTS(/2) SEGDES MLMOT2 ENDIF C C LES LISTREEL ONT-ILS MEME LONGUEUR ? IF(L1.EQ.L2)GOTO 10 CALL ERREUR(337) GOTO 100 C C CREATION DE L'OBJET PROD DE TYPE EVOLUTIO C 10 CONTINUE SEGDES MLREE1 SEGDES MLREE2 C C LES LISTREEL DES ABSCISSES SONT ILS IDENTIQUES ? MLREE1=KEVOL1.IPROGX MLREE3=KEVOL2.IPROGX SEGACT MLREE1,MLREE3 CALL VERIPR(MLREE1.PROG,MLREE3.PROG,L1,IRETOU,1.D-2) IF(IRETOU.EQ.0) THEN CALL ERREUR(394) RETURN ENDIF SEGDES MLREE1 C MLREE1=KEVOL1.IPROGY MLREE2=KEVOL2.IPROGY SEGACT MLREE1,MLREE2,MLREE3 SEGINI KEVOLL IEVOLL(IC)=KEVOLL TYPX='LISTREEL' TYPY='LISTREEL' KEVTEX=TI C NOMEVX=MOTX IF (INV.EQ.1) THEN NOMEVY=MOTY1//MOTY2//MOTY3 ELSE NOMEVY=MOTY1//MOTY4//MOTY3 ENDIF NUMEVX=ICOUL NUMEVY='REEL' C JG=L1 SEGINI MLREE4 IPROGX=MLREE4 SEGINI MLREE5 IPROGY=MLREE5 C C C C IF(INV.EQ.1) THEN DO 20 I=1,L1 FORC=MLREE1.PROG(I) VITE=MLREE2.PROG(I) TIM=MLREE3.PROG(I) C C TIM ET FORC*VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR * C MLREE4.PROG(I)=TIM MLREE5.PROG(I)=VITE*FORC C 20 CONTINUE ELSE DO 21 I=1,L1 FORC=MLREE1.PROG(I) VITE=MLREE2.PROG(I) TIM=MLREE3.PROG(I) C C TIM ET FORC/VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR * C MLREE4.PROG(I)=TIM IF(ABS(VITE).GT.1.E-20) THEN MLREE5.PROG(I)=FORC/VITE ELSE WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', & 'DIVISEUR : RESULTAT MIS A 0' MLREE5.PROG(I)=0.D0 GOTO 21 ENDIF C 21 CONTINUE ENDIF C C DESACTIVE LES LISTREEL C SEGDES MLREE4,MLREE5 SEGDES MLREE3,MLREE1,MLREE2 C C DESACTIVE LES KEVOL C SEGDES KEVOLL SEGDES KEVOL1,KEVOL2 C 201 CONTINUE C C DESACTIVE LES MEVOL C SEGDES MEVOLL SEGDES MEVOL1,MEVOL2 C 100 CONTINUE RETURN 1000 CONTINUE moterr(1:8 )='EVOLUTIO' moterr(9:13)=KEVOL1.NUMEVY call erreur(131) return 1001 CONTINUE moterr(1:8 )='EVOLUTIO' moterr(9:13)=KEVOL2.NUMEVY call erreur(131) RETURN END