C PJBA      SOURCE    BP208322  13/10/10    21:15:06     7837           
      SUBROUTINE PJBA
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C=======================================================================
C OPERATEUR PJBA :
C           PROJECTION D'UN CHPOINT, D'UN CHARGEMENT OU D'UNE RIGIDITE
C           SUR LES ELEMENTS D'UNE BASE MODALE B.
C           LE RESULTAT EST DU MEME TYPE.
C
C SYNTAXE :
C       *   FN  =  PJBA  B   OBJET           ;   SI BASE ELEMENTAIRE
C       *   FN  =  PJBA  B  STR1  (N)  OBJET ;   SI BASE COMPLEXE
C
C         OBJET    POUVANT ETRE UNE FORCE OU UN CHARGEMENT,
C                  OU UNE RIGIDITE DANS LE PREMIER CAS.
C
C         STR1     EST LA SOUS-STRUCTURE OU S'APPLIQUE L'OBJET.
C         N        EST LE NUMERO DE LA SOUS-STRUCTURE SI CELLE-CI EST
C                  FORMEE DE SOUS-STRUCTURES IDENTIQUES .
C
C
C CAS PARTICULIER DES GRANDS DEPLACEMENTS SUR BASE TOURNANTE :
C ----------------------------------------------------------
C
C     SI    LA FORCE N'EST PAS LIEE A LA BASE ( EX : LA PESANTEUR )
C            IL FAUT SPECIFIER LE MOT-CLEF ......... LIBR
C    ALORS  FN EST UN OBJET LISTCHPO CONTENANT LES VECTEURS DE
C            DECOMPOSITION DE LA FORCE GENERALISEE F
C
C=======================================================================
-INC SMBASEM
-INC SMCHPOI
-INC SMCHARG
-INC SMLCHPO
-INC SMSOLUT
-INC SMSTRUC
-INC CCOPTIO
C
      LOGICAL L0,L1,CHAR,TABL
      CHARACTER*4 LIBR(1),CLE(1)
      CHARACTER*72 lemot
      DATA CLE(1)/'REEL'/
      DATA LIBR(1) /'LIBR'/
      NLIBR = 1
      TABL = .FALSE.
C
      call lirobj('MMODEL ',IPMODE,0,iretou)
       if (iretou.ne.0) then
        call pjmode(ipmode)
        return
       endif
    
      CALL LIROBJ('RIGIDITE',MRIGID,0,IRETOU)
      IF (IERR.NE.0) RETURN

C---- Cas d'une rigidite -----------------------------------------------
      IF (IRETOU.NE.0) THEN

        CALL LIROBJ('TABLE   ',MTAB1,1,IRETOU)
        IF (IERR.NE.0) RETURN
        CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &        'MOT',IP,RR,lemot,.TRUE.,IQ)
       if (lemot.eq.'BASE_MODALE') then
        CALL LIRMOT(CLE,1,ICLE,0)
        CALL PROJRG(MRIGID,MTAB1,ICLE,MRIG1,MRIG2)
        if (ierr.ne.0) return
        IF (MRIG2.NE.0) CALL ECROBJ('RIGIDITE',MRIG2)
       elseif (lemot.eq.'LIAISONS_STATIQUES') then
        call probas(MRIGID,MTAB1,MRIG1)
        if (ierr.ne.0) return
          call proba2(MTAB1,MRIG2)
          if (ierr.ne.0) return
          if (mrig2.gt.0.and.mrig1.gt.0) then
           call fusrig(mrig1,mrig2,mrig3)
           mrig1 = mrig3
           mrig2 = 0
          endif
          if (mrig2.gt.0) mrig1 = mrig2
          if (mrig1.eq.0) then
           call ECRLOG(.false.)
           return
          endif
       else
        write(ioimp,*) 'Donnez une table de soustype BASE_MODALE ou',
     &   ' LIAISONS_STATIQUES'
        call erreur(482)
       endif
       CALL ECROBJ('RIGIDITE',MRIG1)  
           
C---- Autres cas -----------------------------------------------
      ELSE
      
c       cas des liaisons statiques : on calcule les rigidites associees
        CALL LIRTAB('LIAISONS_STATIQUES',MTAB1,0,IRETOU)
        if (iretou.ne.0) then
          call proba2(MTAB1,MRIG1)
          if (ierr.ne.0) return
          if (mrig1.gt.0) then
           CALL ECROBJ('RIGIDITE',MRIG1)
          else
           call ECRLOG(.false.)
          endif      
        endif
        
