Sources Esope | Cast3M

froa2d
C FROA2D    SOURCE    FANDEUR   11/07/19    21:16:05     7042
 
      SUBROUTINE FROA2D(IPOGEO,IPMATR,IPMINT,IVAMAT,
     1                  IVACAR,MELE,MFR,LRE,NDDL)
C
C***********************************************************************
C                                                                      *
C  Routine appelée par FRVISQ.                                         *
C                                                                      *
C  Calcule l'amortissement de frontière dans le cas 2D pour les        *
C  massifs de face SEG2 ou SEG3.                                       *
C                                                                      *
C  Entrées :                                                           *
C  --------                                                            *
C                                                                      *
C     IPOGEO : pointeur sur le maillage de l'enveloppe des massifs,    *
C              type MELEME                                             *
C     IPMATR : pointeur sur le segment IMATRI, chapeau des rigidités   *
C              élémentaires                                            *
C     IPMINT : pointeur sur le segment d'intégration, type MINTE       *
C     IVAMAT : pointeur sur un segment MPTVAL de données matériau      *
C     IVACAR : pointeur sur un segment MPTVAL de caractéristiques      *
C              (épaisseur dans le cas contraintes planes)              *
C     MELE   : numéro de l'élément fini associé à la face du massif    *
C     MFR    : numéro de la formulation                                *
C     LRE    : taille de la matrice d'amortissement à construire       *
C     NDDL   : nombre de degrés de liberté                             *
C                                                                      *
C  Remplit le segment XMATRI pour chaque élément de la sous-zone.      *
C***********************************************************************
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
-INC CCREEL
*-
 
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
-INC SMELEME
-INC SMCOORD
-INC SMCHAML
-INC SMINTE
C
      SEGMENT MWORK
        REAL*8 XE(3,NBNN)
        REAL*8 REL(LRE,LRE)
        REAL*8 SHPWRK(6,NBNN),BGENE(NDDL,LRE)
        REAL*8 VALMAT(NV1)
        REAL*8 VECN(NDDL),VECT1(NDDL),VECT2(NDDL)
        REAL*8 XNNT(NDDL,NDDL),XTTT1(NDDL,NDDL),XTTT2(NDDL,NDDL)
      ENDSEGMENT
C
      SEGMENT MPTVAL
      INTEGER IPOS(NS),NSOF(NS)
      INTEGER IVAL(NCOSOU)
      CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
      MELEME=IPOGEO
c*      SEGACT,MELEME
      NBNN=NUM(/1)
      NBELEM=NUM(/2)
*
      MINTE=IPMINT
c*      SEGACT,MINTE
      NBPGAU=POIGAU(/1)
C
      NV1=3
C
      DIM3=1.D0
C
      xMATRI=IPMATR
c*      SEGACT,xMATRI*MOD
c*      NLIGRD=LRE
c*      NLIGRP=LRE
*
      SEGINI,MWORK
C
C  boucle sur les éléments
C
      DO 1 IB=1,NBELEM
C
C  on cherche les coordonnées de l'élément IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL ZERO(REL,LRE,LRE)
C
C  boucle sur les points de Gauss
C
      DO 10 IGAU=1,NBPGAU
C
C  récupération de l'épaisseur
C
         IF (IFOUR.EQ.-2) THEN
            MPTVAL=IVACAR
            IF (IVACAR.NE.0) THEN
               MELVAL=IVAL(1)
               IF (MELVAL.NE.0) THEN
                  IGMN=MIN(IGAU,VELCHE(/1))
                  IBMN=MIN(IB,VELCHE(/2))
                  DIM3=VELCHE(IGMN,IBMN)
               ELSE
                  DIM3=1.D0
               ENDIF
            ENDIF
         ENDIF
C
C  récupération des données matériau
C
         MPTVAL=IVAMAT
         DO 11 J=1,3
            MELVAL=IVAL(J)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB,VELCHE(/2))
            VALMAT(J)=VELCHE(IGMN,IBMN)
 11      CONTINUE
