Sources Esope | Cast3M

fsco3d
C FSCO3D    SOURCE    FANDEUR   12/07/18    21:15:38     7434
 
      SUBROUTINE FSCO3D(IPT,IPMAIL,IPVECT,VEC, IVAFOR)
 
C____________________________________________________________________
C
C   CALCULE LES FORCES SURFACIQUES POUR LES COQUES 3D
C
C
C   ENTREES :
C   ---------
C
C    IPT      TABLEAU DE POINTEUR SUR UN MPTVAL CONTENANT LES FORCES
C             APPLIQUEES
C             0 SI ON A DONNE UNE FORCE CONSTANTE
C    IPMAIL   OBJET GEOMETRIQUE
C    IPVECT   POINTEUR SUR LE VECTEUR REPRESENTANT LA FORCE
C    VEC      VECTEUR REPRESENTANT LA FORCE
C    IVAFOR   POINTEUR SUR UN MPTVAL ET MELVALS ASSOCIEES AUX FORCES
C             NODALE RESULTANTES
C____________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
C
-INC SMCHAML
-INC SMELEME
-INC SMCOORD
C
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
      DIMENSION VEC(*),IPT(*)
 
      DIMENSION XE(3,3),XEL(3,3),BPSS(3,3),BB(9),FT(18),F(6)
      DIMENSION XX(3),YY(3)
C
      DATA XX/0.5D0,0.5D0,0.0D0/
      DATA YY/0.0D0,0.5D0,0.5D0/
      PARAMETER (X1s3 = 0.333333333333333333333333333333333333333333D0 ,
     &           X1s6 = 0.166666666666666666666666666666666666666667D0 )
C
      MELVA1 = IPT(1)
      MELVA2 = IPT(2)
      MELVA3 = IPT(3)
      IF (IPVECT.EQ.0) THEN
        V1 = 0.D0
        V2 = 0.D0
        V3 = 0.D0
        IF (MELVA1.NE.0) THEN
          SEGACT,MELVA1
          IGM1 = MIN(3,MELVA1.VELCHE(/1))
          IBM1 = MELVA1.VELCHE(/2)
        ENDIF
        IF (MELVA2.NE.0) THEN
          SEGACT,MELVA2
          IGM2 = MIN(3,MELVA2.VELCHE(/1))
          IBM2 = MELVA2.VELCHE(/2)
        ENDIF
        IF (MELVA3.NE.0) THEN
          SEGACT,MELVA3
          IGM3 = MIN(3,MELVA3.VELCHE(/1))
          IBM3 = MELVA3.VELCHE(/2)
        ENDIF
      ELSE
        V1 = VEC(1)
        V2 = VEC(2)
        V3 = VEC(3)
      ENDIF
C
      MELEME=IPMAIL
C*      SEGACT,MELEME          (&lt;- actif en E/S et non modifie)
      NBELEM = NUM(/2)
C
C     BOUCLE SUR LES ELEMENTS
C
      DO 1000 IB = 1, NBELEM
 
C       Force moyenne sur l'element
        IF (IPVECT.EQ.0) THEN
          IF (MELVA1.NE.0) THEN
            IBMN = MIN(IB,IBM1)
            IF (IGM1.GT.1) THEN
              V1 = (  MELVA1.VELCHE(1,IBMN) + MELVA1.VELCHE(2,IBMN)
     &              + MELVA1.VELCHE(3,IBMN) ) * X1s3
            ELSE
              V1 = MELVA1.VELCHE(1,IBMN)
            ENDIF
          ENDIF
          IF (MELVA2.NE.0) THEN
            IBMN = MIN(IB,IBM2)
            IF (IGM2.GT.1) THEN
              V2 = (  MELVA2.VELCHE(1,IBMN) + MELVA2.VELCHE(2,IBMN)
     &              + MELVA2.VELCHE(3,IBMN) ) * X1s3
            ELSE
              V2 = MELVA2.VELCHE(1,IBMN)
            ENDIF
          ENDIF
          IF (MELVA3.NE.0) THEN
            IBMN = MIN(IB,IBM3)
            IF (IGM3.GT.1) THEN
              V3 = (  MELVA3.VELCHE(1,IBMN) + MELVA3.VELCHE(2,IBMN)
     &              + MELVA3.VELCHE(3,IBMN) ) * X1s3
            ELSE
              V3 = MELVA3.VELCHE(1,IBMN)
            ENDIF
          ENDIF
        ENDIF
C
        CALL DOXE(XCOOR,IDIM,3,NUM,IB,XE)
C
C       MATRICE DE PASSAGE
C
        CALL VPAST(XE,BPSS)
C
C       COORDONNEES LOCALES
C
        CALL VCORLC(XE,XEL,BPSS)
C
C   chgt de repere des forces appliquees
C
        VL1 = BPSS(1,1)*V1 + BPSS(1,2)*V2 + BPSS(1,3)*V3
        VL2 = BPSS(2,1)*V1 + BPSS(2,2)*V2 + BPSS(2,3)*V3
        VL3 = BPSS(3,1)*V1 + BPSS(3,2)*V2 + BPSS(3,3)*V3
C
        X21 = XEL(1,2) - XEL(1,1)
        Y31 = XEL(2,3) - XEL(2,1)
        r_z = X21 * Y31 * X1s6
        FXT   = r_z * VL1
        FYT   = r_z * VL2
        SURFZ = r_z * VL3
C
C        MISE A 0 DU VECTEUR FORCE
C
        DO I = 1, 18
          FT(I) = 0.D0
        ENDDO
C
C        INTEGRATION NUMERIQUE : IGAU NUMERO DU POINT DE GAUSS
C                                IA NUMERO D UN NOEUD
C
        DO 200 IGAU = 1, 3
          CALL MFDKT(XX(IGAU),YY(IGAU),XEL,BB)
          DO 210 IA = 1, 3
            IK = (IA-1)*3
            IP = IK*2+2
            FT(IP-1) = FXT
            FT(IP  ) = FYT
            FT(IP+1) = FT(IP+1) + SURFZ*BB(IK+1)
            FT(IP+2) = FT(IP+2) + SURFZ*BB(IK+2)
            FT(IP+3) = FT(IP+3) + SURFZ*BB(IK+3)
  210     CONTINUE
  200   CONTINUE
C
C        CHANGEMENT DE REPERE
C
        MPTVAL = IVAFOR
        DO 400 I = 1, 3
          KP = 6 * (I-1)
          DO 402 J = 1,3
            MELVAL = IVAL(J)
            VELCHE(I,IB) =   BPSS(1,J)*FT(1+KP) + BPSS(2,J)*FT(2+KP)
     &                     + BPSS(3,J)*FT(3+KP)
            MELVAL = IVAL(J+3)
            VELCHE(I,IB) =   BPSS(1,J)*FT(4+KP) + BPSS(2,J)*FT(5+KP)
     &                     + BPSS(3,J)*FT(6+KP)
 402      CONTINUE
 400    CONTINUE
 
 1000 CONTINUE
 
      IF (IPVECT.EQ.0) THEN
        IF (MELVA1.NE.0) SEGDES,MELVA1
        IF (MELVA2.NE.0) SEGDES,MELVA2
        IF (MELVA3.NE.0) SEGDES,MELVA3
      ENDIF
C*      SEGDES,MELEME          (&lt;- actif en E/S et non modifie)
 
      RETURN
      END