Sources Esope | Cast3M

puevol
C PUEVOL    SOURCE    BP208322  16/11/18    21:20:35     9177           
      SUBROUTINE PUEVOL(IPEV1,XP1,IP1,IEVPU,IRETO)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER *72 TI
      CHARACTER*4 CTYP1,MOTY3
      CHARACTER*12 MOTX1
      CHARACTER*4 MOTY(8),MOTY1
      LOGICAL     INF1,TEST1
C
C=======================================================================
C
C    CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LA PUISSANCE
C    ENTIERE D'UN OBJET EVOLUTIOn
C
C    SYNTAXE : PUIS =  EVOLF ** NN
C
C    ON EXECUTE LA PUISSANCE ENTIERE DES ORDONNEES DE L'EVOLUTIOn.
C    L'ABSCISSE DE L'OBJET AINSI CREE RESTE CELLE DE L'EVOLUTIOn EN
C    ENTREE.
C
C    ENTREES :
C      IPEV1 = POINTEUR SUR L'OBJET EVOLUTIOn E ELEVER A LA PUISSANCE
C      XP1   = PUISSANCE REELLE
C      IP1   = PUISSANCE ENTIERE
C      IRETO = 2 SI PUISSANCE REELLE
C            = 1 SI PUISSANCE ENTIERE
C
C    SORTIES :
C      IEVPU = POINTEUR SUR L'OBJET EVOLUTIOn RESULTAT
C            = 0 SI PB
C      IRETO = 1
C            = 0 SI UNE COMPOSANTE EST NEGATIVE
C
C    VARIABLES LOCALES :
C
C      MEVOL1  :  POINTEUR SUR MEVOLL (OBJET EVOLUTION)
C      KEVOL1  :  POINTEUR SUR KEVOLL
C      MLREE1  :  POINTEUR SUR LA LISTREEL ABSCISSE DE EVOLL
C      MLREE2  :  POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLL
C
C
C=======================================================================
C
-INC CCGEOME
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMLREEL
-INC SMLMOTS
-INC CCREEL
C
      POINTEUR MLREE4.MLREEL
C
      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
      XGRNEG=-1.D0*XGRAND
c
      IEVPU=0
      IFLO=IRETO
      IRETO=1
C
cbp     Lecture eventuelle d'une couleur pour toutes les sous evolutions
      CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
cbp       IF(ICOUL.EQ.0) ICOUL=IDCOUL+1
cbp       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
C
C     TEST SUR LE SOUS-TYPE
C
      CTYP1=MEVOL1.ITYEVO
      IF (CTYP1.NE.'COMP') GO TO 199
      SEGDES MEVOL1
      RETURN
  199 CONTINUE
C
C     BOUCLE SUR LES COURBES, SI LES 2 EVOL EN ONT AUTANT
C
      NC1=MEVOL1.IEVOLL(/1)
      N=NC1
      SEGINI MEVOLL
      IEVPU=MEVOLL
      TI(1:72)=TITREE
      IEVTEX=TI
      ITYEVO='REEL'
      DO 201 IC=1,NC1
        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
        MOTX1=KEVOL1.NOMEVX(1:4)
        MOTY1=KEVOL1.NOMEVY(1:4)
C
C
  51    MLREE2=KEVOL1.IPROGY
        IF (KEVOL1.NUMEVY.NE.'REEL'.AND.
     &      KEVOL1.NUMEVY.NE.'HIST') GOTO 1000
        SEGACT MLREE2
        IF (KEVOL1.TYPY.NE.'LISTMOTS') THEN
          L1=MLREE2.PROG(/1)
        ELSE
          MLMOT1=KEVOL1.IPROGY
          SEGACT MLMOT1
          L1=MLMOT1.MOTS(/2)
          SEGDES MLMOT1
        ENDIF
        SEGDES MLREE2
C
C
C     CREATION DE L'OBJET PROD DE TYPE EVOLUTIO
C
C
        MLREE1=KEVOL1.IPROGX
        MLREE2=KEVOL1.IPROGY
        SEGACT MLREE1,MLREE2
        SEGINI KEVOLL
        IEVOLL(IC)=KEVOLL
C
        TYPX='LISTREEL'
        TYPY='LISTREEL'
