Sources Esope | Cast3M

spon
C SPON      SOURCE    BP208322  16/11/18    21:21:18     9177           
      SUBROUTINE SPON
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER*72 TI
      CHARACTER*(4) CMOT
C
C     ========================================================
C                                                            =
C     SPECTRES NON LINEAIRES D' OSCILLATEUR                  =
C                                                            =
C     SYNTAXE : EVOL = SPON 'SIGN' EVOL1 'SPEL' EVOL2 MOTENTR=
C                                                            =
C                      'AMOR' LAMOR  'PROP' LPROP            =
C                                                            =
C                      ('COUL' COOL)  SORTIE                 =
C                                                            =
C     CREATION : 1990/06/15                                  =
C     PROGRAMMEUR : A.PINTO $ P.PEGON (CEC-JRC ISPRA)        =
C                   (BASE : SUBROUTINE SPO)                  =
C     7/90                                                   =
C     ========================================================
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMLREEL
-INC CCGEOME
*-
-INC CCREEL
      PARAMETER (LMOT=13)
 
      CHARACTER*4 MODOM(13)
      CHARACTER*12 ITITY(4)
      DATA MODOM/'DEMA','SIGN','SPEL','AMOR',
     1            'TAKE','ISOT','CINE','ELAS',
     &            'COUL','DEPL','VITE','ACCE','EPSE'/
      DATA ITITY /'DEPL MAXIMAU','PSEUDO VITES','PSEUDO ACCEL',
     &             'DEFNL CUMULE'/
      IPAMOR=0
      IPPROP=0
      ICOUL1=IDCOUL
      IPOEVO=0
      IPSPEV=0
      idema = 0
      N0=-1
C
C     LECTURE DES OBJETS
C     ==================
C
 
      DO 10 I=1,13
      CALL LIRMOT(MODOM,LMOT,IPLAC,0)
      IF (IPLAC.EQ.0) GOTO 12
C
  8   GOTO (20,21,22,23,24,24,24,24,
     &                 25,26,26,26,26),IPLAC
C
 
   20  continue
       idema = 1
       goto 10
   21  CONTINUE
C
C     TEMPS ET ACCELERATION DU SIGNAL (OBJET EVOLUTION)
C
      CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET)
        IF (IRET.EQ.0) RETURN
      GOTO 10
C
   22  CONTINUE
C
C     SPECTRES LINEAIRES (OBJET EVOLUTION)
C
      CALL LIROBJ ('EVOLUTIO',IPSPEV,1,IRET)
        IF (IRET.EQ.0) RETURN
C
C     TYPE DES SPECTRES LINEAIRES (OBJET MOT)
C         ( 'DEPL', 'VITE', 'ACCE' )
C
      CALL LIRMOT(MODOM(10),3,ITYP,1)
      IF (ITYP.EQ.0) RETURN
      NN0=ITYP-1
        GOTO 10
C
   23   CONTINUE
C
C     AMORTISSEMENT
C
      CALL LIROBJ ('LISTREEL',IPAMOR,1,IRET)
        IF (IRET.EQ.0) RETURN
      GOTO 10
C
   24   CONTINUE
C
C     PROPRIETES
C
      imod = iplac - 4
      CALL LIROBJ ('LISTREEL',IPPROP,1,IRET)
        IF (IRET.EQ.0) RETURN
      GOTO 10
C
   25   CONTINUE
C
C     COULEURS
C
      CALL LIRMOT (NCOUL,NBCOUL,ICOUL1,1)
      IF (ICOUL1.EQ.0) RETURN
      icoul1=icoul1-1
      GOTO 10
C
  26  CONTINUE
C
C      TYPE DE LA REPONSE (SORTIE)
C
      N0=IPLAC-10
      GOTO 10
C
  10  CONTINUE
  12  CONTINUE
C
C     ON VERIFIE L' EXISTENCE DES DONNES
C     ==================================
C
      IF (IPOEVO.EQ.0)THEN
        CALL ERREUR(588)
        RETURN
      ENDIF
C
      IF (IPSPEV.EQ.0)THEN
        CALL ERREUR(589)
        RETURN
      ENDIF
C
      IF (N0.EQ.-1)THEN
        CALL ERREUR(590)
        RETURN
      ENDIF
