1 : C ENVSP1 SOURCE CHAT 05/01/12 23:40:54 5004 2 : SUBROUTINE ENVSP1 (MSPECT) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : ************************************************************************ 6 : * 7 : * E N V S P 1 8 : * ----------- 9 : * 10 : * FONCTION: 11 : * --------- 12 : * 13 : * CREER LE SPECTRE ENVELOPPE D'UNE SERIE DE SPECTRES D'OSCILLATEURS. 14 : * 15 : * CET OPERATEUR EST TRES ATTACHE A LA NOTION DE SPECTRE CAR IL 16 : * UTILISE L'INTERPOLATION LINEAIRE OU LOGARITHMIQUE DE FACON BIEN 17 : * SPECIFIQUE. 18 : * 19 : * MODULES UTILISES: 20 : * ----------------- 21 : * 22 : -INC CCOPTIO 23 : -INC SMEVOLL 24 : -INC SMLREEL 25 : * 26 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 27 : * ----------- 28 : * 29 : * MSPECT (E) SPECTRES D'OSCILLATEURS EN POSITIONS 1 A "N". 30 : * (S) SPECTRE ENVELOPPE EN POSITION "N+1". 31 : * 32 : SEGMENT,MSPECT 33 : INTEGER IPEVOL(NBSPEC+1),IPAMOR(NBSPEC+1) 34 : ENDSEGMENT 35 : * IPEVOL = SPECTRES D'OSCILLATEUR (OBJETS "EVOLUTIO"). 36 : * EN DERNIERE POSITION, ENVELOPPE. 37 : * IPAMOR = VALEURS DES AMORTISSEMENTS DE CHAQUE SPECTRE (OBJETS 38 : * "LISTREEL"). 39 : * 40 : * VARIABLES: 41 : * ---------- 42 : * 43 : PARAMETER (TOLER = 1.E-6) 44 : * 45 : * AUTEUR, DATE DE CREATION: 46 : * ------------------------- 47 : * 48 : * PASCAL MANIGOT 13 SEPTEMBRE 1988 49 : * 50 : * LANGAGE: 51 : * -------- 52 : * 53 : * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8". 54 : * 55 : ************************************************************************ 56 : * 57 : SEGACT,MSPECT*MOD 58 : NBSPEC = IPEVOL(/1) - 1 59 : * 60 : IF (NBSPEC .LE. 0) RETURN 61 : * 62 : * 63 : * CREATION DE LA LISTE DES AMORTISSEMENTS DU SPECTRE ENVELOPPE: 64 : * 65 : IPAMO9 = IPAMOR(1) 66 : * 67 : DO 100 IB=2,NBSPEC 68 : IPAMO1 = IPAMO9 69 : IPAM0R = IPAMOR(IB) 69 : CALL FUSLRE (IPAMO1,IPAM0R, IPAMO9) 70 : IF (IB .GT. 2) THEN 70 : CALL DTLREE (IPAMO1) 71 : END IF 72 : 100 CONTINUE 73 : * END DO 74 : * 75 : IPAMOR(NBSPEC+1) = IPAMO9 76 : * 76 : CALL DIMEN1(IPAMO9,NBAMOR) 77 : * 78 : * CREATION DE L'EVOLUTION DE L'ENVELOPPE 79 : * 80 : N = NBAMOR 81 : SEGINI MEVOLL 82 : ITRUC = MEVOLL 83 : ITYEVO = 'REEL ' 84 : * 85 : * RECHERCHE DES ENVELOPPES, POUR CHAQUE AMORTISSEMENT 86 : * 87 : DO 200 IB = 1,NBAMOR 87 : CALL EXTRA1(IPAMO9,IB,BETAI) 88 : * 89 : * CREATION OBJET EVOLUTION A BETA CONSTANT 90 : * 91 : N = NBSPEC 92 : SEGINI MEVOL1 93 : IEVOLB = MEVOL1 94 : * 95 : DO 300 IS = 1,NBSPEC 96 : NAMOR = IPAMOR(IS) 97 : NEVOL = IPEVOL(IS) 98 : MLREEL = NAMOR 99 : SEGACT MLREEL 100 : LDIM = PROG(/1) 101 : * 102 : * TEST POUR SAVOIR SI BETAI EST DANS NAMOR 103 : * 103 : CALL PLACE3(PROG,1,LDIM,BETAI,IR,AR) 104 : SEGDES MLREEL 105 : IF (AR.LT.TOLER) THEN 106 : * IL Y A UNE COURBE CORRESPONDANT A BETAI 107 : IF (IR.EQ.0) THEN 108 : IR = IR + 1 109 : ENDIF 110 : MEVOL2 = NEVOL 111 : SEGACT MEVOL2 112 : MEVOL1.IEVOLL(IS) = MEVOL2.IEVOLL(IR) 113 : SEGDES MEVOL2 114 : ELSE 115 : * INTERPOLATION 116 : IF (IR.EQ.0) THEN 117 : IR1 = 1 118 : IR2 = 2 119 : ELSE IF (IR.EQ.LDIM) THEN 120 : IR1 = LDIM - 1 121 : IR2 = LDIM 122 : ELSE 123 : IR1 = IR 124 : IR2 = IR + 1 125 : ENDIF 125 : CALL INTEVO(NEVOL,IR1,IR2,NAMOR,BETAI,NEVOL3) 126 : MEVOL2 = NEVOL3 127 : SEGACT MEVOL2 128 : MEVOL1.IEVOLL(IS) = MEVOL2.IEVOLL(1) 129 : SEGSUP MEVOL2 130 : ENDIF 131 : 300 CONTINUE 132 : * END DO 133 : * 134 : SEGDES MEVOL1 135 : IEVOL = MAXEVO(IEVOLB) 136 : SEGSUP MEVOL1 137 : * 138 : MEVOL2 = IEVOL 139 : SEGACT MEVOL2 140 : IEVOLL(IB) = MEVOL2.IEVOLL(1) 141 : SEGSUP MEVOL2 142 : * 143 : 200 CONTINUE 144 : * END DO 145 : * 146 : * ON RANGE L'EVOLUTION 147 : * 148 : IPEVOL(NBSPEC+1) = ITRUC 149 : * 150 : SEGDES MSPECT 151 : SEGDES MEVOLL 152 : * 153 : END 154 : 155 :
© Cast3M 2003 - All rights reserved.
Disclaimer