Télécharger la plaquette Cast3M


fr en

Télécharger fpma2d.eso

Retour à la liste

Numérotation des lignes : 

fpma2d

  1. C FPMA2D    SOURCE    JK148537  24/11/05    21:15:03     12066          
  2.       SUBROUTINE FPMA2D(IPTVPR,IPMAIL,ipmaim,IPTINT,IVAFOR,IVACAR,XP
  3.      +                  ,netn1,ietn1)
  4. C
  5. C____________________________________________________________________
  6. C   CALCULE LES FORCES DE PRESSIONS SUR LES FACES D ELEMENTS
  7. C   MASSIFS BIDIMENSIONNELS
  8. C
  9. C   ENTREES :
  10. C   ---------
  11. C
  12. C    IPTVPR  POINTEUR SUR UN MELVAL CONTENANT LES PRESSIONS APPLIQUEES
  13. C            0  SI ON A DONNE UNE VALEUR CONSTANTE
  14. C    IPMAIL  POINTEUR SUR UN OBJET GEOMETRIQUE
  15. C    IPTINT  POINTEUR SUR UN MINTE CONTENANT LES POINTS D INTEGRATION
  16. C            (ACTIF EN ENTREE ET EN SORTIE SANS MODIFICATION)
  17. C    IVAFOR  POINTEUR SUR UN MPTVAL ET LES MELVALS CONTENANT LES FORCES
  18. C            NODALE RESULTANTES
  19. C    IVACAR  POINTEUR SUR UN MELVAL DE CARACTERISTIQUES
  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 CCREEL
  31. -INC SMCHAML
  32. -INC SMELEME
  33. -INC SMINTE
  34. -INC SMCOORD
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. C
  39. C= Quelques constantes (2.Pi)
  40.       PARAMETER (X2Pi=6.283185307179586476925286766559D0)
  41.  
  42. C
  43.       segment netn(nbpts+1)
  44.       segment ietn(letn)
  45. C
  46.       SEGMENT WORK
  47.       REAL*8 XE(3,NBNN)
  48.       ENDSEGMENT
  49. C
  50.       SEGMENT MPTVAL
  51.       INTEGER IPOS(NS)    ,NSOF(NS)
  52.       INTEGER      IVAL(NCOSOU)
  53.       CHARACTER*16 TYVAL(NCOSOU)
  54.       ENDSEGMENT
  55.       real*8 V(2)
  56. C
  57. *   prob optimiseur il faut initialiser melva1
  58.       MELVA1=IVAFOR
  59.       IF(IPTVPR.NE.0) THEN
  60.          MELVA1=IPTVPR
  61.       ENDIF
  62.       MELVAL=MELVA1
  63. C
  64.       MINTE=IPTINT
  65.       NBPGAU=POIGAU(/1)
  66. C
  67. C
  68.       idimp1 = IDIM +1
  69.       netn = netn1
  70.       ietn = ietn1
  71. C
  72.       ipt1 = ipmaim
  73.       MELEME=IPMAIL
  74.       NBNN  =NUM(/1)
  75.       NBELEM=NUM(/2)
  76.       SEGINI WORK
  77.       DIM3=1.D0
  78. C
  79. C     BOUCLE SUR LES ELEMENTS
  80. C
  81.       DO 1 IB=1,NBELEM
  82.          if (netn1.ne.0) then
  83.            do 160 inf=1,num(/1)
  84.              ip=num(inf,ib)
  85.               id=netn(ip)+1
  86.               if=netn(ip+1)
  87.              do 165 itn=id,if
  88.               iem=ietn(itn)
  89.                jne=0
  90.                do 166 i0=1,num(/1)
  91.                do 166 i1=1,ipt1.num(/1)
  92.                 if (num(i0,ib).eq.ipt1.num(i1,iem)) jne=jne+1
  93.  166           continue
  94.                if (jne.eq.num(/1)) goto 170
  95.  165         continue
  96.  160       continue
  97.             CALL ERREUR(26)
  98. C            IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  99. C            GOTO 9990
  100.  170        CONTINUE
  101.             NBM=IPT1.NUM(/1)
  102.             NBMA1=NUM(/1)
  103.               XG=0.D0
  104.               YG=0.D0
  105.               DO INM=1,NBM
  106.                 IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  107.                 XG=XG+XCOOR(IREFM+1)
  108.                 YG=YG+XCOOR(IREFM+2)
  109.               ENDDO
  110.               XG=XG/NBM
  111.               YG=YG/NBM
  112.               XK=0.D0
  113.               YK=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.               ENDDO
  119.               XK=XK/NBMA1
  120.               YK=YK/NBMA1
  121.               V(1)=XG-XK
  122.               V(2)=YG-YK
  123.               VN=SQRT(V(1)**2+V(2)**2)
  124.               V(1)=V(1)/VN
  125.               V(2)=V(2)/VN
  126.          endif
  127.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  128. C
  129. C        BOUCLE SUR LES POINTS DE GAUSS
  130. C
  131.          xflot = 1d0
  132.          DO 10 IGAU=1,NBPGAU
  133. C
  134. C   RECUPERATION DE L'EPAISSEUR
  135. C
  136.             IF (IFOUR.EQ.-2) THEN
  137.                MPTVAL=IVACAR
  138.                IF (IVACAR.NE.0) THEN
  139.                   IF(IVAL(1).NE.0) THEN
  140.                      MELVAL=IVAL(1)
  141.                      IGMN=MIN(IGAU,VELCHE(/1))
  142.                      IBMN=MIN(IB,VELCHE(/2))
  143.                      DIM3=VELCHE(IGMN,IBMN)
  144.                   ELSE
  145.                      DIM3=1.D0
  146.                   ENDIF
  147.                ENDIF
  148.             ENDIF
  149. *
  150.             VNQSI1=0.D0
  151.             VNQSI2=0.D0
  152.             T1=0.D0
  153.             T2=0.D0
  154.             R=0.D0
  155. C
  156. C           BOUCLE SUR LES NOEUDS
  157. C
  158.             DO 20 I=1,NBNN
  159.                VNQSI1=VNQSI1+SHPTOT(2,I,IGAU)*XE(1,I)
  160.                VNQSI2=VNQSI2+SHPTOT(2,I,IGAU)*XE(2,I)
  161.                R=R+SHPTOT(1,I,IGAU)*XE(1,I)
  162.  20         CONTINUE
  163.             if (igau.eq.1.and.netn1.ne.0) then
  164.               vnn1=-vnqsi2
  165.               vnn2=vnqsi1
  166.               vnnn =sqrt( vnn1*vnn1+vnn2*vnn2 )
  167.               vnn1 = vnn1 / vnnn
  168.               vnn2 = vnn2 / vnnn
  169.               test = v(1) * vnn1 + v(2) * vnn2 
  170.               if (test.lt.0d0) xflot=-1d0
  171.             endif
  172.             IF (IFOUR.LT.0) THEN
  173.                R=1.D0
  174.             ELSEIF (IFOUR.EQ.0.OR.(IFOUR.EQ.1
  175.      +              .AND.NIFOUR.EQ.0)) THEN
  176.                R=X2PI*R
  177.             ELSEIF (IFOUR.EQ.1.AND.NIFOUR.NE.0) THEN
  178.                R=XPI*R
  179.             ENDIF
  180.             IF (IFOUR.EQ.-2)   R=R*DIM3
  181. *
  182.             IF(IPTVPR.NE.0) THEN
  183.                IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
  184.                IBMN=MIN(IB  ,MELVA1.VELCHE(/2))
  185.                T1=POIGAU(IGAU)*MELVA1.VELCHE(IGMN,IBMN)*R*(-VNQSI2)
  186.      +         *xflot
  187.                T2=POIGAU(IGAU)*MELVA1.VELCHE(IGMN,IBMN)*R*VNQSI1*xflot
  188.             ELSE
  189.                T1=POIGAU(IGAU)*XP*R*(-VNQSI2)*xflot
  190.                T2=POIGAU(IGAU)*XP*R*VNQSI1*xflot
  191.             ENDIF
  192. C
  193.             MPTVAL=IVAFOR
  194.             DO 30 J=1,NBNN
  195.                MELVAL=IVAL(1)
  196.                VELCHE(J,IB)=VELCHE(J,IB)+SHPTOT(1,J,IGAU)*T1
  197.                MELVAL=IVAL(2)
  198.                VELCHE(J,IB)=VELCHE(J,IB)+SHPTOT(1,J,IGAU)*T2
  199.  30         CONTINUE
  200. C
  201.  10      CONTINUE
  202.  1    CONTINUE
  203.       SEGSUP WORK
  204.       END
  205.  
  206.  
  207.  
  208.  

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