C PSRS SOURCE OF166741 25/02/20 21:17:29 12165 C PSRS SOURCE ISPRA 90/02/27 SUBROUTINE PSRS IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C======================================================================= C = CALCUL DU "RESPONSE SPECTRUM" A PARTIR DU "POWER SPECTRUM" = C = POUR PLUSIEURS AMORTISSEMENTS = C = = C = SYNTAXE : = C = = C = RSPE*EVOL = PSRS PSPE*EVOL TE *REEL AMOR*LISTREEL = C = (TT*LISTREEL MCL1*MOT MCL2*MOT = C = MCL3*MOT COUL*MOT ) = C = = C = = C = RSPE : OBJET DE TYPE EVOLUTIO CONTENANT LES = C = "RESPONSE SPECTRA" (NAMOR COURBES) = C = PSPE : OBJET DE TYPE EVOLUTIO CONTENANT LE "POWER SPECTRUM"= C = ( UNE COURBE SEULEMENT ) = C = TE : REEL DONNANT LA DUREE DU SIGNAL (SEC.) = C = AMOR : OBJET DE TYPE LISTREEL CONTENANT NAMOR AMORTISSEMENTS C = = C = MCL1 : GRANDEUR DE REPONSE: 'DEPL(ACEMENT)', 'VITE(SSE)' = C = : OU 'ACCE(LERATION)' (DEFAUT) = C = MCL2 : DISTRIBUTION: 'NEWG(UMG)' OU 'CRAM(ER)' = C = MCL3 : CHOIX DE L'ABSISSE DU "RESPONSE SPECTRUM" = C = : 'FREQ(UENCE)' OU 'PERI(ODE)' (DEFAUT) = C = : DANS LES 2 CAS LES VALEURS SONT RANGEES PAR VALEURS = C = CROISSANTES DES ABSCISSES (UTILATION DE IPOL!) = C = TT : OBJET DE TYPE LISTREEL CONTENANT LES PERIODES = C = COUL : COULEUR ATTRIBUEE A L'OBJET CREE (FACULTATIF) = C = ( DEFAUT = COULEUR DE PSRS) = C = = C = CREATION : 27/02/90, reprise 2/4/90 = C = MESSAGE D'ERREUR : 15/9/91 = C = PROGRAMMEUR : A.P. ET P.P. = C======================================================================= C CHARACTER *72 TI CHARACTER*12 MOTX,MOTY C PARAMETER (NMOCLE=7) CHARACTER*4 MOTCLE(NMOCLE) LOGICAL LPERIO,LUSER C -INC CCGEOME -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL C SEGMENT MTRAV IMPLIED F(NSPT),S(NSPT) ,ETI(NAMRT), T(NI), RES(NAMRT,NI) ENDSEGMENT C DATA MOTCLE/'PERI','FREQ','ACCE','VITE','DEPL','CRAM','NEWG'/ C C DEFAUT MCLE: "'PERI'->LPERIO, 'ACCE'->KGRAND, 'CRAM'->IDISTR C LPERIO=.TRUE. KGRAND=1 IDISTR=1 C C C LECTURE DE L'OBJET EVOLUTIO CONTENANT LE "POWER SPECTRUM" C CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET1) IF(IRET1.EQ.0) GOTO 666 C C LECTURE DU REEL DONNANT LA DUREE DU SIGNAL C CALL LIRREE(TE,1,IRET3) IF(IRET3.EQ.0) GOTO 666 C C LECTURE DE L'OBJET LISTREEL CONTENANT LES AMORTISSEMENT C CALL LIROBJ('LISTREEL',IPREE,1,IRET2) IF(IRET2.EQ.0) GOTO 666 C C LECTURE DE L'OBJET LISTREEL DONNANT LE TABLEAU DES PERIODES C DEFINI PAR L'UTILISATEUR C CALL LIROBJ('LISTREEL',IPREET,0,IRET4) IF(IRET4.EQ.0)THEN LUSER=.FALSE. ELSE LUSER=.TRUE. ENDIF C C LECTURE DES MOTS MCL1, MCL2, MCL3 ...ET DE LA COULEUR C * 1 CALL LIRMO2(MOTCLE,NMOCLE,IVAL, * > NCOUL ,NBCOUL,ICOUL,0) C 1 CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0) * WRITE(*,*) MOTCLE CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) * WRITE(*,*) NCOUL * WRITE(*,*) NBCOUL * WRITE(*,*) ICOUL IF (ICOUL.EQ.0) ICOUL=IDCOUL+1 ICOUL=ICOUL-1 IF(IVAL.EQ.0)GOTO 9 GOTO(2,3,4,4,4,5,5),IVAL C ---> "MCL3" 2 LPERIO=.TRUE. WRITE(*,*) 'Dans 2' GOTO 1 3 LPERIO=.FALSE. WRITE(*,*) 'Dans 3' GOTO 1 C ---> "MCL1" 1->ACCE, 2->VITE, 3->DEPL 4 KGRAND=IVAL-2 WRITE(*,*) 'Dans 4' GOTO 1 C ---> "MCL2" 1->CRAM, 2->NEWG 5 IDISTR=IVAL-5 WRITE(*,*) 'Dans 5' GOTO 1 C C LECTURE DE LA COULEUR C 9 IF(ICOUL.NE.0)GOTO 1 C IF(IERR.NE.0) GOTO 666 C C RECHERCHE DE LA TAILLE DU SEGMENT DE TRAVAIL C MEVOL1=IPSIG SEGACT MEVOL1 KEVOL1=MEVOL1.IEVOLL(1) SEGACT KEVOL1 C IF(ICOUL.EQ.0) ICOUL=KEVOL1.NUMEVX C MLREE3=KEVOL1.IPROGX SEGACT MLREE3 NSPT=MLREE3.PROG(/1) SEGDES MLREE3 C MLREE3=IPREE SEGACT MLREE3 NAMRT=MLREE3.PROG(/1) SEGDES MLREE3 C IF (LUSER)THEN MLREE3=IPREET SEGACT MLREE3 NI=MLREE3.PROG(/1) SEGDES MLREE3 NT=NI ELSE NI=75 NT=0 ENDIF C C CHARGEMENT DES TABLEAUX DE TRAVAIL C SEGINI MTRAV C MLREE1=KEVOL1.IPROGX MLREE2=KEVOL1.IPROGY SEGACT MLREE1,MLREE2 DO 10 I=1,NSPT F(I)=MLREE1.PROG(I) S(I)=MLREE2.PROG(I) 10 CONTINUE SEGDES MLREE1 SEGDES MLREE2 SEGDES KEVOL1 SEGDES MEVOL1 C MLREE3=IPREE SEGACT MLREE3 DO 11 I=1,NAMRT ETI(I)=MLREE3.PROG(I) 11 CONTINUE SEGDES MLREE3 C IF (LUSER)THEN MLREE3=IPREET SEGACT MLREE3 DO 12 I=1,NI T(I)=MLREE3.PROG(I) 12 CONTINUE SEGDES MLREE3 ENDIF C C CALCUL DU "RESPONSE SPECTRUM" C CALL POSPRE(MTRAV,NSPT,NAMRT, KGRAND,IDISTR,TE,NT) IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DU "RESPONSE SPECTRUM" ' C C ABSISSE EN PERIODE OU EN FREQUENCE C IF(LPERIO.AND.LUSER)THEN MLREE1=IPREET MOTX='PERIODE' ELSE JG=NT SEGINI MLREE1 IF(LPERIO)THEN DO 20 I=1,NT MLREE1.PROG(I)=T(I) 20 CONTINUE MOTX='PERIODE' ELSE DO 21 I=1,NT MLREE1.PROG(NT-I+1)=1/T(I) 21 CONTINUE MOTX='FREQUENCE' ENDIF SEGDES MLREE1 ENDIF C C LEGENDE (PARTIELLE) DES ORDONNEES C MOTY(1:10)='RSPE-'//MOTCLE(2+KGRAND)//' ' C C CREATION DE L'OBJET EVOLUTIO RSPE C N=NAMRT SEGINI MEVOLL IPVO=MEVOLL TI(1:72)=TITREE IEVTEX=TI ITYEVO='REEL' C DO 30 IEVOL=1,NAMRT C SEGINI KEVOLL C WRITE(TI,100)ETI(IEVOL) 100 FORMAT(1X,'AMORTISSEMENT DE ',1PD12.5) KEVTEX=TI C IEVOLL(IEVOL)=KEVOLL TYPX='LISTREEL' TYPY='LISTREEL' C IPROGX=MLREE1 NOMEVX=MOTX(1:12) C JG=NT SEGINI MLREE2 IF(LPERIO)THEN DO 22 I=1,NT MLREE2.PROG(I)=RES(IEVOL,I) 22 CONTINUE ELSE DO 23 I=1,NT MLREE2.PROG(NT-I+1)=RES(IEVOL,I) 23 CONTINUE ENDIF SEGDES MLREE2 IPROGY=MLREE2 WRITE(MOTY(11:12),'(I2)')IEVOL NOMEVY=MOTY(1:12) C NUMEVX=ICOUL NUMEVY='REEL' C SEGDES KEVOLL 30 CONTINUE C SEGDES MEVOLL SEGSUP MTRAV C CALL ECROBJ('EVOLUTIO',IPVO) 666 CONTINUE RETURN END