Télécharger la plaquette Cast3M


fr en

Télécharger fpma3d.eso

Retour à la liste

Numérotation des lignes : 

fpma3d

  1. C FPMA3D    SOURCE    JK148537  24/11/05    21:15:04     12066          
  2.       SUBROUTINE FPMA3D(IPTVPR,IPMAIL,ipmaim,IPTINT,IVAFOR,XP
  3.      +                  ,netn1,ietn1)
  4. C
  5. C____________________________________________________________________
  6. C
  7. C   CALCULE LES FORCES DE PRESSIONS SUR LES FACES D ELEMENTS
  8. C   MASSIFS TRIDIMENSIONNELS
  9. C
  10. C   ENTREES :
  11. C   ---------
  12. C
  13. C    IPTVPR  POINTEUR SUR UN MELVAL CONTENANT LES PRESSIONS APPLIQUEES
  14. C            0 SI ON A DONNE UNE PRESSION CONSTANTE
  15. C    IPMAIL  POINTEUR SUR UN OBJET GEOMETRIQUE
  16. C    IPTINT  POINTEUR SUR UN MINTE CONTENANT LES POINTS D INTEGRATION
  17. C            ACTIF EN ENTREE ET EN SORTIE SANS MODIFICATION
  18. C    IVAFOR  POINTEUR SUR UN MPTVAL ET LES MELVAL CONTENANT LES FORCES
  19. C            NODALES RESUL
  20. C
  21. C      JACQUELINE BROCHARD  AVRIL 85
  22. C
  23. C      PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 17 09 90
  24. C
  25. C______________________________________________________________________
  26. C
  27.       IMPLICIT INTEGER(I-N)
  28.       IMPLICIT REAL*8(A-H,O-Z)
  29. C
  30. -INC SMCHAML
  31. -INC SMELEME
  32. -INC SMINTE
  33. -INC SMCOORD
  34.  
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. C
  38.       segment netn(nbpts+1)
  39.       segment ietn(letn)
  40. C
  41. C
  42.       SEGMENT MPTVAL
  43.         INTEGER      IPOS(NS),NSOF(NS)
  44.         INTEGER      IVAL(NCOSOU)
  45.         CHARACTER*16 TYVAL(NCOSOU)
  46.       ENDSEGMENT
  47. C
  48.       SEGMENT WORK
  49.          REAL*8 XE(3,NBNN)
  50.       ENDSEGMENT
  51.       real*8 V(3)
  52. C
  53. *  pour daire plaisir a l'optimiseur
  54.       melva1=iptint
  55.       IF(IPTVPR.NE.0) THEN
  56.         MELVA1=IPTVPR
  57.         SEGACT MELVA1
  58.       ENDIF
  59. C
  60.       MINTE=IPTINT
  61.       NBPGAU=POIGAU(/1)
  62. C
  63.       idimp1 = IDIM +1
  64.       netn = netn1
  65.       ietn = ietn1
  66. C
  67.       ipt1 = ipmaim
  68.       MELEME=IPMAIL
  69.       NBNN  =NUM(/1)
  70.       NBELEM=NUM(/2)
  71. C
  72.       SEGINI WORK
  73.       SEGACT,MCOORD
  74. C
  75. C     BOUCLE SUR LES ELEMENTS
  76. C
  77.       DO 1 IB=1,NBELEM
  78.          if (netn1.ne.0) then
  79.            do 160 inf=1,num(/1)
  80.              ip=num(inf,ib)
  81.               id=netn(ip)+1
  82.               if=netn(ip+1)
  83.              do 165 itn=id,if
  84.               iem=ietn(itn)
  85.                jne=0
  86.                do 166 i0=1,num(/1)
  87.                do 166 i1=1,ipt1.num(/1)
  88.                 if (num(i0,ib).eq.ipt1.num(i1,iem)) jne=jne+1
  89.  166           continue
  90.                if (jne.eq.num(/1)) goto 170
  91.  165         continue
  92.  160       continue
  93.             CALL ERREUR(26)
  94. C            IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  95. C            GOTO 9990
  96.  170        CONTINUE
  97.             NBM=IPT1.NUM(/1)
  98.             NBMA1=NUM(/1)
  99.               XG=0.D0
  100.               YG=0.D0
  101.               ZG=0.D0
  102.               DO INM=1,NBM
  103.                 IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  104.                 XG=XG+XCOOR(IREFM+1)
  105.                 YG=YG+XCOOR(IREFM+2)
  106.                 ZG=ZG+XCOOR(IREFM+3)
  107.               ENDDO
  108.               XG=XG/NBM
  109.               YG=YG/NBM
  110.               ZG=ZG/NBM
  111.               XK=0.D0
  112.               YK=0.D0
  113.               ZK=0.D0
  114.               DO INF=1,NBMA1
  115.                 IREFF=(NUM(INF,IB)-1)*idimp1
  116.                 XK=XK+XCOOR(IREFF+1)
  117.                 YK=YK+XCOOR(IREFF+2)
  118.                 ZK=ZK+XCOOR(IREFF+3)
  119.               ENDDO
  120.               XK=XK/NBMA1
  121.               YK=YK/NBMA1
  122.               ZK=ZK/NBMA1
  123.               V(1)=XG-XK
  124.               V(2)=YG-YK
  125.               V(3)=ZG-ZK
  126.               VN=SQRT(V(1)**2+V(2)**2+V(3)**2)
  127.               V(1)=V(1)/VN
  128.               V(2)=V(2)/VN
  129.               V(3)=V(3)/VN
  130.          endif
  131. C
  132.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  133. C
  134. C        BOUCLE SUR LES POINTS DE GAUSS
  135. C
  136.          xflot = 1d0
  137.          DO 10 IGAU=1,NBPGAU
  138.             VNQSI1=0.D0
  139.             VNQSI2=0.D0
  140.             VNQSI3=0.D0
  141.             VNETA1=0.D0
  142.             VNETA2=0.D0
  143.             VNETA3=0.D0
  144. C
  145.             T1=0.D0
  146.             T2=0.D0
  147.             T3=0.D0
  148. C
  149. C           BOUCLE SUR LES NOEUDS
  150. C
  151.             DO 20 I=1,NBNN
  152.                VNQSI1=VNQSI1+SHPTOT(2,I,IGAU)*XE(1,I)
  153.                VNQSI2=VNQSI2+SHPTOT(2,I,IGAU)*XE(2,I)
  154.                VNQSI3=VNQSI3+SHPTOT(2,I,IGAU)*XE(3,I)
  155.                VNETA1=VNETA1+SHPTOT(3,I,IGAU)*XE(1,I)
  156.                VNETA2=VNETA2+SHPTOT(3,I,IGAU)*XE(2,I)
  157.                VNETA3=VNETA3+SHPTOT(3,I,IGAU)*XE(3,I)
  158.  20         CONTINUE
  159. c
  160.             if (igau.eq.1.and.netn1.ne.0) then
  161.               vnn1=vnqsi2*vneta3-vnqsi3*vneta2
  162.               vnn2=vnqsi3*vneta1-vnqsi1*vneta3
  163.               vnn3=vnqsi1*vneta2-vnqsi2*vneta1
  164.               vnnn =sqrt( vnn1*vnn1+vnn2*vnn2+vnn3*vnn3)
  165.               vnn1 = vnn1 / vnnn
  166.               vnn2 = vnn2 / vnnn
  167.               vnn3 = vnn3 / vnnn
  168.               test = v(1) * vnn1 + v(2) * vnn2 + v(3) * vnn3
  169.               if (test.lt.0d0) xflot=-1d0
  170.             endif
  171. C
  172.             IF(IPTVPR.NE.0) THEN
  173.               IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
  174.               IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
  175.               T1=POIGAU(IGAU)*(VNQSI2*VNETA3-VNQSI3*VNETA2)*
  176.      1                      MELVA1.VELCHE(IGMN,IBMN)
  177.               T2=POIGAU(IGAU)*(VNQSI3*VNETA1-VNQSI1*VNETA3)*
  178.      1                      MELVA1.VELCHE(IGMN,IBMN)
  179.               T3=POIGAU(IGAU)*(VNQSI1*VNETA2-VNQSI2*VNETA1)*
  180.      1                      MELVA1.VELCHE(IGMN,IBMN)
  181.             ELSE
  182.               T1=POIGAU(IGAU)*(VNQSI2*VNETA3-VNQSI3*VNETA2)*XP
  183.               T2=POIGAU(IGAU)*(VNQSI3*VNETA1-VNQSI1*VNETA3)*XP
  184.               T3=POIGAU(IGAU)*(VNQSI1*VNETA2-VNQSI2*VNETA1)*XP
  185.             ENDIF
  186. C
  187.             MPTVAL=IVAFOR
  188.             MELVAL=IVAL(1)
  189.             DO J=1,NBNN
  190.                VELCHE(J,IB)=VELCHE(J,IB)+xflot*SHPTOT(1,J,IGAU)*T1
  191.             ENDDO
  192.             MELVAL=IVAL(2)
  193.             DO J=1,NBNN
  194.                VELCHE(J,IB)=VELCHE(J,IB)+xflot*SHPTOT(1,J,IGAU)*T2
  195.             ENDDO
  196.             MELVAL=IVAL(3)
  197.             DO J=1,NBNN
  198.                VELCHE(J,IB)=VELCHE(J,IB)+xflot*SHPTOT(1,J,IGAU)*T3
  199.             ENDDO
  200.   10     CONTINUE
  201.    1  CONTINUE
  202.       SEGDES,MCOORD
  203.  
  204.       SEGSUP WORK
  205.       END
  206.  
  207.  
  208.  
  209.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales