Sources Esope | Cast3M

pschoc
C PSCHOC    SOURCE    CHAT      05/01/13    02:37:16     5004
      SUBROUTINE PSCHOC(IRAID,MTRAV,IPCH,NORM,IJ, ICHP1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
************************************************************************
*
*                             P S C H O C
*                             -----------
*
* FONCTION:
* ---------
*
*     calcule le pseudo-mode en d{placement pour une force de choc.
*
* MODULES UTILISES:
* -----------------
*
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC SMCOORD
*
* PARAMETRES:   (e)=entr{e   (s)=sortie
* -----------
*
*     IRAID   (e)  pointeur sur la matrice K de la structure.
*     MTRAV   (e)  pointeur sur un segemnt contenant les modes.
*     IPCH    (e)  point de choc.
*     NORM    (e)  normale de choc.
*     IJ      (e)  point de la structure IJ
*     ICHP1   (s)  pointeur sur le pseudo-mode en d{placement.
*
*
      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
*
************************************************************************
*
      ICHP1  = 0
*
*     normalisation de la normale
*
      IPNV = (IDIM + 1) * (NORM - 1)
      PS = 0.D0
      DO 10 ID = 1,IDIM
         XC = XCOOR(IPNV + ID)
         PS = PS + XC * XC
 10   CONTINUE
      IF (PS.LT.XPETIT) THEN
         CALL ERREUR(162)
         RETURN
      ENDIF
      RACPS = SQRT(PS)
      XX = XCOOR(IPNV + 1) / RACPS
      XY = XCOOR(IPNV + 2) / RACPS
      IF (IDIM.EQ.3) THEN
         XZ = XCOOR(IPNV + 3) / RACPS
      ENDIF
      IF (IJ.EQ.2) THEN
         XX = -1.D0 * XX
         XY = -1.D0 * XY
         IF (IDIM.EQ.3) THEN
            XZ = -1.D0 * XZ
         ENDIF
      ENDIF
*
*     liste des composantes
*
      IF (IDIM.EQ.3) THEN
         CALL ECRCHA('UZ')
      ENDIF
      CALL ECRCHA('UY')
      CALL ECRCHA('UX')
      CALL MOTS
      CALL LIROBJ('LISTMOTS',IMOT1,1,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IDIM.EQ.3) THEN
         CALL ECRCHA('FZ')
      ENDIF
      CALL ECRCHA('FY')
      CALL ECRCHA('FX')
      CALL MOTS
      CALL LIROBJ('LISTMOTS',IMOT2,1,IRETOU)
      IF (IERR.NE.0) RETURN
*
*     cr{ation du chpoint force
*
      IF (IDIM.EQ.3) THEN
         CALL ECRREE(XZ)
         CALL ECRCHA('FZ')
      ENDIF
      CALL ECRREE(XY)
      CALL ECRCHA('FY')
      CALL ECRREE(XX)
      CALL ECRCHA('FX')
      CALL ECRENT(IDIM)
      CALL ECROBJ('POINT',IPCH)
      CALL ECRCHA('CHPO')
      CALL MANUEL
      CALL LIROBJ('CHPOINT ',ICHP2,1,IRETOU)
      IF (IERR.NE.0) RETURN
*
      SEGACT MTRAV
      NBMODE = FREQ(/1)
*
*     r{solution du syst}me statique
*
      CALL ECROBJ('CHPOINT ',ICHP2)
      CALL ECROBJ('RIGIDITE',IRAID)
      CALL RESOU
      CALL LIROBJ('CHPOINT ',ICHPST,1,IRETOU)
      IF (IERR.NE.0) RETURN
*
*     r{solution du syst}me dynamique
*
      DO 70 ID = 1,NBMODE
         IPHI = DEPL(ID)
         CALL XTY1(IPHI,ICHP2,IMOT1,IMOT2,XPHINF)
         IF (IERR.NE.0) RETURN
         XFLOT = XPHINF / MW2(ID)
         IF (ID .EQ. 1) THEN
            CALL MUCHPO(IPHI,XFLOT,ICHPDY,1)
            IF (IERR.NE.0) RETURN
         ELSE
            CALL ADCHPO(ICHPDY,IPHI,ICHP4,1D0,XFLOT)
            IF (IERR.NE.0) RETURN
            CALL DECHPO(ICHPDY)
            IF (IERR.NE.0) RETURN
            ICHPDY = ICHP4
         ENDIF
70    CONTINUE
*
*     calcul du pseudo-mode
*
      CALL ADCHPO(ICHPST,ICHPDY,ICHP1,1D0,-1D0)
      IF (IERR.NE.0) RETURN
      CALL DECHPO(ICHPST)
      IF (IERR.NE.0) RETURN
      CALL DECHPO(ICHPDY)
      IF (IERR.NE.0) RETURN
*
      SEGDES MTRAV
*
      END