Sources Esope | Cast3M

puis
C PUIS      SOURCE    BP208322  16/11/18    21:20:35     9177           
      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 PPARAM
-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'
c       KEVTEX=TI
C
      NOMEVX=MOTX
      IF (INV.EQ.1) THEN
         NOMEVY=MOTY1//MOTY2//MOTY3
      ELSE
         NOMEVY=MOTY1//MOTY4//MOTY3
      ENDIF
      KEVTEX=NOMEVY
      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