Sources Esope | Cast3M

fpma2d
C FPMA2D    SOURCE    CB215821  19/07/30    21:16:28     10273          
      SUBROUTINE FPMA2D(IPTVPR,IPMAIL,IPTINT,IVAFOR,IVACAR,XP)
C
C____________________________________________________________________
C   CALCULE LES FORCES DE PRESSIONS SUR LES FACES D ELEMENTS
C   MASSIFS BIDIMENSIONNELS
C
C   ENTREES :
C   ---------
C
C    IPTVPR  POINTEUR SUR UN MELVAL CONTENANT LES PRESSIONS APPLIQUEES
C            0  SI ON A DONNE UNE VALEUR 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 MELVALS CONTENANT LES FORCES
C            NODALE RESULTANTES
C    IVACAR  POINTEUR SUR UN MELVAL DE CARACTERISTIQUES
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 CCREEL
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
C
C= Quelques constantes (2.Pi)
      PARAMETER (X2Pi=6.283185307179586476925286766559D0)
 
      SEGMENT WORK
      REAL*8 XE(3,NBNN)
      ENDSEGMENT
C
      SEGMENT MPTVAL
      INTEGER IPOS(NS)    ,NSOF(NS)
      INTEGER      IVAL(NCOSOU)
      CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
*   prob optimiseur il faut initialiser melva1
      MELVA1=IVAFOR
      IF(IPTVPR.NE.0) THEN
         MELVA1=IPTVPR
      ENDIF
      MELVAL=MELVA1
C
      MINTE=IPTINT
      NBPGAU=POIGAU(/1)
C
      MELEME=IPMAIL
      NBNN  =NUM(/1)
      NBELEM=NUM(/2)
      SEGINI WORK
      DIM3=1.D0
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
C
C   RECUPERATION DE L'EPAISSEUR
C
            IF (IFOUR.EQ.-2) THEN
               MPTVAL=IVACAR
               IF (IVACAR.NE.0) THEN
                  IF(IVAL(1).NE.0) THEN
                     MELVAL=IVAL(1)
                     IGMN=MIN(IGAU,VELCHE(/1))
                     IBMN=MIN(IB,VELCHE(/2))
                     DIM3=VELCHE(IGMN,IBMN)
                  ELSE
                     DIM3=1.D0
                  ENDIF
               ENDIF
            ENDIF
*
            VNQSI1=0.D0
            VNQSI2=0.D0
            T1=0.D0
            T2=0.D0
            R=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)
               R=R+SHPTOT(1,I,IGAU)*XE(1,I)
 20         CONTINUE
            IF (IFOUR.LT.0) THEN
               R=1.D0
            ELSEIF (IFOUR.EQ.0.OR.(IFOUR.EQ.1
     +              .AND.NIFOUR.EQ.0)) THEN
               R=X2PI*R
            ELSEIF (IFOUR.EQ.1.AND.NIFOUR.NE.0) THEN
               R=XPI*R
            ENDIF
            IF (IFOUR.EQ.-2)   R=R*DIM3
*
            IF(IPTVPR.NE.0) THEN
               IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
               IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
               T1=POIGAU(IGAU)*MELVA1.VELCHE(IGMN,IBMN)*R*(-VNQSI2)
               T2=POIGAU(IGAU)*MELVA1.VELCHE(IGMN,IBMN)*R*VNQSI1
            ELSE
               T1=POIGAU(IGAU)*XP*R*(-VNQSI2)
               T2=POIGAU(IGAU)*XP*R*VNQSI1
            ENDIF
C
            MPTVAL=IVAFOR
            DO 30 J=1,NBNN
               MELVAL=IVAL(1)
               VELCHE(J,IB)=VELCHE(J,IB)+SHPTOT(1,J,IGAU)*T1
               MELVAL=IVAL(2)
               VELCHE(J,IB)=VELCHE(J,IB)+SHPTOT(1,J,IGAU)*T2
 30         CONTINUE
C
 10      CONTINUE
 1    CONTINUE
      SEGSUP WORK
      END