C PSACCE    SOURCE    CHAT      05/01/13    02:36:56     5004           
      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 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