C
      IF (IPAMOR.EQ.0 ) THEN
        CALL ERREUR(361)
        RETURN
      ENDIF
C
      IF (IPPROP.EQ.0 ) THEN
        CALL ERREUR(591)
        RETURN
      ENDIF
C
C     ON VERIFIE LA CONSISTENCE DES DONNES
C     ====================================
C
C     AMORTISSEMENT
C
      MLREEL=IPAMOR
      SEGACT MLREEL
      NNBAM=PROG(/1)
      DO 11 NBAM=1,NNBAM
      IF (PROG(NBAM).LT.0.OR.PROG(NBAM).GE.1) THEN
           MOTERR(1:8)='AMORTISS'
           REAERR(1)=PROG(NBAM)
           REAERR(2)=0.
           REAERR(3)=1.
           SEGDES MLREEL
           CALL ERREUR(42)
           RETURN
      ENDIF
 11   CONTINUE
      SEGDES MLREEL
C
C     PROPRIETES
C
      MLREEL=IPPROP
      SEGACT MLREEL
      NNPRO=PROG(/1)
        IF (NNPRO.NE.5 .and.imod.eq.1) THEN
            INTERR(1)=5
            CALL ERREUR(592)
            SEGDES MLREEL
            RETURN
       else if (NNPRO.NE.2 .and.imod.ne.1) then
            INTERR(1)=2
            CALL ERREUR(592)
            SEGDES MLREEL
            RETURN
       else if (NNPRO.eq.2 .and.imod.ne.1) then
* modele bilineaire elastoplastique ou elastique
* on met n'importe quoi dans les 3 parametres qui servent à rien
          alfa = 0.d0
          beta = 0.d0
          gama = 0.d0
        ENDIF
      IF (PROG(1).LT.1) THEN
           CALL ERREUR(593)
           SEGDES MLREEL
           RETURN
      ENDIF
      IF (abs(PROG(2)).GT.1. and. imod.ne.4) THEN
           CALL ERREUR(594)
           SEGDES MLREEL
           RETURN
      ENDIF
      IF (PROG(2).LT.0D0 .AND. IMOD.EQ.1) THEN
           MOTERR='TETA'
           CALL ERREUR(595)
           SEGDES MLREEL
           RETURN
      ENDIF
      if (imod.eq.1) then
      IF (PROG(3).LT.0) THEN
           MOTERR='ALFA'
           CALL ERREUR(595)
           SEGDES MLREEL
           RETURN
      ENDIF
      IF (PROG(4).LT.0) THEN
           MOTERR='BETA'
           CALL ERREUR(595)
           SEGDES MLREEL
           RETURN
      ENDIF
      IF (PROG(5).LT.0) THEN
           MOTERR='GAMA'
           CALL ERREUR(595)
           SEGDES MLREEL
           RETURN
      ENDIF
      endif
C
C     PROPRIETES: TOUT EN ORDE
C
        DUCT=PROG(1)
        TETA=PROG(2)
      if (imod.eq.1) then
        ALFA=PROG(3)
        BETA=PROG(4)
        GAMA=PROG(5)
      endif
      SEGDES MLREEL
C
C     LE SIGNAL
C
      MEVOLL=IPOEVO
      SEGACT MEVOLL
      KEVOLL=IEVOLL(1)
      SEGACT KEVOLL
      MLREEL=IPROGX
      SEGACT MLREEL
      ILONT=PROG(/1)
      TE=PROG(ILONT)-PROG(1)
      DTEMPO=TE/(ILONT-1.)
      DT=PROG(2)-PROG(1)
      DTT=DTEMPO-DT
           IF (ABS(DTT).GT.1.D-6) THEN
           CALL ERREUR(568)
           SEGDES MLREEL
           SEGDES KEVOLL
           SEGDES MEVOLL
           RETURN
           ENDIF
      IPT=IPROGX
      IPG=IPROGY
      SEGDES MLREEL
      SEGDES KEVOLL
      SEGDES MEVOLL
C
C     ON RECOUPERE LE NB. DE SPECTRES
C
      MEVOLL=IPSPEV
      SEGACT MEVOLL
           NBCOUR=IEVOLL(/1)
      SEGDES MEVOLL
C
C     ON COMPARE LE NB. D'AMORTISSEMENTS AVEC LE NB. DE SPECTRES
C
           IF (NBCOUR.NE.NNBAM) THEN
           CALL ERREUR(596)
           RETURN
           ENDIF
