Sources Esope | Cast3M

pjba
C PJBA      SOURCE    CB215821  20/11/25    13:35:48     10792          
      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 PPARAM
-INC CCOPTIO
C
      LOGICAL L0,L1,CHAR,TABL
      CHARACTER*4 LIBR(1),CLE(1)
      CHARACTER*32 CH32
      CHARACTER*72 motyp1,motyp2
      DATA CLE(1)/'REEL'/
      DATA LIBR(1) /'LIBR'/
      NLIBR = 1
      TABL = .FALSE.
 
 
C---- Cas d'un LISTCHPO ou d'une TABLE de resultats --------------------
      CALL LIRTAB('PASAPAS',MTAB1,0,IRETOU)
      IF (IRETOU.EQ.0) CALL LIRTAB('DYNAMIC',MTAB1  ,0,IRETOU)
      IF (IRETOU.EQ.0) CALL LIRTAB('EXEC'   ,MTAB1  ,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
        CALL LIROBJ('LISTCHPO',ILCHP1,0,IRETOU)
        IF(IRETOU .EQ. 1) CALL ACTOBJ('LISTCHPO',ILCHP1,1)
      ENDIF
      IF (IRETOU.EQ.0) GOTO 100
 
*     SIGNAL D'ENTREE
      ITYP=0
      CALL REFUS
      CALL LIRRES(ILCHP1,1,ITYP,CH32,NCH,0,ILREE1)
      IF (IERR.NE.0) RETURN
 
*     TABLE DE MODES
      CALL LIRTAB('BASE_MODALE',ITBAS1,1,IRET)
      IF (IERR.NE.0) RETURN
 
*     NOMBRE DE MODES
      CALL LIRENT(NMOD1,0,IRET)
      IF (IRET.EQ.0) NMOD1=0
 
*     MATRICE POUR LE PRODUIT SCALAIRE
      CALL LIROBJ('RIGIDITE',IRIG1,0,IRET)
      IF (IRET.EQ.0) IRIG1=0
 
      CALL PJBLCH(ILCHP1,ITBAS1,NMOD1,IRIG1,ILCHP2)
      IF (IERR.NE.0) RETURN
      CALL ACTOBJ('LISTCHPO',ILCHP2,1)
      CALL ECROBJ('LISTCHPO',ILCHP2)
 
      RETURN
 
C---- Cas d'un MODELE --------------------------------------------------
 100  CONTINUE  
      call LIROBJ('MMODEL ',IPMODE,0,iretou)
      IF (iretou.EQ.0) GOTO 200
      CALL ACTOBJ('MMODEL ',IPMODE,1)
      call pjmode(ipmode)
      return
 
C---- Cas d'une RIGIDITE -----------------------------------------------
 200  CONTINUE      
      CALL LIROBJ('RIGIDITE',MRIGID,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 300
 
C   --- Cas d'une RIGIDITE suivie d'1 (ou 2) TABLE(S) ---
        CALL LIROBJ('TABLE   ',MTAB1,1,IRETOU)
        IF (IERR.NE.0) RETURN
        CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &        'MOT',IP,RR,motyp1,.TRUE.,IQ)
c       lecture facultative d une 2eme table
        CALL LIROBJ('TABLE   ',MTAB2,0,IRETO2)
        IF(IRETO2.NE.0) THEN
          CALL ACCTAB(MTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &          'MOT',IP,RR,motyp2,.TRUE.,IQ)
          IF (IERR.NE.0) RETURN
c         a t'on inversé les 2 tables ?
          if (motyp1.eq.'LIAISONS_STATIQUES'.and.
     &        motyp2.eq.'BASE_MODALE') then
            motyp1='BASE_MODALE'
            motyp2='LIAISONS_STATIQUES'
            MTEMP = MTAB1
            MTAB1 = MTAB2
            MTAB2 = MTEMP
          endif
          if (motyp1.ne.'BASE_MODALE'.or.
     &        motyp2.ne.'LIAISONS_STATIQUES') then
              write(ioimp,*) 'Donnez une (des) table(s) de soustype',
     &        ' BASE_MODALE ou LIAISONS_STATIQUES'
              call erreur(482)
              return
          endif
        ELSE
          MTAB2=0
        ENDIF
 
c      -calcul de Phi^T * K * Phi  (ou Phi = base modale)
        if (motyp1.eq.'BASE_MODALE') then
          CALL LIRMOT(CLE,1,ICLE,0)
          CALL PROJRG(MRIGID,MTAB1,MTAB2,ICLE,MRIG1,MRIG2)
          if (ierr.ne.0) return
          IF (MRIG2.NE.0) CALL ECROBJ('RIGIDITE',MRIG2)
 
c      -calcul de Psi^T * RELA * Psi  (ou Psi = base deformees statiques)
        elseif (motyp1.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)
          return
        endif
        CALL ECROBJ('RIGIDITE',MRIG1)  
        RETURN
 
c---- cas d'un CHPOINT ou d'un CHARGEMENT ------------------------------
 300  CONTINUE
      CALL LIROBJ('CHPOINT ',IP1,0,IRETOU)
      IF(IRETOU.EQ.1)CALL ACTOBJ('CHPOINT ',IP1,1)
      CHAR = IRETOU.EQ.0
      IF (CHAR) THEN
         CALL LIROBJ('CHARGEME',IPCHAR,0,IRETOU)
         IF(IRETOU .EQ. 1) CALL ACTOBJ('CHARGEME',IPCHAR,1)
         IF (IERR.NE.0) RETURN
      ENDIF      
      IF (IRETOU.EQ.0) GOTO 400
 
c      -lecture des modes sous forme de BASEMODA ou de table BASE_MODALE 
        IPSTA=0
        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.
c          lecture facultative d une 2eme table de liaisons statiques
           CALL LIRTAB('LIAISONS_STATIQUES',IPSTA,0,IRETOU)
        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      -fin du cas on a une base modale
 
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 ACTOBJ('CHPOINT ',IP1,1)
              CALL PROJTA(IP1,IP2,IPSTA,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 ACTOBJ('LISTCHPO',IRET,1)
            CALL ECROBJ('LISTCHPO',IRET)
          ELSE
            IF (TABL) THEN
              CALL PROJTA(IP1,IP2,IPSTA,IRET)
            ELSE
              CALL PROJBA( IP1,IP2,IP4,IRET )
            ENDIF
            IF(IRET.EQ.0) GO TO 5000
            CALL ACTOBJ('CHPOINT ',IRET,1)
            CALL ECROBJ('CHPOINT ',IRET)
          ENDIF
        ENDIF
        GOTO 5000
2000    CONTINUE
        SEGDES MSOSTU
3000    CONTINUE
        SEGDES MSTRUC
4000    CALL ERREUR(216)
        SEGDES MBASEM
5000    CONTINUE
 
      RETURN
 
c---- cas TABLE LIAISONS STATIQUES SEULE -------------------------------
 400  CONTINUE
      CALL LIRTAB('LIAISONS_STATIQUES',MTAB1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 9999
c     on calcule les rigidites associees
      call proba2(MTAB1,MRIG1)
      if (ierr.ne.0) return
      if (mrig1.gt.0) then
        CALL ECROBJ('RIGIDITE',MRIG1)
      else
        call ECRLOG(.false.)
      endif      
 
      RETURN
 
c     petit message d'erreur si on n'a pas lu un objet a projeter
9999  CONTINUE
      MOTERR(1:8)='RIGIDITE'
      MOTERR(9:16)='CHPOINT'
      MOTERR(17:24)='CHARGEME'
      MOTERR(25:32)='TABLE'
      MOTERR(33:40)='LISTCHPO'
      call erreur(471)
 
      END