c         KEVTEX=TI
        KEVTEX=KEVOL1.KEVTEX
        NOMEVX=MOTX1
        IF (IFLO.EQ.1) THEN
          WRITE(MOTY3,'(I4)') INT(XP1)
          NOMEVY=MOTY1(1:4)//'**'//MOTY3(1:4)
        ELSE
          WRITE(MOTY3,'(F4.1)') XP1
          NOMEVY=MOTY1(1:4)//'** '//MOTY3(1:4)
        ENDIF
cbp         NUMEVX=ICOUL
cbp     tant qu'on peut, on conserve la couleur
        if(ICOUL.ne.0) then
          NUMEVX = ICOUL-1
        else
          NUMEVX = KEVOL1.NUMEVX
        endif
        NUMEVY='REEL'
C
        JG=L1
        SEGINI,MLREE3=MLREE1
        IPROGX=MLREE3
        SEGINI,MLREE4
        IPROGY=MLREE4
c         IF (XP1.GT.0.) THEN
c           DO 20 I=1,L1
c             X=MLREE1.PROG(I)
c             Y=MLREE2.PROG(I)
c             MLREE3.PROG(I)=X
c             MLREE4.PROG(I)=Y**XP1
c   20      CONTINUE
c         ELSE
c           DO 21 I=1,L1
c              X=MLREE1.PROG(I)
c              Y=MLREE2.PROG(I)
c              MLREE3.PROG(I)=X
c              IF (Y.GT.1.E-20) THEN
c                 MLREE4.PROG(I)=Y**XP1
c              ELSE
c                 GOTO 1001
c              ENDIF
c   21      CONTINUE
c         ENDIF
c
c bp: ci dessus donne des NAN si Y&lt;0 et XP1>0, on préfère :
c
        IF (IFLO.EQ.1) THEN
          DO 20 I=1,L1
cbp2012              X=MLREE1.PROG(I)
             Y=MLREE2.PROG(I)
cbp2012              MLREE3.PROG(I)=X
             MLREE4.PROG(I)=Y**IP1
  20      CONTINUE
          TEST1=IP1.lt.0
c bp (05/2012) : ajout du cas SQRT
        ELSEIF(XP1.eq.0.5D0) THEN
          DO 21 I=1,L1
cbp2012              X=MLREE1.PROG(I)
             Y=MLREE2.PROG(I)
cbp2012              MLREE3.PROG(I)=X
             IF(Y.LT.0.D0) GOTO 1001
             MLREE4.PROG(I)=sqrt(Y)
  21      CONTINUE
          TEST1 = .false.
        ELSE
          DO 22 I=1,L1
cbp2012              X=MLREE1.PROG(I)
             Y=MLREE2.PROG(I)
cbp2012              MLREE3.PROG(I)=X
             IF(Y.LT.0.D0) GOTO 1001
             MLREE4.PROG(I)=Y**XP1
  22      CONTINUE
          TEST1=XP1.lt.0.D0
        ENDIF
c
c      on ajoute un petit avertissement en présence d'INF
c      (pas une erreur car ce resultat peut etre intermediaire et
c      finalement 1/INF=0 donc on peut continuer)
       INF1=.false.
       if (TEST1) then
        do i=1,L1
           Y=MLREE4.PROG(i)
           if(Y.gt.XGRAND) INF1=.true.
        enddo
       endif
       if(INF1) write(IOIMP,*)
     & 'Attention: au moins une valeur est INFinie'
C
C     DESACTIVE LES LISTREEL
C
      SEGDES MLREE3,MLREE4
      SEGDES MLREE1,MLREE2
C
C     DESACTIVE LES KEVOL
C
      SEGDES KEVOLL
      SEGDES KEVOL1
C
 201  CONTINUE
C
C     DESACTIVE LES MEVOL
C
      SEGDES MEVOLL
      SEGDES MEVOL1
C
 100  CONTINUE
      RETURN
 1000 CONTINUE
      MOTERR(1:8 )='EVOLUTIO'
      MOTERR(9:13)=KEVOL1.NUMEVY
      CALL ERREUR(131)
      RETURN
 1001 CONTINUE
      CALL ERREUR(213)
      RETURN
 2001 FORMAT(I1)
 2002 FORMAT(I2)
 2003 FORMAT(I3)
 2004 FORMAT(I4)
      END