Sources Esope | Cast3M

psacce
C PSACCE    SOURCE    CB215821  20/11/25    13:37:47     10792          
      SUBROUTINE PSACCE(IRAID,IMASS,IMAIL,MTRAV,DIR, ICHP1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
************************************************************************
*
*                             P S A C C E
*                             -----------
*
* FONCTION:
* ---------
*
*     calcule le pseudo-mode en d{placement pour une acc{l{ration
*       sismique d'ensemble.
*
* MODULES UTILISES:
* -----------------
*
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMCHPOI
*
* PARAMETRES:   (e)=entr{e   (s)=sortie
* -----------
*
*     IRAID   (e)  pointeur sur la matrice K de la structure.
*     IMASS   (e)  pointeur sur la matrice M de la stuctureE.
*     IMAIL   (e)  pointeur sur le maillage de la structure.
*     MTRAV   (e)  pointeur sur les modes de la structure.
*     DIR     (e)  direction de l'excitation sismique.
*     ICHP1   (s)  pointeur sur le pseudo-mode en d{placement.
*
      CHARACTER*2 DIR
      SEGMENT MTRAV
        REAL*8 FREQ(NBMODE),MN(NBMODE),MW2(NBMODE),
     &         QX(NBMODE),QY(NBMODE),QZ(NBMODE)
        INTEGER DEPL(NBMODE)
      ENDSEGMENT
*
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     Lionel VIVAN       Juillet 1988
*
************************************************************************
*
      SEGMENT PSTRA
        REAL*8 QSMW2(NBMODE)
      ENDSEGMENT
*
      ICHP1  = 0
      SEGACT MTRAV
      NBMODE = FREQ(/1)
      SEGINI PSTRA
      IF (DIR .EQ. 'UX') THEN
         DO 4 I = 1,NBMODE
            QSMW2(I) = -1.D0 * QX(I) / MW2(I)
4        CONTINUE
      ELSE IF (DIR .EQ. 'UY') THEN
         DO 6 I = 1,NBMODE
            QSMW2(I) = -1.D0 * QY(I) / MW2(I)
6        CONTINUE
      ELSE
         DO 8 I = 1,NBMODE
            QSMW2(I) = -1.D0 * QZ(I) / MW2(I)
8        CONTINUE
      ENDIF
*
*     r{solution du syst}me statique
*
*     est-on en axisym{trique ?
*
      IF (IFOUR.EQ.0 .OR. IFOUR.EQ.1) THEN
         IF (DIR .EQ. 'UX') THEN
            CALL ECRREE(1.D0)
            CALL ECRCHA('UT')
            CALL ECRREE(-1.D0)
            CALL ECRCHA('UR')
            CALL ECRENT(2)
            CALL ECROBJ('MAILLAGE',IMAIL)
            CALL MANUCH
            IF (IERR.NE.0) RETURN
            CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
            IF (IERR.NE.0) RETURN
         ELSE IF (DIR .EQ. 'UY') THEN
            CALL ECRREE(-1.D0)
            CALL ECRCHA('UT')
            CALL ECRREE(-1.D0)
            CALL ECRCHA('UR')
            CALL ECRENT(2)
            CALL ECROBJ('MAILLAGE',IMAIL)
            CALL MANUCH
            IF (IERR.NE.0) RETURN
            CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
            IF (IERR.NE.0) RETURN
         ELSE
            CALL ECRREE(-1.D0)
            CALL ECRCHA('UZ')
            CALL ECRENT(1)
            CALL ECROBJ('MAILLAGE',IMAIL)
            CALL MANUCH
            IF (IERR.NE.0) RETURN
            CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
            IF (IERR.NE.0) RETURN
         ENDIF
*
         MCHPOI = ICHPT
         SEGACT MCHPOI
         IFOPOI = IFOUR
         NS = IPCHP(/1)
         DO 10 I = 1,NS
            MSOUPO = IPCHP(I)
            SEGACT MSOUPO
            NC = NOHARM(/1)
            DO 20 IC = 1,NC
               IF (IFOUR .EQ. 1) THEN
                  IF (DIR .EQ. 'UX') THEN
                     NOHARM(IC) = 1
                  ELSE IF (DIR .EQ. 'UY') THEN
                     NOHARM(IC) = -1
                  ELSE
                     NOHARM(IC) = 0
                  ENDIF
               ELSE
                  NOHARM(IC) = 0
               ENDIF
20          CONTINUE
            SEGDES MSOUPO
10       CONTINUE
         SEGDES MCHPOI
      ELSE
         CALL ECRREE(-1.D0)
         CALL ECRCHA(DIR)
         CALL ECRENT(1)
         CALL ECROBJ('MAILLAGE',IMAIL)
         CALL MANUCH
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('CHPOINT ',ICHPT,1,IRETOU)
         IF (IERR.NE.0) RETURN
      ENDIF
*
      CALL MUCPRI(ICHPT,IMASS,ICHP2)
      IF (IERR.NE.0) RETURN
*
      CALL ECROBJ('CHPOINT ',ICHP2)
      CALL ECROBJ('RIGIDITE',IRAID)
      CALL RESOU
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('CHPOINT ',ICHPST,1,IRETOU)
      IF (IERR.NE.0) RETURN
*
*     r{solution du syst}me dynamique
*
      DO 30 ID = 1,NBMODE
         XFLOT = QSMW2(ID)
         IPHI = DEPL(ID)
         IF (ID .EQ. 1) THEN
            CALL MUCHPO(IPHI,XFLOT,ICHPDY,1)
            IF (IERR.NE.0) RETURN
         ELSE
            CALL ADCHPO(ICHPDY,IPHI,ICHP3,1D0,XFLOT)
            IF (IERR.NE.0) RETURN
            CALL DECHPO(ICHPDY)
            IF (IERR.NE.0) RETURN
            ICHPDY = ICHP3
         ENDIF
30    CONTINUE
*
*     calcul du pseudo-mode
*
      CALL ADCHPO(ICHPST,ICHPDY,ICHP1,1D0,-1D0)
      IF (IERR.NE.0) RETURN
*
*     destruction
*
      CALL DECHPO(ICHPST)
      IF (IERR.NE.0) RETURN
      CALL DECHPO(ICHPDY)
      IF (IERR.NE.0) RETURN
      CALL DECHPO(ICHPT)
      IF (IERR.NE.0) RETURN
*
      SEGSUP PSTRA
      SEGDES MTRAV
*
      END