Sources Esope | Cast3M

psrs
C PSRS      SOURCE    PV        21/04/26    21:15:22     10978          
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