Sources Esope | Cast3M

bsigel
C BSIGEL    SOURCE    OF166741  25/02/21    21:15:11     12166          
 
      SUBROUTINE BSIGEL (IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LPERM,
     &                   IVAFOR,NFOR)
 
*----------------------------------------------------------------------*
*    CALCUL DES INDUCTIONS (FLUX) ELECTRIQUES NODAUX EQUIVALENTES      *
*      Formulation 'ELECTROSTATIQUE' (MFR=71) - Elements MASSIFs       *
*----------------------------------------------------------------------*
*  IPMAIL  (E)  Pointeur sur un segment  MELEME                     *
*  IPMINT  (E)  Pointeur sur un segment MINTE (ACTIF)                *
*  NBPGAU  (E)  Nombre de points d'integration pour les "contraintes" *
*  IVASTR  (E)  pointeur sur un segment MPTVAL contenant les        *
*              les melvals de contraints                           *
*  NSTRS   (E)  Nombre de composantes de "contraintes/deformations"    *
*  LRE     (E)  Nombre de DDL dans la matrice de "rigidite"           *
*  LPERM   (E)  Nombre de composantes de "deformations" = NSTRS        *
*  IVAFOR  (E)  pointeur sur un segment MPTVAL contenant les        *
*              les melvals de forces                               *
*  NFOR    (E)  Nombre de composantes de "flux" LRE = NBNN * NFOR   *
*----------------------------------------------------------------------*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
 
-INC SMCHAML
-INC SMELEME
-INC SMCOORD
-INC SMINTE
 
-INC TMPTVAL
 
      SEGMENT MWRK1
        REAL*8 XFORC(LRE), XFLUE(NSTRS), XEL(3,NBNN)
        REAL*8 SHP(6,NBNN), BGRELE(LPERM,LRE)
      ENDSEGMENT
 
      MELEME = IPMAIL
      NBNN   = meleme.NUM(/1)
      NBELEM = meleme.NUM(/2)
 
      MINTE = IPMINT
*      NBPGAU = minte.POIGAU(/1)
 
      SEGINI,MWRK1
 
C-------------------------
C Boucle sur les elements
C-------------------------
      DO IEL = 1, NBELEM
 
C - Recuperation des coordonnees des noeuds de l element IEL
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XEL)
 
C - Initialisation des flux nodaux equivalents
        DO ICOMP = 1, LRE
          XFORC(ICOMP) = XZero
        ENDDO
C
        MPTVAL = IVASTR
C--  --  --  --  --  --  --  --  --
C - Boucle sur les points de Gauss
C--  --  --  --  --  --  --  --  --
        ISDJC = 0
        DO IGAU = 1, NBPGAU
C -- Calcul de la matrice Bel et du jacobien au point de Gauss IGAU
          CALL BELEC(XEL,SHPTOT(1,1,IGAU),NBNN,LPERM,1,
     &               SHP,BGRELE,DJAC)
          IF (DJAC.EQ.XZero) THEN
            INTERR(1) = IEL
            CALL ERREUR(259)
            GOTO 999
          ENDIF
          IF (DJAC.LT.XZero) ISDJC = ISDJC+1
          DJAC = ABS(DJAC)*POIGAU(IGAU)
C -- Recuperation des inductions Del au point d'integration (IGAU)
          DO ICOMP = 1, NSTRS
            MELVAL = IVAL(ICOMP)
            IGMN = MIN(IGAU,VELCHE(/1))
            IEMN = MIN(IEL ,VELCHE(/2))
            XFLUE(ICOMP) = VELCHE(IGMN,IEMN)
          ENDDO
C -- Calcul du terme Bel * Del et de la contribution du point IGAU
          DO ICOMP = 1, LRE
            r_z = XZero
            DO JCOMP = 1, NSTRS
              r_z = r_z + BGRELE(JCOMP,ICOMP) * XFLUE(JCOMP)
            ENDDO
            XFORC(ICOMP) = XFORC(ICOMP) + r_z*DJAC
          ENDDO
C--  --  --  --  --  --  --  --  --
        ENDDO
C--  --  --  --  --  --  --  --  --
        IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
          INTERR(1) = IEL
          CALL ERREUR(195)
          GOTO 999
        ENDIF
C - Stockage de XFORC dans le MELVAL IVAFOR
        MPTVAL = IVAFOR
        IE = 0
        DO IGAU = 1, NBNN
          DO ICOMP = 1, NFOR
            IE = IE + 1
            MELVAL = IVAL(ICOMP)
            IEMN = MIN(IEL,VELCHE(/2))
            VELCHE(IGAU,IEMN) = XFORC(IE)
          ENDDO
        ENDDO
C-------------------------
      ENDDO
C-------------------------
 
 999  CONTINUE
      SEGSUP,MWRK1
 
      RETURN
      END