C PSCHPT    SOURCE    CB215821  20/11/25    13:37:50     10792          
      SUBROUTINE PSCHPT(IRAID,IMASS,MTRAV,ICHPT,TYP,ICHP1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
************************************************************************
*
*                             P S C H P T
*                             -----------
*
* FONCTION:
* ---------
*
*     calcule le pseudo-mode en d{placement pour un CHPOINT.
*
* MODULES UTILISES:
* -----------------
*
-INC CCHAMP

-INC PPARAM
-INC CCOPTIO
-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 structure.
*     MTRAV   (e)  pointeur sur un segment contenant les modes.
*     ICHPT   (e)  pointeur sur le chpoint force.
*     TYP     (e)  = 'FORC', chpoint de type force.
*                  = 'DEPL', chpoint de type d{placement.
*     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
*
*
* VARIABLES:
* ----------
*
      CHARACTER*(*)      TYP
      CHARACTER*(LOCOMP) NOM,LNOM
*
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     Lionel VIVAN       Avril 1990
*
************************************************************************
*
      ICHP1  = 0
*
      IF (TYP.EQ.'FORC') THEN
         I5 = 1
         CALL COPIE2(ICHPT,ICHP2)
         MCHPOI = ICHP2
         SEGACT MCHPOI
         NSOU = IPCHP(/1)
         DO 10 I = 1,NSOU
            MSOUPO = IPCHP(I)
            SEGACT MSOUPO
            NC = NOCOMP(/2)
*
*           liste des composantes
*
            DO 20 I4 = 1,NC
               NOM = NOCOMP(I4)
               CALL PLACE(NOMDU,40,INOM,NOM)
               LNOM = NOMDD(INOM)
               IF (I4.EQ.1 .AND. I.EQ.1) THEN
                  CALL ECRCHA(NOM)
                  CALL MOTS
                  IF (IERR.NE.0) RETURN
                  CALL LIROBJ('LISTMOTS',IMOT1,1,IRETOU)
                  IF (IERR.NE.0) RETURN
                  CALL ECRCHA(LNOM)
                  CALL MOTS
                  IF (IERR.NE.0) RETURN
                  CALL LIROBJ('LISTMOTS',IMOT2,1,IRETOU)
                  IF (IERR.NE.0) RETURN
               ELSE
                  I5 = I5 + 1
                  CALL INSER3(IMOT1,I5,NOM)
                  IF (IERR.NE.0) RETURN
                  CALL INSER3(IMOT2,I5,LNOM)
                  IF (IERR.NE.0) RETURN
               ENDIF
 20            CONTINUE
*           end do
            SEGDES MSOUPO
 10         CONTINUE
*           end do
         SEGDES MCHPOI
      ENDIF
*
      SEGACT MTRAV
      NBMODE = FREQ(/1)
*
*     r{solution du syst}me statique
*
      IF (TYP.EQ.'DEPL') THEN
         CALL MUCHPO(ICHPT,-1.D0,ICHP3,1)
         IF (IERR.NE.0) RETURN
         CALL MUCPRI(ICHP3,IMASS,ICHP2)
         IF (IERR.NE.0) RETURN
         CALL DECHPO(ICHP3)
         IF (IERR.NE.0) RETURN
      ENDIF
      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
         IPHI = DEPL(ID)
         IF (TYP.EQ.'FORC') THEN
            CALL XTY1(IPHI,ICHP2,IMOT2,IMOT1,XPHINF)
            IF (IERR.NE.0) RETURN
            XFLOT = XPHINF / MW2(ID)
         ELSE IF (TYP.EQ.'DEPL') THEN
            CALL YTMX(IPHI,ICHPT,IMASS,RNI)
            IF (IERR.NE.0) RETURN
            XFLOT = -1.D0 * RNI / MW2(ID)
         ENDIF
         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
 30      CONTINUE
*     end do
*
*     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
      CALL DECHPO(ICHP2)
      IF (IERR.NE.0) RETURN
*
      SEGDES MTRAV
*
      END