Sources Esope | Cast3M

fpco3d
C FPCO3D    SOURCE    PV        09/03/12    21:23:03     6325
      SUBROUTINE FPCO3D(IPTVPR,IPMAIL,IVAFOR)
C____________________________________________________________________
C
C   CALCULE LES FORCES DE PRESSIONS SUR LES COQUES 3D
C
C
C   ENTREES :
C   ---------
C
C    IPTVPR   MELVAL CONTENANT LES PRESSIONS APPLIQUEES (ACTIF)
C    IPMAIL   OBJET GEOMETRIQUE (ACTIF)
C    IVAFOR   POINTEUR SUR UN MPTVAL ET MELVALS ASSOCIEES AUX FORCES
C             NODALE RESULTANTES
C
C      JACQUELINE BROCHARD  AVRIL 85
C      PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 21 09 90
C
C____________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
-INC SMCHAML
-INC SMELEME
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
C
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
C
      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/
      DATA UNTIER/.33333333333333333D0/
C
      MELVA1=IPTVPR
      IGMN=MIN(3,MELVA1.VELCHE(/1))
C
      MELEME=IPMAIL
      NBELEM=NUM(/2)
C
C     BOUCLE SUR LES ELEMENTS
C
      DO 1000 IB=1,NBELEM
         IBMN=MIN(IB,MELVA1.VELCHE(/2))
         IF (IGMN.EQ.1) THEN
*
*           Champ constant
*
            P=MELVA1.VELCHE(1,IBMN)
         ELSE
*
*           P moyen sur l'element
*
            P=0.D0
            DO 11 IGAU=1,3
               P=MELVA1.VELCHE(IGAU,IBMN)+P
 11         CONTINUE
            P=P/3
         ENDIF
         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        MISE A 0 DU VECTEUR FORCE
C
         DO 100 I=1,18
 100     FT(I)=0.D0
         X21=XEL(1,2)-XEL(1,1)
         Y31=XEL(2,3)-XEL(2,1)
         SURF=X21*Y31*.5D0
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
               IP=(IA-1)*6+2
               IK=(IA-1)*3
               DO 220 ID=1,3
                  FT(IP+ID)=FT(IP+ID)+UNTIER*BB(IK+ID)
  220          CONTINUE
  210       CONTINUE
  200    CONTINUE
C
C        MULTIPLICATION PAR P*SURF
C
         DO 300 I=1,18
            FT(I)=FT(I)*SURF*P
  300    CONTINUE
C
C        CHANGEMENT DE REPERE
C
         DO 400 I=1,3
            KP=6*(I-1)
            MP=KP+3
            DO 401 II=1,6
 401        F(II)=0.D0
            DO 402 J=1,3
               LP=J
               NP=LP+3
               DO 403   JP=1,3
                  F(LP)=F(LP)+BPSS(JP,J)*FT(JP+KP)
                  F(NP)=F(NP)+BPSS(JP,J)*FT(JP+MP)
 403           CONTINUE
 402        CONTINUE
            MPTVAL=IVAFOR
            DO 410 K=1,6
               MELVAL=IVAL(K)
               VELCHE(I,IB)=F(K)
  410       CONTINUE
  400    CONTINUE
 1000 CONTINUE
      RETURN
      END