c       autres cas : chpoint ou chargement
        CALL LIROBJ('CHPOINT ',IP1,0,IRETOU)
        CHAR = IRETOU.EQ.0
        IF (CHAR) THEN
           CALL LIROBJ('CHARGEME',IPCHAR,1,IRETOU)
           IF (IERR.NE.0) RETURN
        ENDIF
c       lecture des modes sous forme de BASEMODA ou de table BASE_MODALE 
        CALL LIROBJ('BASEMODA',IP2,0,IRETOU)
        IF (IRETOU.EQ.0) THEN
           CALL LIRTAB('BASE_MODALE',ITBAS,1,IRETOU)
           IF(IERR.NE.0) RETURN
           CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
     &                       'TABLE',I1,X1,' ',L1,IP2)
           TABL = .TRUE.
        ELSE
          MBASEM=IP2
          SEGACT MBASEM
          NBAS=LISBAS(/1)
          IP4=1
          IF(NBAS.EQ.1) GOTO 5
*       BASE COMPLEXE
          CALL LIROBJ('STRUCTUR',IRET,1,IRETOU)
          IF(IERR.NE.0) GOTO 4000
          MSTRUC=IRET
          SEGACT MSTRUC
          NSTRU=LISTRU(/1)
          MSOSTU=LISTRU(1)
          IP3=1
          IF(NSTRU.EQ.1) GOTO 2
*         STRUCTURE COMPLEXE
          CALL LIRENT(IP3,1,IRETOU)
          IF(IERR.NE.0) GOTO 3000
*    ON VERIFIE QU'IL S'AGIT DE SOUS-STRUCTURES IDENTIQUES
          SEGACT MSOSTU
          ISRAI1=ISRAID
          SEGDES MSOSTU
          DO 1 NS=2,NSTRU
            MSOSTU=LISTRU(NS)
            SEGACT MSOSTU
            IF(ISRAI1.NE.ISRAID) GOTO 2000
            SEGDES MSOSTU
 1        CONTINUE
          IF(IP3.EQ.0.OR.IP3.GT.NSTRU) GOTO 4000
          MSOSTU=LISTRU(IP3)
 2        CONTINUE
          SEGDES MSTRUC
*         ON VERIFIE QUE LA SOUS-STRUCTURE EST DANS LA BASE
          DO 3 NB = 1,NBAS
            MSOBAS=LISBAS(NB)
            SEGACT MSOBAS
            IP4=NB
            IF(IBSTRM(1).EQ.MSOSTU) GOTO 4
            SEGDES MSOBAS
 3        CONTINUE
*       INCOHERENCE ENTRE LA BASE ET LA STRUCTURE
          GOTO 4000
 4        CONTINUE
          SEGDES MSOBAS
        ENDIF
c       lecture du mot clé LIBR
 5      CALL LIRMOT(LIBR,NLIBR,ILIBRE,0)
c       cas d'un chargement 
        IF (CHAR) THEN
          MCHAR1=IPCHAR
          SEGINI,MCHARG=MCHAR1
          NBCHG=KCHARG(/1)
          DO 10 NC=1,NBCHG
            ICHAR1=KCHARG(NC)
            SEGINI,ICHARG=ICHAR1
            KCHARG(NC)=ICHARG
            IP1=ICHPO1
*+*   POUR L'INSTANT, ON NE DUPLIQUE PAS LES LISTREELS
            IF (TABL) THEN
              CALL PROJTA(IP1,IP2,IRET)
            ELSE
              CALL PROJBA(IP1,IP2,IP4,IRET)
            ENDIF
            IF(IERR.NE.0) RETURN
            ICHPO1=IRET
            SEGDES,ICHARG
 10       CONTINUE
          SEGDES,MCHARG
          CALL ECROBJ('CHARGEME',MCHARG)
c       cas d'un chpoint   
        ELSE
          IF (ILIBRE .EQ. 1) THEN
C          CAS GRANDS DEPLACEMENTS ; CHARGEMENT LIBRE
            CALL PJLIBR( IP1,IP2,IP4,IRET )
            CALL ECROBJ( 'LISTCHPO',IRET )
          ELSE
            IF (TABL) THEN
              CALL PROJTA(IP1,IP2,IRET)
            ELSE
              CALL PROJBA( IP1,IP2,IP4,IRET )
            ENDIF
            IF(IRET.EQ.0) GO TO 5000
            CALL ECROBJ( 'CHPOINT ',IRET )
          ENDIF
        ENDIF
        GOTO 5000
2000    CONTINUE
        SEGDES MSOSTU
3000    CONTINUE
        SEGDES MSTRUC
4000    CALL ERREUR(216)
        SEGDES MBASEM
5000    CONTINUE
*
      ENDIF
*
      END