Télécharger baryce.eso

Retour à la liste

Numérotation des lignes :

  1. C BARYCE SOURCE BP208322 16/12/14 21:15:01 9260
  2. *
  3. *---------------------------------------------------------------*
  4. * CALCUL LE BARYCENTRE D'UN OBJET MAILLAGE
  5. *
  6. * Creation : ???
  7. * Modif : BP, 2016-12-13 : ajout de l'option 'ELEM'
  8. *---------------------------------------------------------------*
  9. *
  10. SUBROUTINE BARYCE
  11. IMPLICIT INTEGER(I-N)
  12. IMPLICIT REAL*8(A-H,O-Z)
  13.  
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC SMCOORD
  17.  
  18. DIMENSION XGRAV(4)
  19.  
  20. C======================================================================
  21. c LECTURES, ACTIVATIONS ET INITIALISATIONS
  22. C======================================================================
  23.  
  24. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  25. IF (IERR.NE.0) RETURN
  26.  
  27. SEGACT,MCOORD
  28. IDIMP1=IDIM+1
  29. NBPTS=XCOOR(/1)/IDIMP1
  30.  
  31. CALL LIRMOT('ELEM',1,IELEM,0)
  32. IF (IELEM.EQ.1) GOTO 10
  33.  
  34.  
  35. C======================================================================
  36. c BARYcentre du maillage
  37. C======================================================================
  38.  
  39. XGRAV(1)=0.D0
  40. XGRAV(2)=0.D0
  41. XGRAV(3)=0.D0
  42. XGRAV(4)=0.D0
  43. NPOIN=0
  44.  
  45. SEGACT,MELEME
  46. IPT1=MELEME
  47.  
  48. C BOUCLE SUR LE(S) MAILLAGE(S) ELEMENTAIRES
  49. DO 2 IO=1,MAX(1,LISOUS(/1))
  50. IF (LISOUS(/1).NE.0) THEN
  51. IPT1=LISOUS(IO)
  52. SEGACT IPT1
  53. ENDIF
  54.  
  55. NPOIN=NPOIN+IPT1.NUM(/2)*IPT1.NUM(/1)
  56. DO 3 J=1,IPT1.NUM(/2)
  57. DO 3 I=1,IPT1.NUM(/1)
  58. IREF=IDIMP1*(IPT1.NUM(I,J)-1)
  59. DO 5 L=1,IDIMP1
  60. 5 XGRAV(L)=XGRAV(L)+XCOOR(IREF+L)
  61. 3 CONTINUE
  62.  
  63. IF (LISOUS(/1).NE.0) SEGDES IPT1
  64. 2 CONTINUE
  65.  
  66. SEGDES,MELEME
  67.  
  68. C ON MET LE CENTRE DE GRAVITE DANS LA TABLE DES POINTS
  69. NBPTS=XCOOR(/1)/IDIMP1+1
  70. SEGADJ,MCOORD
  71. IREF=(NBPTS-1)*IDIMP1
  72. DO 7 I=1,IDIMP1
  73. XCOOR(IREF+I)=XGRAV(I)/NPOIN
  74. 7 CONTINUE
  75. KGRAV=XCOOR(/1)/IDIMP1
  76.  
  77. CALL ECROBJ('POINT ',KGRAV)
  78. RETURN
  79.  
  80.  
  81. 10 CONTINUE
  82. C======================================================================
  83. c BARYcentre de chaque ELEMent du maillage
  84. C======================================================================
  85.  
  86. c CREATION D'UN NOUVEAU MAILLAGE DE POI1
  87. NBNN = 1
  88. NBELEM = 0
  89. NBSOUS = 0
  90. NBREF = 0
  91. SEGINI,IPT2
  92. IPT2.ITYPEL = 1
  93. J2 = 0
  94.  
  95. SEGACT,MELEME
  96. IPT1=MELEME
  97.  
  98. C BOUCLE SUR LE(S) MAILLAGE(S) ELEMENTAIRES
  99. DO 12 IO=1,MAX(1,LISOUS(/1))
  100. IF (LISOUS(/1).NE.0) THEN
  101. IPT1=LISOUS(IO)
  102. SEGACT IPT1
  103. ENDIF
  104.  
  105. NBELEM = NBELEM + IPT1.NUM(/2)
  106. SEGADJ,IPT2
  107. NBPTSJ=NBPTS
  108. NBPTS=NBPTS + IPT1.NUM(/2)
  109. SEGADJ,MCOORD
  110.  
  111. DO 13 J=1,IPT1.NUM(/2)
  112. XGRAV(1)=0.D0
  113. XGRAV(2)=0.D0
  114. XGRAV(3)=0.D0
  115. XGRAV(4)=0.D0
  116. DO 14 I=1,IPT1.NUM(/1)
  117. IREF=IDIMP1*(IPT1.NUM(I,J)-1)
  118. DO 15 L=1,IDIMP1
  119. 15 XGRAV(L)=XGRAV(L)+XCOOR(IREF+L)
  120. 14 CONTINUE
  121. C ON MET LE CENTRE DE GRAVITE DANS:
  122. C LE MAILLAGE IPT2 + LA TABLE DES POINTS XCOOR
  123. NBPTSJ=NBPTSJ+1
  124. J2=J2+1
  125. IPT2.NUM(1,J2)=NBPTSJ
  126. IPT2.ICOLOR(J2)=IPT1.ICOLOR(J)
  127. IREF=(NBPTSJ-1)*IDIMP1
  128. DO 17 I=1,IDIMP1
  129. XCOOR(IREF+I)=XGRAV(I)/IPT1.NUM(/1)
  130. 17 CONTINUE
  131. 13 CONTINUE
  132. IF (LISOUS(/1).NE.0) SEGDES IPT1
  133. 12 CONTINUE
  134.  
  135. SEGDES,MELEME
  136. SEGDES,IPT2
  137. CALL ECROBJ('MAILLAGE',IPT2)
  138.  
  139.  
  140. RETURN
  141. END
  142.  
  143.  
  144.  
  145.  

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