Sources Esope | Cast3M

seisme
C SEISME    SOURCE    CB215821  25/04/23    21:15:45     12247          
      SUBROUTINE SEISME
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C**************************************************************
C     SOUS PROGRAMME ASSOCIE A L OPERATEUR SEISME
C
C     26/06/86  AUTEUR D. BROCHARD (VIBR) TEL 6994
C
C
C     CREATION D UN OBJET CHARGEMENT A PARTIR D UN OBJET
C     EVOLUTION, D UN OBJET BASE MODALE,D UN OBJET FLOTTANT,
C     D UN MOT.
C
C     SYNTAXE
C     _______
C
C        CHARG = SEISME  EVOL | BASEM | COEF  MOT
C                             | TBAS  |
C
C     REMARQUE
C     --------
C
C     AU 26/06/86 CET OPERATEUR NE FONCTIONNE QUE POUR LES
C     BASES MODALES.IL GENERE UN CHAMP-POINT QUI REPRESENTE LA
C     REPARTITION SPATIALE (SUR LES ALFA) DU CHARGEMENT SISMIQUE.
C     CE CHAMP MULPIPLIE PAR LA FONCTION DE TEMPS DONNE LES FORCES
C     GENERALISEES.
C
C*******************************************************************
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMBASEM
-INC SMCHPOI
-INC SMCOORD
-INC SMCHARG
-INC SMSOLUT
C
      LOGICAL BASMUL,L0,L1
      PARAMETER (LNOM=3)
      CHARACTER*4 NOM(LNOM)
      CHARACTER*8 CTYP,TYPRET,CHARRE
      DATA  NOM/'UX  ','UY  ','UZ  '/
      BASMUL = .FALSE.
C
C     LECTURE DONNEES
C
      CALL LIROBJ('EVOLUTIO',MEVOLL,1,IRETOU)
      CALL LIRREE(DFLOT,1,IRETOU)
      COEF=DFLOT
      CALL LIRMOT(NOM,LNOM,IMOT,1)
      IF (IERR.NE.0) RETURN
C
C     CALCUL DE LA POSITION DU QN (DEPLACEMENT GENERALISE
C
      IF (IMOT.EQ.1) THEN
         IPLAC=3
      ELSE IF (IMOT.EQ.2) THEN
         IPLAC=4
      ELSE
         IPLAC=5
      ENDIF
      IPLA2 = IPLAC - 2
*
      CALL QUETYP(CTYP,1,IRETOU)
*
      IF (CTYP(1:8).EQ.'TABLE   ') THEN
         CALL LIRTAB('BASE_MODALE',ITBAS,0,IRET)
         IF (IRET.EQ.0) THEN
            CALL LIRTAB('ENSEMBLE_DE_BASES',ITBAS,1,IRET)
            BASMUL = .TRUE.
         ENDIF
         IF (IERR.NE.0) RETURN
         IF ( BASMUL ) THEN
            IB = 0
 10         CONTINUE
            IB = IB + 1
            TYPRET = ' '
            CALL ACCTAB(ITBAS,'ENTIER',IB,X0,' ',L0,IP0,
     &                          TYPRET,I1,X1,CHARRE,L1,ITTBAS)
            IF (ITTBAS.NE.0 .AND. TYPRET.EQ.'TABLE   ') THEN
               CALL ACCTAB(ITTBAS,'MOT',I0,X0,'MODES',L0,IP0,
     &                          'TABLE',I1,X1,' ',L1,IBAS)
               CALL SEISM2(IBAS,IPLA2,ICHP2)
               IF (IERR.NE.0) RETURN
               IF (IB.EQ.1) THEN
                  ICHPT = ICHP2
               ELSE
                  CALL ADCHPO(ICHPT,ICHP2,ICHP3,1D0,1D0)
                  CALL DECHPO(ICHPT)
                  CALL DECHPO(ICHP2)
                  IF (IERR.NE.0) RETURN
                  ICHPT = ICHP3
               ENDIF
               GOTO 10
            ENDIF
         ELSE
            CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
     &                      'TABLE',I1,X1,' ',L1,IBAS)
            CALL SEISM2(IBAS,IPLA2,ICHPT)
            IF (IERR.NE.0) RETURN
         ENDIF
         GOTO 2000
      ENDIF
*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*
*                  version appel{e @ disparaitre
*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*
      CALL LIROBJ('BASEMODA',MBASEM,1,IRETOU)
C
C     LECTURE DE LA BASE MODALE ET CREATION D UN CHPO DE
C     COMPOSANTE QN SUR FALF  ASSOCIE AU MELEME DE LA BASE MODALE
C
      SEGACT MBASEM
      NBAS=LISBAS(/1)
      NSOUPO=NBAS
C
      NAT=1
      SEGINI MCHPOI
C   si c'est un chargement il s'agit du second membre de nature discr
      JATTRI(1) = 2
      ICHPT = MCHPOI
      IFOPOI=IFOUR
C
      DO 201 NN=1,NBAS
         NC=1
C
         SEGINI MSOUPO
         MSOBAS=LISBAS(NN)
C
         SEGACT MSOBAS
         MSOLUT=IBSTRM(2)
C
         SEGACT MSOLUT
         MELEME=MSOLIS(3)
         MSOLEN=MSOLIS(4)
C
         SEGACT MSOLEN
         NBMOD=ISOLEN(/1)
C
         N=NBMOD
         SEGINI MPOVAL
C
         DO 202 NMOD=1,NBMOD
            MMODE=ISOLEN(NMOD)
C
            SEGACT MMODE
*
*   COEF EST MULTIPLIE A ICHAFO
*   POUR POUVOIR RECONNAITRE LE QI DE CE CHARGEMENT
*   LORS DE LA RECOMBINAISON DES PSEUDO-MODES.
*
            QI = -1.D0 * FMMODD(IPLAC)
            VPOCHA(NMOD,1)=QI
            SEGDES MMODE
202      CONTINUE
C
         SEGDES MPOVAL
         IPOVAL=MPOVAL
         NOHARM(1)=NIFOUR
         NOCOMP(1)='FALF'
         IGEOC=MELEME
         SEGDES MSOUPO
C
         IPCHP(NN)=MSOUPO
         SEGDES MSOBAS,MSOLUT,MSOLEN
201   CONTINUE
C
      SEGDES MBASEM
C
      SEGDES MCHPOI
*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*
 2000 CONTINUE
C
C     CREATION DU CHARG. EN ASSOCIANT AU CHPO LA FONCTION DE TEMPS
C     L OBJET EVOLUTION
C
      N=1
      SEGINI MCHARG
      SEGINI ICHARG
      SEGACT MEVOLL
      KEVOLL=IEVOLL(1)
      SEGACT KEVOLL
      CHANAT(1)='FORCE'
      CHANOM(1) = '   1'
      CHAMOB(1)='STAT'
      CHALIE(1)='LIE '
      CHATYP = 'CHPOINT '
      ICHPO1=ICHPT
      ICHPO2=IPROGX
      IPPP = IPROGY
      CALL MUFLIR(IPPP,COEF,IPY,1)
      ICHPO3=IPY
c ICHPO4, ICHPO5, ICHPO6 et ICHPO7 ne sont pas initialises
      SEGDES KEVOLL,MEVOLL
      SEGDES ICHARG
      KCHARG(1)=ICHARG
      SEGDES MCHARG
C
      CALL ECROBJ('CHARGEME',MCHARG)
C
      END