Sources Esope | Cast3M

fsma3d
C FSMA3D    SOURCE    OF166741  25/02/21    21:17:06     12166          
 
      SUBROUTINE FSMA3D(IPT,IPMAIL,IPTINT,IPVECT,VEC,IVAFOR)
 
C____________________________________________________________________
C
C   CALCULE LES FORCES SURFACIQUES SUR LES FACES D ELEMENTS
C   MASSIFS TRIDIMENSIONNELS
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  POINTEUR SUR UN OBJET GEOMETRIQUE
C    IPTINT  POINTEUR SUR UN MINTE CONTENANT LES POINTS D INTEGRATION
C    IPVECT  POINTEUR SUR LE VECTEUR REPRESENTANT LA FORCE
C    VEC     VECTEUR REPRESENTANT LA FORCE
C    IVAFOR  POINTEUR SUR UN MPTVAL ET LES MELVAL CONTENANT LES FORCES
C            NODALES RESUL
C
C______________________________________________________________________
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD
 
-INC TMPTVAL
 
      SEGMENT WORK
         REAL*8 XE(3,NBNN)
      ENDSEGMENT
 
      DIMENSION VEC(*),IPT(*)
 
      MELVA1 = IPT(1)
      MELVA2 = IPT(2)
      MELVA3 = IPT(3)
      IF (IPVECT.EQ.0) THEN
        IF (MELVA1.NE.0) THEN
          SEGACT,MELVA1
          IGM1 = MELVA1.VELCHE(/1)
          IBM1 = MELVA1.VELCHE(/2)
        ENDIF
        IF (MELVA2.NE.0) THEN
          SEGACT,MELVA2
          IGM2 = MELVA2.VELCHE(/1)
          IBM2 = MELVA2.VELCHE(/2)
        ENDIF
        IF (MELVA3.NE.0) THEN
          SEGACT,MELVA3
          IGM3 = MELVA3.VELCHE(/1)
          IBM3 = MELVA3.VELCHE(/2)
        ENDIF
        AUX1 = 0.D0
        AUX2 = 0.D0
        AUX3 = 0.D0
      ELSE
        AUX1 = VEC(1)
        AUX2 = VEC(2)
        AUX3 = VEC(3)
      ENDIF
 
      MINTE=IPTINT
C*      SEGACT,MINTE           &lt;- ACTIF EN E/S (NON MODIFIE)
      NBPGAU=POIGAU(/1)
 
      MELEME=IPMAIL
C*      SEGACT,MELEME          &lt;- ACTIF EN E/S (NON MODIFIE)
      NBNN  =NUM(/1)
      NBELEM=NUM(/2)
 
      SEGINI,WORK
C
C     BOUCLE SUR LES ELEMENTS
C
      DO 1 IB = 1, NBELEM
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
 
        IF (IPVECT.EQ.0) THEN
          IF (MELVA1.NE.0) IB1 = MIN(IB,IBM1)
          IF (MELVA2.NE.0) IB2 = MIN(IB,IBM2)
          IF (MELVA3.NE.0) IB3 = MIN(IB,IBM3)
        ENDIF
C
C        BOUCLE SUR LES POINTS DE GAUSS
C
        DO 10 IGAU=1,NBPGAU
C
C
C           BOUCLE SUR LES NOEUDS
C
          VNQSI1 = 0.D0
          VNQSI2 = 0.D0
          VNQSI3 = 0.D0
          VNETA1 = 0.D0
          VNETA2 = 0.D0
          VNETA3 = 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)
            VNQSI3=VNQSI3+SHPTOT(2,I,IGAU)*XE(3,I)
            VNETA1=VNETA1+SHPTOT(3,I,IGAU)*XE(1,I)
            VNETA2=VNETA2+SHPTOT(3,I,IGAU)*XE(2,I)
            VNETA3=VNETA3+SHPTOT(3,I,IGAU)*XE(3,I)
 20       CONTINUE
          VNOR1 = VNQSI2*VNETA3-VNQSI3*VNETA2
          VNOR2 = VNQSI3*VNETA1-VNQSI1*VNETA3
          VNOR3 = VNQSI1*VNETA2-VNQSI2*VNETA1
          r_z = POIGAU(IGAU) * SQRT(VNOR1*VNOR1+VNOR2*VNOR2+VNOR3*VNOR3)
C
          IF (IPVECT.EQ.0) THEN
            IF (MELVA1.NE.0) THEN
              IGMN = MIN(IGAU,IGM1)
              AUX1 = MELVA1.VELCHE(IGMN,IB1)
            ENDIF
            IF (MELVA2.NE.0) THEN
              IGMN = MIN(IGAU,IGM2)
              AUX2 = MELVA2.VELCHE(IGMN,IB2)
            ENDIF
            IF (MELVA3.NE.0) THEN
              IGMN = MIN(IGAU,IGM3)
              AUX3 = MELVA3.VELCHE(IGMN,IB3)
            ENDIF
          ENDIF
*
          T1 = r_z * AUX1
          T2 = r_z * AUX2
          T3 = r_z * AUX3
C
          MPTVAL=IVAFOR
          DO 30 J=1,NBNN
            r_z = SHPTOT(1,J,IGAU)
            MELVAL = IVAL(1)
            VELCHE(J,IB) = VELCHE(J,IB) + r_z * T1
            MELVAL = IVAL(2)
            VELCHE(J,IB) = VELCHE(J,IB) + r_z * T2
            MELVAL = IVAL(3)
            VELCHE(J,IB) = VELCHE(J,IB) + r_z * T3
  30      CONTINUE
 
  10    CONTINUE
 
   1  CONTINUE
 
      SEGSUP WORK
 
      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 (NON MODIFIE)
C*      SEGDES,MINTE           &lt;- ACTIF EN E/S (NON MODIFIE)
 
      RETURN
      END