Télécharger baryce.eso

Retour à la liste

Numérotation des lignes :

  1. C BARYCE SOURCE PV 20/04/01 21:15:15 10569
  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*mod
  28. IDIMP1=IDIM+1
  29.  
  30. CALL LIRMOT('ELEM',1,IELEM,0)
  31. IF (IELEM.EQ.1) GOTO 10
  32.  
  33.  
  34. C======================================================================
  35. c BARYcentre du maillage
  36. C======================================================================
  37.  
  38. XGRAV(1)=0.D0
  39. XGRAV(2)=0.D0
  40. XGRAV(3)=0.D0
  41. XGRAV(4)=0.D0
  42. NPOIN=0
  43.  
  44. SEGACT,MELEME
  45. IPT1=MELEME
  46.  
  47. C BOUCLE SUR LE(S) MAILLAGE(S) ELEMENTAIRES
  48. DO 2 IO=1,MAX(1,LISOUS(/1))
  49. IF (LISOUS(/1).NE.0) THEN
  50. IPT1=LISOUS(IO)
  51. SEGACT IPT1
  52. ENDIF
  53.  
  54. NPOIN=NPOIN+IPT1.NUM(/2)*IPT1.NUM(/1)
  55. DO 3 J=1,IPT1.NUM(/2)
  56. DO 3 I=1,IPT1.NUM(/1)
  57. IREF=IDIMP1*(IPT1.NUM(I,J)-1)
  58. DO 5 L=1,IDIMP1
  59. 5 XGRAV(L)=XGRAV(L)+XCOOR(IREF+L)
  60. 3 CONTINUE
  61.  
  62. IF (LISOUS(/1).NE.0) SEGDES IPT1
  63. 2 CONTINUE
  64.  
  65. SEGDES,MELEME
  66.  
  67. C ERREUR SI MAILLAGE VIDE
  68. IF (NPOIN.EQ.0) THEN
  69. MOTERR(1:8)='MAILLAGE'
  70. CALL ERREUR(1027)
  71. RETURN
  72. ENDIF
  73.  
  74. C ON MET LE CENTRE DE GRAVITE DANS LA TABLE DES POINTS
  75. NBPTS=NBPTS+1
  76. SEGADJ,MCOORD
  77. IREF=(NBPTS-1)*IDIMP1
  78. DO 7 I=1,IDIMP1
  79. XCOOR(IREF+I)=XGRAV(I)/NPOIN
  80. 7 CONTINUE
  81. KGRAV=nbpts
  82.  
  83. CALL ECROBJ('POINT ',KGRAV)
  84. RETURN
  85.  
  86.  
  87. 10 CONTINUE
  88. C======================================================================
  89. c BARYcentre de chaque ELEMent du maillage
  90. C======================================================================
  91.  
  92. c CREATION D'UN NOUVEAU MAILLAGE DE POI1
  93. NBNN = 1
  94. NBELEM = 0
  95. NBSOUS = 0
  96. NBREF = 0
  97. SEGINI,IPT2
  98. IPT2.ITYPEL = 1
  99. J2 = 0
  100.  
  101. SEGACT,MELEME
  102. IPT1=MELEME
  103.  
  104. C BOUCLE SUR LE(S) MAILLAGE(S) ELEMENTAIRES
  105. DO 12 IO=1,MAX(1,LISOUS(/1))
  106. IF (LISOUS(/1).NE.0) THEN
  107. IPT1=LISOUS(IO)
  108. SEGACT IPT1
  109. ENDIF
  110.  
  111. NBELEM = NBELEM + IPT1.NUM(/2)
  112. SEGADJ,IPT2
  113. NBPTSJ=NBPTS
  114. NBPTS=NBPTS + IPT1.NUM(/2)
  115. SEGADJ,MCOORD
  116.  
  117. DO 13 J=1,IPT1.NUM(/2)
  118. XGRAV(1)=0.D0
  119. XGRAV(2)=0.D0
  120. XGRAV(3)=0.D0
  121. XGRAV(4)=0.D0
  122. DO 14 I=1,IPT1.NUM(/1)
  123. IREF=IDIMP1*(IPT1.NUM(I,J)-1)
  124. DO 15 L=1,IDIMP1
  125. 15 XGRAV(L)=XGRAV(L)+XCOOR(IREF+L)
  126. 14 CONTINUE
  127. C ON MET LE CENTRE DE GRAVITE DANS:
  128. C LE MAILLAGE IPT2 + LA TABLE DES POINTS XCOOR
  129. NBPTSJ=NBPTSJ+1
  130. J2=J2+1
  131. IPT2.NUM(1,J2)=NBPTSJ
  132. IPT2.ICOLOR(J2)=IPT1.ICOLOR(J)
  133. IREF=(NBPTSJ-1)*IDIMP1
  134. DO 17 I=1,IDIMP1
  135. XCOOR(IREF+I)=XGRAV(I)/IPT1.NUM(/1)
  136. 17 CONTINUE
  137. 13 CONTINUE
  138. IF (LISOUS(/1).NE.0) SEGDES IPT1
  139. 12 CONTINUE
  140.  
  141. C ERREUR SI MAILLAGE VIDE
  142. IF (NBELEM.EQ.0) THEN
  143. MOTERR(1:8)='MAILLAGE'
  144. CALL ERREUR(1027)
  145. RETURN
  146. ENDIF
  147.  
  148. SEGDES,MELEME
  149. SEGDES,IPT2
  150. CALL ECROBJ('MAILLAGE',IPT2)
  151.  
  152.  
  153. RETURN
  154. END
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  

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