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 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