1 : C ENVSPE SOURCE CHAT 05/01/12 23:41:02 5004 2 : SUBROUTINE ENVSPE 3 : ************************************************************************ 4 : * 5 : * E N V S P E 6 : * ----------- 7 : * 8 : * SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "ENVELOPPE" 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 : * PHRASE D'APPEL (EN GIBIANE): 20 : * ---------------------------- 21 : * 22 : * ENVLOP = 'ENVELOPPE' LIST_SPO ; 23 : * 24 : * OPERANDES ET RESULTATS: 25 : * ----------------------- 26 : * 27 : * LIST_SPO (TABLE) CONTIENT LES DIFFERENTS SPECTRES 28 : * -------- D'OSCILLATEUR (PAS FORCEMENT DEFINIS AUX 29 : * MEMES FREQUENCES, NI POUR LES MEMES 30 : * AMORTISSEMENTS): 31 : * LIST_SPO I 'SPECTRE = OBJET "EVOLUTIO" REPRESENTANT LE 32 : * I-EME "SPO". 33 : * LIST_SPO I 'AMORTISSEMENT' = OBJET "LISTREEL" DONNANT LES 34 : * AMORTISSEMENTS POUR CHAQUE COURBE 35 : * DE L'OBJET "EVOLUTIO" NUMERO "I". 36 : * 37 : * ENVLOP (TABLE) CONTIENT LE SPECTRE ENVELOPPE: 38 : * ------ 39 : * LIST_SPO 'SPECTRE' = OBJET "EVOLUTIO" REPRESENTANT LE 40 : * SPECTRE. 41 : * LIST_SPO 'AMORTISSEMENT' = OBJET "LISTREEL" DONNANT LES 42 : * AMORTISSEMENTS POUR CHAQUE COURBE 43 : * DE L'OBJET "EVOLUTIO". 44 : * 45 : * MODULES UTILISES: 46 : * ----------------- 47 : * 48 : IMPLICIT INTEGER(I-N) 49 : -INC CCOPTIO 50 : -INC SMTABLE 51 : * 52 : * VARIABLES: 53 : * ---------- 54 : * 55 : * IPEVOL = SPECTRES D'OSCILLATEUR (OBJETS "EVOLUTIO"). 56 : * EN DERNIERE POSITION, ENVELOPPE. 57 : * IPAMOR = VALEURS DES AMORTISSEMENTS DE CHAQUE SPECTRE (OBJETS 58 : * "LISTREEL"). 59 : * 60 : REAL*8 X,XVALRE 61 : CHARACTER*1 C 62 : CHARACTER*8 TYPOBJ,CHARRE 63 : LOGICAL L,LOGIN,LOGRE 64 : SEGMENT,MSPECT 65 : INTEGER IPEVOL(NBSPEC+1),IPAMOR(NBSPEC+1) 66 : ENDSEGMENT 67 : * 68 : * AUTEUR, DATE DE CREATION: 69 : * ------------------------- 70 : * 71 : * PASCAL MANIGOT 13 SEPTEMBRE 1988 72 : * 73 : * LANGAGE: 74 : * -------- 75 : * 76 : * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8". 77 : * 78 : ************************************************************************ 79 : * 79 : CALL LIROBJ ('TABLE ',ISPEC,1,IRETOU) 80 : IF (IERR .NE. 0) RETURN 81 : * 82 : * NOMBRE DE SPECTRES D'OSCILLATEURS FOURNI: 82 : CALL DIMEN7 (ISPEC, NBSPEC) 83 : IF (NBSPEC .LE. 0) THEN 83 : CALL ERREUR (215) 84 : RETURN 85 : END IF 86 : * 87 : * LA TABLE EST SUPPOSEE ETRE INDICEE PAR DES ENTIERS, A PARTIR DE 1. 88 : * ... CE QUE L'ON VA VERIFIER TOUT DE SUITE, EN MEME TEMPS QUE L'ON 89 : * RANGE LES SPECTRES SOUS UNE FORME INFORMATIQUEMENT PLUS PRATIQUE. 90 : * 91 : SEGINI,MSPECT 92 : * 93 : DO 100 IB=1,NBSPEC 94 : TYPOBJ = 'TABLE ' 94 : CALL ACCTAB(ISPEC,'ENTIER ',IB,0.D0,C,LOGIN ,0,TYPOBJ, 95 : C IVALRE,XVALRE,CHARRE,LOGRE,ICOUR) 96 : IF (TYPOBJ.NE.'TABLE ') THEN 97 : MOTERR(1:8)=TYPOBJ(1:8) 97 : CALL ERREUR(39) 98 : ENDIF 99 : IF (IERR .NE. 0) RETURN 100 : TYPOBJ = 'EVOLUTIO' 100 : CALL ACCTAB(ICOUR,'MOT ',0,0.D0,'SPECTRE',LOGIN ,0,TYPOBJ, 101 : C IVALRE,XVALRE,CHARRE,LOGRE,IPTR) 102 : IF (TYPOBJ.NE.'EVOLUTIO') THEN 103 : MOTERR(1:8)=TYPOBJ(1:8) 103 : CALL ERREUR(39) 104 : ENDIF 105 : IF (IERR .NE. 0) RETURN 106 : IPEVOL(IB) = IPTR 107 : TYPOBJ = 'LISTREEL' 107 : CALL ACCTAB(ICOUR,'MOT ',0,0.D0,'AMORTISSEMENT',LOGIN ,0, 108 : C TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPTR) 109 : IF (TYPOBJ.NE.'LISTREEL') THEN 110 : MOTERR(1:8)=TYPOBJ(1:8) 110 : CALL ERREUR(39) 111 : ENDIF 112 : IF (IERR .NE. 0) RETURN 113 : IPAMOR(IB) = IPTR 114 : 100 CONTINUE 115 : * END DO 116 : * 117 : * CREATION DU SPECTRE ENVELOPPE: 117 : CALL ENVSP1 (MSPECT) 118 : IF (IERR .NE. 0) RETURN 119 : * 119 : CALL CRTABL(MTABLE) 120 : SEGACT,MSPECT 121 : IPEV0L = IPEVOL(NBSPEC+1) 121 : CALL ECCTAB (MTABLE,'MOT ',I,X,'SPECTRE',L,I, 122 : & 'EVOLUTIO',I,X,C,L,IPEV0L) 123 : IPAM0R = IPAMOR(NBSPEC+1) 123 : CALL ECCTAB (MTABLE,'MOT ',I,X,'AMORTISSEMENT',L,I, 124 : & 'LISTREEL',I,X,C,L,IPAM0R) 125 : * 126 : SEGSUP,MSPECT 127 : SEGDES,MTABLE 128 : * 129 : * ECRITURE DU SPECTRE ENVELOPPE: 129 : CALL ECROBJ ('TABLE ',MTABLE) 130 : * 131 : END 132 :
© Cast3M 2003 - All rights reserved.
Disclaimer