C COPBA4    SOURCE    CHAT      05/01/12    22:19:35     5004           
      SUBROUTINE COPBA4(ITMOD,ITPSM)                                            
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)                                                  
************************************************************************        
*                                                                      *        
*     Projecte le champ base B des pseudo-modes sur la base modale.    *        
*                                                                      *        
*     Param}tres:                                                      *        
*                                                                      *        
* e   ITMOD   Table des modes de sous-type BASE_DE_MODES               *        
* es  ITPSM   Table des pseudo-modes                                   *        
*                                                                      *        
*                                                                      *        
*     Auteur, date de cr{ation:                                        *        
*                                                                      *        
*     Lionel VIVAN       Aout 1990                                     *        
*                                                                      *        
************************************************************************        
*                                                                               
      LOGICAL L0,L1                                                             
      CHARACTER*8 TYPRET,CHARRE                                                        
      CHARACTER*40 MONTYP                                                       
*                                                                               
      IPSM = 0                                                                  
 10   CONTINUE                                                                  
      IPSM = IPSM + 1                                                           
      TYPRET = ' '                                                              
      CALL ACCTAB(ITPSM,'ENTIER',IPSM,X0,' ',L0,IP0,                            
     &                  TYPRET,I1,X1,CHARRE,L1,ITTP)                               
      IF (TYPRET.EQ.'TABLE   ' .AND. ITTP.NE.0) THEN                            
         CALL ACCTAB(ITTP,'MOT',I0,X0,'SOUSTYPE',L0,IP0,                        
     &                    'MOT',I1,X1,MONTYP,L1,IP1)                            
*                                                                               
*        cas des forces concentr{es                                             
*                                                                               
         IF (MONTYP(1:9).EQ.'PSMO_FORC') THEN                                   
            CALL ACCTAB(ITTP,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,                 
     &                       'CHPOINT',I1,X1,' ',L1,ICHPT)                      
            CALL PROJTA(ICHPT,ITMOD,ICHPR)                                      
            CALL ECCTAB(ITTP,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,                 
     &                       'CHPOINT',I1,X1,' ',L1,ICHPR)                      
*                                                                               
*        cas des structures multisupport{es                                     
*                                                                               
         ELSE IF (MONTYP(1:9).EQ.'PSMO_DEPL') THEN                              
            CALL ACCTAB(ITTP,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,                 
     &                       'CHPOINT',I1,X1,' ',L1,ICHPT)                      
            CALL PROJTA(ICHPT,ITMOD,ICHPR)                                      
            CALL ECCTAB(ITTP,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,                 
     &                       'CHPOINT',I1,X1,' ',L1,ICHPR)                      
         ENDIF                                                                  
         GOTO 10                                                                
      ENDIF                                                                     
*                                                                               
      END