C PSCHPT    SOURCE    AM        08/02/14    21:28:02     6050           
      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 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*4 TYP,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