C
C     ON COMMENCE FINALEMENT !!!
C     ==========================
C
      MLREEL=IPAMOR
      SEGACT MLREEL
      N1=PROG(/1)
      N=N1
      SEGINI MEVOLL
      IPEVOF=MEVOLL
C
             MLREE3=IPT
             SEGACT MLREE3
             LONT=MLREE3.PROG(/1)
             TPS=MLREE3.PROG(LONT)
             SEGDES MLREE3
C
        MEVOL1=IPSPEV
        SEGACT MEVOL1
C
C     BOUCLE SUR LES DIFFERENTS AMORTISSEMENTS
C
      DO 100 I=1,N1
C     MLREEL=IPAMOR
      XSI=PROG(I)
C
        KEVOL1=MEVOL1.IEVOLL(I)
        SEGACT KEVOL1
        MLREE1=KEVOL1.IPROGX
        MLREE3=KEVOL1.IPROGY
        SEGDES KEVOL1
        SEGACT MLREE1
        SEGACT MLREE3
C
        N2=MLREE1.PROG(/1)
      M=0
      IAUX=0
 
C
C
C        BOUCLE SUR LES FREQUENCES
C
      JG=N2
      SEGINI MLREE2
      IPSPO=MLREE2
C
      DO 101 J=1,N2
      DFREQ=MLREE1.PROG(J)
      AUX=1/(10.*DFREQ)
      IF (DT.GT.AUX) THEN
      IF (IAUX.EQ.0) THEN
      DPERIO=1/DFREQ
      IAUX=1
      ENDIF
      ENDIF
      W=2*XPI*DFREQ
      W2=W*W
C
        SPECTL=MLREE3.PROG(J)
 
C
      IF (NN0.EQ.0) DISMAX=SPECTL
      IF (NN0.EQ.1) DISMAX=SPECTL/W
      IF (NN0.EQ.2) DISMAX=SPECTL/W2
C
C     APPEL A LA SUBROUTINE CONTENANT L'ALGORITHME
C
      CALL INOSC2(IPT,IPG,DFREQ,XSI,RMAX,TMAX,
     1   DISMAX,DUCT,ALFA,BETA,GAMA,TETA,imod,idema,xepse)
 
C
      IF (TMAX.GT.TPS) M=M+1
C     MLREE2=IPSPO
      IF (N0.EQ.0) MLREE2.PROG(J)=RMAX
      IF (N0.EQ.1) MLREE2.PROG(J)=W*RMAX
      IF (N0.EQ.2) MLREE2.PROG(J)=W2*RMAX
      IF (N0.EQ.3) MLREE2.PROG(J)=XEPSE
  101    CONTINUE
C
      SEGINI KEVOLL
      IEVOLL(I)=KEVOLL
      TYPX='LISTREEL'
      TYPY='LISTREEL'
      IPROGX=MLREE1
      IPROGY=IPSPO
      NOMEVX='FREQUENCE'
      NOMEVY=ITITY(N0+1)
      NUMEVX=ICOUL1
      NUMEVY='REEL'
      TI(1:72)=TITREE
      IEVTEX=TI
      ITYEVO='REEL'
c       KEVTEX=TI
      KEVTEX=NOMEVY
      SEGDES KEVOLL
      SEGDES MLREE2
      SEGDES MLREE1
      SEGDES MLREE3
  100 CONTINUE
C
   38 FORMAT(1X,'SPON : POUR L AMORTISSEMENT',E12.5/
     >1X,'       IL Y A',I5,3X,'DEPLACEMENTS MAXIMAUX'/
     >1X,'       APRES LA FIN DU SIGNAL')
300   FORMAT(1X,'SPON : POUR L AMORTISSEMENT',E12.5/
     >1X,'       POUR LES FREQUENCES ( F ) >',E12.5/
     >1X,'       ( PERIODES ( T ) ) &lt;',E12.5/
     >1X,'       LA CONDITION ( DT &lt; 1/(10*F) )  (ACCURACY)'/
     >1X,'       N EST PAS VERIFIE')
C
      SEGDES MEVOLL
      SEGDES MLREEL
        SEGDES MEVOL1
C
C
      CALL ECROBJ ('EVOLUTIO',IPEVOF)
      RETURN
      END