1 : C PSRS SOURCE CHAT 07/10/29 21:26:56 5940 2 : C PSRS SOURCE ISPRA 90/02/27 3 : SUBROUTINE PSRS 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : C======================================================================= 7 : C = CALCUL DU "RESPONSE SPECTRUM" A PARTIR DU "POWER SPECTRUM" = 8 : C = POUR PLUSIEURS AMORTISSEMENTS = 9 : C = = 10 : C = SYNTAXE : = 11 : C = = 12 : C = RSPE*EVOL = PSRS PSPE*EVOL TE *REEL AMOR*LISTREEL = 13 : C = (TT*LISTREEL MCL1*MOT MCL2*MOT = 14 : C = MCL3*MOT COUL*MOT ) = 15 : C = = 16 : C = = 17 : C = RSPE : OBJET DE TYPE EVOLUTIO CONTENANT LES = 18 : C = "RESPONSE SPECTRA" (NAMOR COURBES) = 19 : C = PSPE : OBJET DE TYPE EVOLUTIO CONTENANT LE "POWER SPECTRUM"= 20 : C = ( UNE COURBE SEULEMENT ) = 21 : C = TE : REEL DONNANT LA DUREE DU SIGNAL (SEC.) = 22 : C = AMOR : OBJET DE TYPE LISTREEL CONTENANT NAMOR AMORTISSEMENTS 23 : C = = 24 : C = MCL1 : GRANDEUR DE REPONSE: 'DEPL(ACEMENT)', 'VITE(SSE)' = 25 : C = : OU 'ACCE(LERATION)' (DEFAUT) = 26 : C = MCL2 : DISTRIBUTION: 'NEWG(UMG)' OU 'CRAM(ER)' = 27 : C = MCL3 : CHOIX DE L'ABSISSE DU "RESPONSE SPECTRUM" = 28 : C = : 'FREQ(UENCE)' OU 'PERI(ODE)' (DEFAUT) = 29 : C = : DANS LES 2 CAS LES VALEURS SONT RANGEES PAR VALEURS = 30 : C = CROISSANTES DES ABSCISSES (UTILATION DE IPOL!) = 31 : C = TT : OBJET DE TYPE LISTREEL CONTENANT LES PERIODES = 32 : C = COUL : COULEUR ATTRIBUEE A L'OBJET CREE (FACULTATIF) = 33 : C = ( DEFAUT = COULEUR DE PSRS) = 34 : C = = 35 : C = CREATION : 27/02/90, reprise 2/4/90 = 36 : C = MESSAGE D'ERREUR : 15/9/91 = 37 : C = PROGRAMMEUR : A.P. ET P.P. = 38 : C======================================================================= 39 : C 40 : CHARACTER *72 TI 41 : CHARACTER*12 MOTX,MOTY 42 : C 43 : PARAMETER (NMOCLE=7) 44 : CHARACTER*4 MOTCLE(NMOCLE) 45 : LOGICAL LPERIO,LUSER 46 : C 47 : -INC CCGEOME 48 : -INC CCOPTIO 49 : -INC SMEVOLL 50 : -INC SMLREEL 51 : C 52 : SEGMENT MTRAV 53 : IMPLIED F(NSPT),S(NSPT) ,ETI(NAMRT), T(NI), RES(NAMRT,NI) 54 : ENDSEGMENT 55 : C 56 : DATA MOTCLE/'PERI','FREQ','ACCE','VITE','DEPL','CRAM','NEWG'/ 57 : C 58 : C DEFAUT MCLE: "'PERI'->LPERIO, 'ACCE'->IGRAND, 'CRAM'->IDISTR 59 : C 60 : LPERIO=.TRUE. 61 : IGRAND=1 62 : IDISTR=1 63 : C 64 : C 65 : C LECTURE DE L'OBJET EVOLUTIO CONTENANT LE "POWER SPECTRUM" 66 : C 66 : CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET1) 67 : IF(IRET1.EQ.0) GOTO 666 68 : C 69 : C LECTURE DU REEL DONNANT LA DUREE DU SIGNAL 70 : C 70 : CALL LIRREE(TE,1,IRET3) 71 : IF(IRET3.EQ.0) GOTO 666 72 : C 73 : C LECTURE DE L'OBJET LISTREEL CONTENANT LES AMORTISSEMENT 74 : C 74 : CALL LIROBJ('LISTREEL',IPREE,1,IRET2) 75 : IF(IRET2.EQ.0) GOTO 666 76 : C 77 : C LECTURE DE L'OBJET LISTREEL DONNANT LE TABLEAU DES PERIODES 78 : C DEFINI PAR L'UTILISATEUR 79 : C 79 : CALL LIROBJ('LISTREEL',IPREET,0,IRET4) 80 : IF(IRET4.EQ.0)THEN 81 : LUSER=.FALSE. 82 : ELSE 83 : LUSER=.TRUE. 84 : ENDIF 85 : C 86 : C LECTURE DES MOTS MCL1, MCL2, MCL3 ...ET DE LA COULEUR 87 : C 87 : * 1 CALL LIRMO2(MOTCLE,NMOCLE,IVAL, 88 : * > NCOUL ,NBCOUL,ICOUL,0) 89 : C 89 : 1 CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0) 90 : * WRITE(*,*) MOTCLE 90 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 91 : * WRITE(*,*) NCOUL 92 : * WRITE(*,*) NBCOUL 93 : * WRITE(*,*) ICOUL 94 : IF (ICOUL.EQ.0) ICOUL=IDCOUL+1 95 : ICOUL=ICOUL-1 96 : IF(IVAL.EQ.0)GOTO 9 97 : GOTO(2,3,4,4,4,5,5),IVAL 98 : C ---> "MCL3" 99 : 2 LPERIO=.TRUE. 100 : WRITE(*,*) 'Dans 2' 101 : GOTO 1 102 : 3 LPERIO=.FALSE. 103 : WRITE(*,*) 'Dans 3' 104 : GOTO 1 105 : C ---> "MCL1" 1->ACCE, 2->VITE, 3->DEPL 106 : 4 IGRAND=IVAL-2 107 : WRITE(*,*) 'Dans 4' 108 : GOTO 1 109 : C ---> "MCL2" 1->CRAM, 2->NEWG 110 : 5 IDISTR=IVAL-5 111 : WRITE(*,*) 'Dans 5' 112 : GOTO 1 113 : C 114 : C LECTURE DE LA COULEUR 115 : C 116 : 9 IF(ICOUL.NE.0)GOTO 1 117 : C 118 : IF(IERR.NE.0) GOTO 666 119 : C 120 : C RECHERCHE DE LA TAILLE DU SEGMENT DE TRAVAIL 121 : C 122 : MEVOL1=IPSIG 123 : SEGACT MEVOL1 124 : KEVOL1=MEVOL1.IEVOLL(1) 125 : SEGACT KEVOL1 126 : C 127 : IF(ICOUL.EQ.0) ICOUL=KEVOL1.NUMEVX 128 : C 129 : MLREE3=KEVOL1.IPROGX 130 : SEGACT MLREE3 131 : NSPT=MLREE3.PROG(/1) 132 : SEGDES MLREE3 133 : C 134 : MLREE3=IPREE 135 : SEGACT MLREE3 136 : NAMRT=MLREE3.PROG(/1) 137 : SEGDES MLREE3 138 : C 139 : IF (LUSER)THEN 140 : MLREE3=IPREET 141 : SEGACT MLREE3 142 : NI=MLREE3.PROG(/1) 143 : SEGDES MLREE3 144 : NT=NI 145 : ELSE 146 : NI=75 147 : NT=0 148 : ENDIF 149 : C 150 : C CHARGEMENT DES TABLEAUX DE TRAVAIL 151 : C 152 : SEGINI MTRAV 153 : C 154 : MLREE1=KEVOL1.IPROGX 155 : MLREE2=KEVOL1.IPROGY 156 : SEGACT MLREE1,MLREE2 157 : DO 10 I=1,NSPT 158 : F(I)=MLREE1.PROG(I) 159 : S(I)=MLREE2.PROG(I) 160 : 10 CONTINUE 161 : SEGDES MLREE1 162 : SEGDES MLREE2 163 : SEGDES KEVOL1 164 : SEGDES MEVOL1 165 : C 166 : MLREE3=IPREE 167 : SEGACT MLREE3 168 : DO 11 I=1,NAMRT 169 : ETI(I)=MLREE3.PROG(I) 170 : 11 CONTINUE 171 : SEGDES MLREE3 172 : C 173 : IF (LUSER)THEN 174 : MLREE3=IPREET 175 : SEGACT MLREE3 176 : DO 12 I=1,NI 177 : T(I)=MLREE3.PROG(I) 178 : 12 CONTINUE 179 : SEGDES MLREE3 180 : ENDIF 181 : C 182 : C CALCUL DU "RESPONSE SPECTRUM" 183 : C 183 : CALL POSPRE(MTRAV,NSPT,NAMRT, IGRAND,IDISTR,TE,NT) 184 : IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DU "RESPONSE SPECTRUM" ' 185 : C 186 : C ABSISSE EN PERIODE OU EN FREQUENCE 187 : C 188 : IF(LPERIO.AND.LUSER)THEN 189 : MLREE1=IPREET 190 : MOTX='PERIODE' 191 : ELSE 192 : JG=NT 193 : SEGINI MLREE1 194 : IF(LPERIO)THEN 195 : DO 20 I=1,NT 196 : MLREE1.PROG(I)=T(I) 197 : 20 CONTINUE 198 : MOTX='PERIODE' 199 : ELSE 200 : DO 21 I=1,NT 201 : MLREE1.PROG(NT-I+1)=1/T(I) 202 : 21 CONTINUE 203 : MOTX='FREQUENCE' 204 : ENDIF 205 : SEGDES MLREE1 206 : ENDIF 207 : C 208 : C LEGENDE (PARTIELLE) DES ORDONNEES 209 : C 210 : MOTY(1:10)='RSPE-'//MOTCLE(2+IGRAND)//' ' 211 : C 212 : C CREATION DE L'OBJET EVOLUTIO RSPE 213 : C 214 : N=NAMRT 215 : SEGINI MEVOLL 216 : IPVO=MEVOLL 217 : TI(1:72)=TITREE 218 : IEVTEX=TI 219 : ITYEVO='REEL' 220 : C 221 : DO 30 IEVOL=1,NAMRT 222 : C 223 : SEGINI KEVOLL 224 : C 225 : WRITE(TI,100)ETI(IEVOL) 226 : 100 FORMAT(1X,'AMORTISSEMENT DE ',1PD12.5) 227 : KEVTEX=TI 228 : C 229 : IEVOLL(IEVOL)=KEVOLL 230 : TYPX='LISTREEL' 231 : TYPY='LISTREEL' 232 : C 233 : IPROGX=MLREE1 234 : NOMEVX=MOTX(1:12) 235 : C 236 : JG=NT 237 : SEGINI MLREE2 238 : IF(LPERIO)THEN 239 : DO 22 I=1,NT 240 : MLREE2.PROG(I)=RES(IEVOL,I) 241 : 22 CONTINUE 242 : ELSE 243 : DO 23 I=1,NT 244 : MLREE2.PROG(NT-I+1)=RES(IEVOL,I) 245 : 23 CONTINUE 246 : ENDIF 247 : SEGDES MLREE2 248 : IPROGY=MLREE2 249 : WRITE(MOTY(11:12),'(I2)')IEVOL 250 : NOMEVY=MOTY(1:12) 251 : C 252 : NUMEVX=ICOUL 253 : NUMEVY='REEL' 254 : C 255 : SEGDES KEVOLL 256 : 30 CONTINUE 257 : C 258 : SEGDES MEVOLL 259 : SEGSUP MTRAV 260 : C 260 : CALL ECROBJ('EVOLUTIO',IPVO) 261 : 666 CONTINUE 262 : RETURN 263 : END 264 : 265 : 266 : 267 : 268 : 269 : 270 : 271 : 272 :
© Cast3M 2003 - All rights reserved.
Disclaimer