Sources Esope | Cast3M

fpma3d
C FPMA3D    SOURCE    CB215821  20/01/21    21:15:11     10505          
      SUBROUTINE FPMA3D(IPTVPR,IPMAIL,IPTINT,IVAFOR,XP)
C
C____________________________________________________________________
C
C   CALCULE LES FORCES DE PRESSIONS SUR LES FACES D ELEMENTS
C   MASSIFS TRIDIMENSIONNELS
C
C   ENTREES :
C   ---------
C
C    IPTVPR  POINTEUR SUR UN MELVAL CONTENANT LES PRESSIONS APPLIQUEES
C            0 SI ON A DONNE UNE PRESSION CONSTANTE
C    IPMAIL  POINTEUR SUR UN OBJET GEOMETRIQUE
C    IPTINT  POINTEUR SUR UN MINTE CONTENANT LES POINTS D INTEGRATION
C            ACTIF EN ENTREE ET EN SORTIE SANS MODIFICATION
C    IVAFOR  POINTEUR SUR UN MPTVAL ET LES MELVAL CONTENANT LES FORCES
C            NODALES RESUL
C
C      JACQUELINE BROCHARD  AVRIL 85
C
C      PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 17 09 90
C
C______________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
C
      SEGMENT MPTVAL
        INTEGER      IPOS(NS),NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
      SEGMENT WORK
         REAL*8 XE(3,NBNN)
      ENDSEGMENT
C
*  pour daire plaisir a l'optimiseur
      melva1=iptint
      IF(IPTVPR.NE.0) THEN
        MELVA1=IPTVPR
        SEGACT MELVA1
      ENDIF
C
      MINTE=IPTINT
      NBPGAU=POIGAU(/1)
C
      MELEME=IPMAIL
      NBNN  =NUM(/1)
      NBELEM=NUM(/2)
C
      SEGINI WORK
      SEGACT,MCOORD
C
C     BOUCLE SUR LES ELEMENTS
C
      DO 1 IB=1,NBELEM
         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
C        BOUCLE SUR LES POINTS DE GAUSS
C
         DO 10 IGAU=1,NBPGAU
            VNQSI1=0.D0
            VNQSI2=0.D0
            VNQSI3=0.D0
            VNETA1=0.D0
            VNETA2=0.D0
            VNETA3=0.D0
C
            T1=0.D0
            T2=0.D0
            T3=0.D0
C
C           BOUCLE SUR LES NOEUDS
C
            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
C
            IF(IPTVPR.NE.0) THEN
              IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
              IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
              T1=POIGAU(IGAU)*(VNQSI2*VNETA3-VNQSI3*VNETA2)*
     1                      MELVA1.VELCHE(IGMN,IBMN)
              T2=POIGAU(IGAU)*(VNQSI3*VNETA1-VNQSI1*VNETA3)*
     1                      MELVA1.VELCHE(IGMN,IBMN)
              T3=POIGAU(IGAU)*(VNQSI1*VNETA2-VNQSI2*VNETA1)*
     1                      MELVA1.VELCHE(IGMN,IBMN)
            ELSE
              T1=POIGAU(IGAU)*(VNQSI2*VNETA3-VNQSI3*VNETA2)*XP
              T2=POIGAU(IGAU)*(VNQSI3*VNETA1-VNQSI1*VNETA3)*XP
              T3=POIGAU(IGAU)*(VNQSI1*VNETA2-VNQSI2*VNETA1)*XP
            ENDIF
C
            MPTVAL=IVAFOR
            MELVAL=IVAL(1)
            DO J=1,NBNN
               VELCHE(J,IB)=VELCHE(J,IB)+SHPTOT(1,J,IGAU)*T1
            ENDDO
            MELVAL=IVAL(2)
            DO J=1,NBNN
               VELCHE(J,IB)=VELCHE(J,IB)+SHPTOT(1,J,IGAU)*T2
            ENDDO
            MELVAL=IVAL(3)
            DO J=1,NBNN
               VELCHE(J,IB)=VELCHE(J,IB)+SHPTOT(1,J,IGAU)*T3
            ENDDO
  10     CONTINUE
   1  CONTINUE
      SEGDES,MCOORD
 
      SEGSUP WORK
      END