Télécharger la plaquette Cast3M


fr en

Télécharger vomsi3.eso

Retour à la liste

Numérotation des lignes : 

vomsi3

  1. C VOMSI3    SOURCE    GOUNAND   25/11/24    21:15:29     12406          
  2.       SUBROUTINE VOMSI3(MELEMX,IELDEB,IELFIN,NKPVIR,XVOL,XVOLS,XVOLV)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : VOMSI3
  7. C DESCRIPTION : VOlume d'un Maillage de SIMplexes
  8. C               MELEMX est supposé actif.
  9. C
  10. C     Comme VOMSI2 mais avec un MELEMX au lieu de MELEME
  11. C
  12. C LANGAGE     : ESOPE
  13. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  14. C               mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C VERSION    : v1, 03/11/2017, version initiale
  17. C HISTORIQUE : v1, 03/11/2017, création
  18. C HISTORIQUE :
  19. C HISTORIQUE :
  20. C***********************************************************************
  21. -INC CCGEOME
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMCOORD
  25. -INC TMATOP1
  26. *-INC SMELEMX
  27. -INC SMLREEL
  28.       LOGICAL LVIRT
  29. * Statement functions
  30. *      DETTRI(A11,A12,A21,A22)=A11*A22-A21*A12
  31.       DETTET(A11,A12,A13,A21,A22,A23,A31,A32,A33)=
  32.      &  A11*(A22*A33-A23*A32)
  33.      &       +A12*(A23*A31-A21*A33)
  34.      &       +A13*(A21*A32-A22*A31)
  35.  
  36. *
  37. * Executable statements
  38. *
  39.       XVOL=0.D0
  40.       XVOLS=0.D0
  41.       XVOLV=0.D0
  42. *Maillage vide
  43. *      SEGACT MELEMX
  44. *      IF (LISOUS(/1).EQ.0.AND.NUMX(/2).EQ.0) THEN
  45.       IF (NLCOU.EQ.0) THEN
  46.          WRITE(IOIMP,*) 'ITLOC coucou vomsi3'
  47.          write(ioimp,*) 'NLCOU=',NLCOU
  48.          write(ioimp,*) 'MELEMX=',MELEMX
  49.          CALL ECMELX(MELEMX,0)
  50.          CALL ERREUR(5)
  51.          RETURN
  52.       ENDIF
  53.       IDIMP1=IDIM+1
  54. *      NBNN=NUMX(/1)
  55.       NBNN=NNCOU
  56.       IF (NBNN.NE.IDIMP1) THEN
  57.          WRITE(IOIMP,*) 'NBNN=',NBNN
  58.          WRITE(IOIMP,*) 'IDIMP1=',IDIMP1
  59.          write(ioimp,*) 'MELEMX=',MELEMX
  60.          WRITE(IOIMP,*) 'ITLOC'
  61.          CALL ECMELX(MELEMX,0)
  62.          CALL ERREUR(5)
  63.          RETURN
  64.       ENDIF
  65.       IF
  66.      $     (.NOT.(IELDEB.GE.1.AND.IELFIN.GE.IELDEB.AND.NLCOU.GE.IELFIN
  67.      $     .AND.NUMX(/2).GE.NLCOU))  THEN
  68.          WRITE(IOIMP,*) 'ITLOC coucou vomsi3'
  69.          write(ioimp,*) 'IELDEB=',IELDEB
  70.          write(ioimp,*) 'IELFIN=',IELFIN
  71.          write(ioimp,*) 'NLCOU=',NLCOU
  72.          write(ioimp,*) 'NUM2=',NUMX(/2)
  73.          write(ioimp,*) 'MELEMX=',MELEMX
  74.          CALL ECMELX(MELEMX,0)
  75.          CALL ERREUR(5)
  76.          RETURN
  77.       ENDIF
  78. *
  79.       DO 10 IBELEM=IELDEB,IELFIN
  80. *         WRITE(IOIMP,*) 'IBELEM=',IBELEM
  81. * Volume d'un triangle
  82.          lvirt=.false.
  83.          IF (IDIM.EQ.2) THEN
  84.             I0=NUMX(1,IBELEM)
  85.             I1=NUMX(2,IBELEM)
  86.             I2=NUMX(3,IBELEM)
  87.             IF (NKPVIR.NE.0) THEN
  88. *               IF (I0.LE.NKPVIR.OR.I1.LE.NKPVIR.OR.I2.LE.NKPVIR) goto 10
  89.                IF (I0.LE.NKPVIR.OR.I1.LE.NKPVIR.OR.I2.LE.NKPVIR)
  90.      $              lvirt=.true.
  91.                ENDIF
  92.             IP0=(I0-1)*IDIMP1
  93.             IP1=(I1-1)*IDIMP1
  94.             IP2=(I2-1)*IDIMP1
  95.             X10=XCOOR(IP1+1)-XCOOR(IP0+1)
  96.             Y10=XCOOR(IP1+2)-XCOOR(IP0+2)
  97.             X20=XCOOR(IP2+1)-XCOOR(IP0+1)
  98.             Y20=XCOOR(IP2+2)-XCOOR(IP0+2)
  99. *     XVOL=ABS(DETTRI(X10,Y10,X20,Y20))/2.D0
  100.             XVOLIO=(X10*Y20-X20*Y10)/2.D0
  101. * Volume d'un tétraèdre
  102.          ELSEIF (IDIM.EQ.3) THEN
  103.             I0=NUMX(1,IBELEM)
  104.             I1=NUMX(2,IBELEM)
  105.             I2=NUMX(3,IBELEM)
  106.             I3=NUMX(4,IBELEM)
  107.             IF (NKPVIR.NE.0) THEN
  108. *               IF (I0.LE.NKPVIR.OR.I1.LE.NKPVIR.OR.I2.LE.NKPVIR.OR.
  109. *     $             I3.LE.NKPVIR) goto 10
  110.                IF (I0.LE.NKPVIR.OR.I1.LE.NKPVIR.OR.I2.LE.NKPVIR.OR.
  111.      $             I3.LE.NKPVIR) lvirt=.true.
  112.             ENDIF
  113.             IP0=(I0-1)*IDIMP1
  114.             IP1=(I1-1)*IDIMP1
  115.             IP2=(I2-1)*IDIMP1
  116.             IP3=(I3-1)*IDIMP1
  117.             X10=XCOOR(IP1+1)-XCOOR(IP0+1)
  118.             Y10=XCOOR(IP1+2)-XCOOR(IP0+2)
  119.             Z10=XCOOR(IP1+3)-XCOOR(IP0+3)
  120.             X20=XCOOR(IP2+1)-XCOOR(IP0+1)
  121.             Y20=XCOOR(IP2+2)-XCOOR(IP0+2)
  122.             Z20=XCOOR(IP2+3)-XCOOR(IP0+3)
  123.             X30=XCOOR(IP3+1)-XCOOR(IP0+1)
  124.             Y30=XCOOR(IP3+2)-XCOOR(IP0+2)
  125.             Z30=XCOOR(IP3+3)-XCOOR(IP0+3)
  126.             XVOLIO=(DETTET(X10,X20,X30,Y10,Y20,Y30,Z10,Z20
  127.      $           ,Z30))/6.D0
  128.          ENDIF
  129.          xvoli=abs(xvolio)
  130.          if (.not.lvirt) then
  131.             XVOL=XVOL+xvoli
  132.          else
  133.             XVOLV=XVOLV+xvoli
  134.          endif
  135.          XVOLS=XVOLS+xvolio
  136.  10   CONTINUE
  137.       RETURN
  138. *
  139. * End of subroutine VOMSI3
  140. *
  141.       END
  142.  
  143.  

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