Sources Esope | Cast3M

d2vrig
C D2VRIG    SOURCE    CB215821  20/11/25    13:23:57     10792          
        SUBROUTINE D2VRIG(ITCHAR,KTNUM,KTPHI,KTFEX,KTLIAB,REPRIS)
      IMPLICIT INTEGER(I-N)
        IMPLICIT REAL*8(A-H,O-Z)
*---------------------------------------------------------------*
*                                                               *
*     Opérateur DYNE : algorithme de Fu - de Vogelaere          *
*     ________________________________________________          *
*                                                               *
*     Remplissage du tableau FTEXB représentant les chargements,*
*     sur base B, on ne lit que les efforts car ces forces      *
*     servent au calcul des moments pour les corps rigides      *
*     On effectue aussi les interpolations nécessaires.         *
*                                                               *
*     Paramètres:                                               *
*                                                               *
* e   ITCHAR  Table représentant les chargements                *
* e   ITINIT  Table représentant les conditions initiales       *
* e   KTNUM   Segment contenant les paramètres numériques       *
* e   KPREF   Segment des points de référence                   *
* es  KTFEX   Segment contenant les chargements libres          *
* e   REPRISE Vrai si reprise, faux sinon                       *
*                                                               *
*     Auteur, date de création:                                 *
*                                                               *
*     Samuel DURAND, le 07 octobre 1996  .                      *
*                                                               *
*                                                               *
*---------------------------------------------------------------*
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
-INC SMCHARG
-INC SMCHPOI
-INC SMELEME
-INC SMLREEL
*
*       FTEXB(.,.,1,..)  valeur au pas m
*       FTEXB(.,.,2,..)  valeur au pas m-1
*
      SEGMENT,MTNUM
         REAL*8 XDT(NPC1),XTEMPS(NPC1)
      ENDSEGMENT
      SEGMENT,MTPHI
         INTEGER IBASB(NPLB),IPLSB(NPLB),INMSB(NSB),IORSB(NSB)
         INTEGER IAROTA(NSB)
         REAL*8 XPHILB(NSB,NPLSB,NA2,IDIMB)
      ENDSEGMENT
      SEGMENT,MTFEX
         REAL*8  FEXA(NPFEXA,NPC1,2)
         REAL*8  FEXPSM(NPLB,NPC1,2,IDIMB)
         REAL*8  FTEXB(NPLB,NPC1,2,IDIM)
*         INTEGER IFEXA(NPFEXA),IFEXB(NPFEXB)
      ENDSEGMENT
      SEGMENT,MTRAV
         REAL*8 FTCHG(NPC2)
      ENDSEGMENT
      SEGMENT,MTLIAB
         INTEGER IPALB(NLIAB,NIPALB),IPLIB(NLIAB,NPLBB),JPLIB(NPLB)
         REAL*8 XPALB(NLIAB,NXPALB)
         REAL*8 XABSCI(NLIAB,NIP),XORDON(NLIAB,NIP)
      ENDSEGMENT
*
*
        LOGICAL L0,L1,REPRIS
        CHARACTER*(LOCOMP) CMOT,NOMTRI(3)
        CHARACTER*8 TYPRET,CHARRE
        CHARACTER*40 MONMOT
*
        DATA NOMTRI/'FX  ','FY  ','FZ  '/
*
        MTNUM = KTNUM
        MTFEX = KTFEX
        MTPHI = KTPHI
        MTLIAB = KTLIAB
*
        NPC1 = XDT(/1)
        NPLB = JPLIB(/1)
        NSB = IAROTA(/1)
        IDIMB = XPHILB(/4)
*
* Lecture des chargements en base B
*
        DO 5 IP=1,NPLB
          DO 6 IC=1,NPC1
            DO 7 I2=1,2
               DO 8 I3=1,IDIM
                  FTEXB(IP,IC,I2,I3)=0.D0
 8             CONTINUE
 7           CONTINUE
 6         CONTINUE
 5      CONTINUE
      IF (ITCHAR.NE.0) THEN
        TYPRET = ' '
        CALL ACCTAB(ITCHAR,'MOT',I0,X0,'BASE_B',L0,IP0,
     &                  TYPRET,I1,X1,CHARRE,L1,ICHAR1)
        IF (ICHAR1.NE.0 .AND. TYPRET.EQ.'CHARGEME') THEN
           MCHARG = ICHAR1
           SEGACT,MCHARG
           NCHAR = KCHARG(/1)
*
*        Boucle sur les chargements élémentaires
*
         DO 10 ICHAR=1,NCHAR
            ICHARG = KCHARG(ICHAR)
            SEGACT,ICHARG
            IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(ICHAR).NE.'STAT'
     & .OR.CHALIE(ICHAR).NE.'LIE ') THEN
               SEGDES ICHARG
               SEGDES MCHARG
               CALL ERREUR(696)
               RETURN
            ENDIF
            MLR1 = ICHPO2
            MLR2 = ICHPO3
            CALL DEVINT(MLR1,MLR2,KTNUM,KTRAV,REPRIS)
            MTRAV = KTRAV
            MCHPOI = ICHPO1
            SEGACT,MCHPOI
            NSOUPO=IPCHP(/1)
            DO 20 I=1,NSOUPO
               MSOUPO = IPCHP(I)
               SEGACT,MSOUPO
               MELEME = IGEOC
               SEGACT,MELEME
               NC = NOCOMP(/2)
               MPOVAL = IPOVAL
               SEGACT,MPOVAL
               N = VPOCHA(/1)
               DO 30 J=1,N
                  KNOE = NUM(1,J)
                  DO 35 K=1,NC
                     CMOT = NOCOMP(K)
                     CALL PLACE(NOMTRI,3,ID,CMOT)
                     IF (ID.NE.0) THEN
* On vérifie que le point est un point de liaison
                       CALL PLACE2(JPLIB,NPLB,IPOS,KNOE)
                        IF (IPOS.NE.0) THEN
                           ISB = IBASB(IPOS)
                           IF (IAROTA(ISB).NE.0) THEN
                              XFORCB = VPOCHA(J,K)
*
*                       Boucle sur les pas de temps
*
                              DO 36 IT=1,(NPC1 - 1)
                                FTEXB(IPOS,IT,2,ID) =
     &                    FTEXB(IPOS,IT,2,ID) +( XFORCB * FTCHG(IT) )
                                IT2 = IT + 1
                                FTEXB(IPOS,IT,1,ID) =
     &                    FTEXB(IPOS,IT,1,ID) +( XFORCB * FTCHG(IT2) )
 36                           CONTINUE
                            ENDIF
*                       end do
                         ENDIF
                       ENDIF
 35                 CONTINUE
*                 end do
 30               CONTINUE
*              end do
 20            CONTINUE
*           end do
            SEGSUP,MTRAV
 10         CONTINUE
*        end do
         SEGDES,MCHARG
       ENDIF
      ENDIF
*
      END