Sources Esope | Cast3M

envsp1
C ENVSP1    SOURCE    CHAT      05/01/12    23:40:54     5004
      SUBROUTINE ENVSP1 (MSPECT)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
************************************************************************
*
*                             E N V S P 1
*                             -----------
*
* FONCTION:
* ---------
*
*     CREER LE SPECTRE ENVELOPPE D'UNE SERIE DE SPECTRES D'OSCILLATEURS.
*
*     CET OPERATEUR EST TRES ATTACHE A LA NOTION DE SPECTRE CAR IL
*     UTILISE L'INTERPOLATION LINEAIRE OU LOGARITHMIQUE DE FACON BIEN
*     SPECIFIQUE.
*
* MODULES UTILISES:
* -----------------
*
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMLREEL
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     MSPECT  (E)  SPECTRES D'OSCILLATEURS EN POSITIONS 1 A "N".
*             (S)  SPECTRE ENVELOPPE EN POSITION "N+1".
*
      SEGMENT,MSPECT
         INTEGER IPEVOL(NBSPEC+1),IPAMOR(NBSPEC+1)
      ENDSEGMENT
*     IPEVOL = SPECTRES D'OSCILLATEUR (OBJETS "EVOLUTIO").
*              EN DERNIERE POSITION, ENVELOPPE.
*     IPAMOR = VALEURS DES AMORTISSEMENTS DE CHAQUE SPECTRE (OBJETS
*              "LISTREEL").
*
* VARIABLES:
* ----------
*
      PARAMETER (TOLER = 1.E-6)
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     13 SEPTEMBRE 1988
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
*
************************************************************************
*
      SEGACT,MSPECT*MOD
      NBSPEC = IPEVOL(/1) - 1
*
      IF (NBSPEC .LE. 0) RETURN
*
*
*     CREATION DE LA LISTE DES AMORTISSEMENTS DU SPECTRE ENVELOPPE:
*
      IPAMO9 = IPAMOR(1)
*
      DO 100 IB=2,NBSPEC
         IPAMO1 = IPAMO9
         IPAM0R = IPAMOR(IB)
         CALL FUSLRE (IPAMO1,IPAM0R,  IPAMO9)
         IF (IB .GT. 2) THEN
            CALL DTLREE (IPAMO1)
         END IF
  100    CONTINUE
*     END DO
*
      IPAMOR(NBSPEC+1) = IPAMO9
*
      CALL DIMEN1(IPAMO9,NBAMOR)
*
*     CREATION DE L'EVOLUTION DE L'ENVELOPPE
*
      N = NBAMOR
      SEGINI MEVOLL
      ITRUC = MEVOLL
      ITYEVO = 'REEL    '
*
*     RECHERCHE DES ENVELOPPES, POUR CHAQUE AMORTISSEMENT
*
      DO 200 IB = 1,NBAMOR
         CALL EXTRA1(IPAMO9,IB,BETAI)
*
*        CREATION OBJET EVOLUTION A BETA CONSTANT
*
         N = NBSPEC
         SEGINI MEVOL1
         IEVOLB = MEVOL1
*
         DO 300 IS = 1,NBSPEC
            NAMOR = IPAMOR(IS)
            NEVOL = IPEVOL(IS)
            MLREEL = NAMOR
            SEGACT MLREEL
            LDIM = PROG(/1)
*
*           TEST POUR SAVOIR SI BETAI EST DANS NAMOR
*
            CALL PLACE3(PROG,1,LDIM,BETAI,IR,AR)
            SEGDES MLREEL
            IF (AR.LT.TOLER) THEN
*              IL Y A UNE COURBE CORRESPONDANT A BETAI
               IF (IR.EQ.0) THEN
                  IR = IR + 1
               ENDIF
               MEVOL2 = NEVOL
               SEGACT MEVOL2
               MEVOL1.IEVOLL(IS) = MEVOL2.IEVOLL(IR)
               SEGDES MEVOL2
            ELSE
*              INTERPOLATION
               IF (IR.EQ.0) THEN
                  IR1 = 1
                  IR2 = 2
               ELSE IF (IR.EQ.LDIM) THEN
                  IR1 = LDIM - 1
                  IR2 = LDIM
               ELSE
                  IR1 = IR
                  IR2 = IR + 1
               ENDIF
               CALL INTEVO(NEVOL,IR1,IR2,NAMOR,BETAI,NEVOL3)
               MEVOL2 = NEVOL3
               SEGACT MEVOL2
               MEVOL1.IEVOLL(IS) = MEVOL2.IEVOLL(1)
               SEGSUP MEVOL2
            ENDIF
300         CONTINUE
*        END DO
*
         SEGDES MEVOL1
         IEVOL = MAXEVO(IEVOLB)
         SEGSUP MEVOL1
*
         MEVOL2 = IEVOL
         SEGACT MEVOL2
         IEVOLL(IB) = MEVOL2.IEVOLL(1)
         SEGSUP MEVOL2
*
200      CONTINUE
*     END DO
*
*     ON RANGE L'EVOLUTION
*
      IPEVOL(NBSPEC+1) = ITRUC
*
      SEGDES MSPECT
      SEGDES MEVOLL
*
      END