C
         RHO=VALMAT(1)
         E=VALMAT(2)
         XNU=VALMAT(3)
         CS=E/(2*(1+XNU)*RHO)
         IF (IFOUR.EQ.-2) THEN
            CP=SQRT(E/(RHO*(1-XNU*XNU)))
         ELSE
            CP=SQRT(2*CS*(1-XNU)/(1-2*XNU))
         ENDIF
         CS=SQRT(CS)
C
C  coefficients d'amortissement
C
         RCP=RHO*CP
         RCS=RHO*CS
C
C  calcul de la tangente locale normalisée
C
         VNQSI1=0.D0
         VNQSI2=0.D0
         DO 20 I=1,NBNN
            VNQSI1=VNQSI1+SHPTOT(2,I,IGAU)*XE(1,I)
            VNQSI2=VNQSI2+SHPTOT(2,I,IGAU)*XE(2,I)
 20      CONTINUE
         XNORM=SQRT(VNQSI1*VNQSI1+VNQSI2*VNQSI2)
         VECT1(1)=VNQSI1/XNORM
         VECT1(2)=VNQSI2/XNORM
         IF(IFOUR.EQ.1) VECT1(3)=0.D0
C
C  calcul de la normale
C
         VECN(1)=-VECT1(2)
         VECN(2)=VECT1(1)
         IF(IFOUR.EQ.1) VECN(3)=0.D0
C
C  calcul des matrices nnT et ttT1
C
         DO 30 I=1,NDDL
            DO 31 J=1,NDDL
               XNNT(I,J)=VECN(I)*VECN(J)
               XTTT1(I,J)=VECT1(I)*VECT1(J)
 31         CONTINUE
 30      CONTINUE
C
C  calcul du deuxième vecteur tangent dans le cas du mode Fourier
C  et de la matrice ttT2 associee
C
         IF (IFOUR.EQ.1) THEN
           VECT2(1)=0.D0
           VECT2(2)=0.D0
           VECT2(3)=1.D0
           DO I=1,NDDL
             DO J=1,NDDL
               XTTT2(I,J)=VECT2(I)*VECT2(J)
             ENDDO
           ENDDO
         ENDIF
C
C  calcul de la matrice N des fonctions de forme
C
         XDPGE=0.D0
         YDPGE=0.D0
         CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
     1   DIM3,XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
C
C  calcul du jacobien
C
         DXDQSI=0.D0
         DYDQSI=0.D0
         DO 40 I=1,NBNN
            DXDQSI=DXDQSI+SHPTOT(2,I,IGAU)*XE(1,I)
            DYDQSI=DYDQSI+SHPTOT(2,I,IGAU)*XE(2,I)
 40      CONTINUE
         DJAC=SQRT(DXDQSI*DXDQSI+DYDQSI*DYDQSI)
C
C  calcul de l'élément de volume
C
         IF (IFOUR.LT.0) THEN
           R=1.D0
           IF (IFOUR.EQ.-2) R=DIM3
         ELSE
           R=0.D0
           DO I=1,NBNN
             R=R+SHPTOT(1,I,IGAU)*XE(1,I)
           ENDDO
           IF (IFOUR.EQ.0.OR.(IFOUR.EQ.1
     &              .AND.NIFOUR.EQ.0)) THEN
               R=2*XPI*R
            ELSEIF (IFOUR.EQ.1.AND.NIFOUR.NE.0) THEN
               R=XPI*R
           ENDIF
         ENDIF
C
C  construction de la matrice d'amortissement
C
         DJACN=ABS(DJAC)*RCP*POIGAU(IGAU)*R
         CALL BDBST(BGENE,DJACN,XNNT,LRE,NDDL,REL)
 
         DJACT=ABS(DJAC)*RCS*POIGAU(IGAU)*R
         CALL BDBST(BGENE,DJACT,XTTT1,LRE,NDDL,REL)
C
C  cas du mode Fourier
C
         IF (IFOUR.EQ.1) THEN
           CALL BDBST(BGENE,DJACT,XTTT2,LRE,NDDL,REL)
         ENDIF
C
 10   CONTINUE
C
C  remplissage de XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,ib))
C
 1    CONTINUE
 
      SEGSUP,MWORK
c*      SEGDES,xMATRI,MINTE,MELEME
 
      RETURN
      END