Sources Esope | Cast3M

devfx0
C DEVFX0    SOURCE    CB215821  20/11/25    13:25:01     10792          
      SUBROUTINE DEVFX0(ITCHAR,KTNUM,KPREF,KTFEX,REPRIS,RIGIDE,
     &LMODYN,ITBAS)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*--------------------------------------------------------------------*
*                                                                    *
*     Op�rateur DYNE : algorithme de Fu - de Vogelaere               *
*     ________________________________________________               *
*                                                                    *
*     Remplissage des tableaux repr�sentant les chargements, en      *
*     faisant 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               *
*                                                                    *
*     Auteur, date de cr�ation:                                      *
*                                                                    *
*     Denis ROBERT-MOUGIN, le 25 mai 1989.                           *
*                                                                    *
*--------------------------------------------------------------------*
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHARG
-INC SMCHPOI
-INC SMELEME
-INC SMLREEL
*
*     FEXA(.,.,1)  valeur au pas  m
*     FEXA(.,.,2)  valeur au pas  m - 1/2
*
      SEGMENT,MTNUM
         REAL*8 XDT(NPC1),XTEMPS(NPC1)
      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,MPREF
         INTEGER IPOREF(NPREF)
      ENDSEGMENT
      LOGICAL L0,L1,REPRIS,RIGIDE,LMODYN
      CHARACTER*8 TYPRET,CHARRE
*
      MTNUM = KTNUM
      MTFEX = KTFEX
      MPREF = KPREF
      NPREF = IPOREF(/1)
      NPC1 = XDT(/1)
*
*     On extrait les chargements de la table
*
      TYPRET = ' '
 
      if (lmodyn) then
        TYPRET= 'CHARGEME'
        ICHAR1 = ITCHAR
      else
        CALL ACCTAB(ITCHAR,'MOT',I0,X0,'BASE_A',L0,IP0,
     &                  TYPRET,I1,X1,CHARRE,L1,ICHAR1)
      endif
 
      IF (ICHAR1.NE.0 .AND. TYPRET.EQ.'CHARGEME') THEN
         MCHARG = ICHAR1
         SEGACT,MCHARG
         NCHAR = KCHARG(/1)
         IXA = 0
*
*        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
                  DO 35 K=1,NC
                     KNOE = NUM(1,J)
                     CALL PLACE2(IPOREF,NPREF,IPOS,KNOE)
                     IF (IPOS.NE.0) THEN
                        IXA = IXA + 1
                        XFORCA = VPOCHA(J,K)
* bp, 2018-12-14        IFEXA(IPOS) = IXA
*
*                       Boucle sur les pas de temps
*
                        DO 36 IT=1,NPC1
                           NP = 2 * IT
                           FEXA(IPOS,IT,1) = FEXA(IPOS,IT,1) +
     &                                       ( XFORCA * FTCHG(NP) )
                           NI = NP - 1
                           FEXA(IPOS,IT,2) = FEXA(IPOS,IT,2) +
     &                                       ( XFORCA * FTCHG(NI) )
 36                        CONTINUE
*                       end do
                     ENDIF
 35                  CONTINUE
*                 end do
 30               CONTINUE
*              end do
               SEGDES,MPOVAL,MELEME,MSOUPO
 20            CONTINUE
*           end do
            SEGDES,MCHPOI,ICHARG
            SEGSUP,MTRAV
 10         CONTINUE
*        end do
         SEGDES,MCHARG
      ELSE
         TYPRET = ' '
         CALL ACCTAB(ITCHAR,'MOT',I0,X0,'BASE_B',L0,IP0,
     &                  TYPRET,I1,X1,CHARRE,L1,ICHAR2)
         IF ((ICHAR2.EQ.0).OR.(.NOT.RIGIDE)) THEN
            CALL ERREUR(486)
            RETURN
         ENDIF
      ENDIF
*
      END