Télécharger baryce.eso

Retour à la liste

Numérotation des lignes :

  1. C BARYCE SOURCE JC220346 17/12/12 21:15:01 9662
  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 ERREUR SI MAILLAGE VIDE
  69. IF (NPOIN.EQ.0) THEN
  70. MOTERR(1:8)='MAILLAGE'
  71. CALL ERREUR(1027)
  72. RETURN
  73. ENDIF
  74.  
  75. C ON MET LE CENTRE DE GRAVITE DANS LA TABLE DES POINTS
  76. NBPTS=XCOOR(/1)/IDIMP1+1
  77. SEGADJ,MCOORD
  78. IREF=(NBPTS-1)*IDIMP1
  79. DO 7 I=1,IDIMP1
  80. XCOOR(IREF+I)=XGRAV(I)/NPOIN
  81. 7 CONTINUE
  82. KGRAV=XCOOR(/1)/IDIMP1
  83.  
  84. CALL ECROBJ('POINT ',KGRAV)
  85. RETURN
  86.  
  87.  
  88. 10 CONTINUE
  89. C======================================================================
  90. c BARYcentre de chaque ELEMent du maillage
  91. C======================================================================
  92.  
  93. c CREATION D'UN NOUVEAU MAILLAGE DE POI1
  94. NBNN = 1
  95. NBELEM = 0
  96. NBSOUS = 0
  97. NBREF = 0
  98. SEGINI,IPT2
  99. IPT2.ITYPEL = 1
  100. J2 = 0
  101.  
  102. SEGACT,MELEME
  103. IPT1=MELEME
  104.  
  105. C BOUCLE SUR LE(S) MAILLAGE(S) ELEMENTAIRES
  106. DO 12 IO=1,MAX(1,LISOUS(/1))
  107. IF (LISOUS(/1).NE.0) THEN
  108. IPT1=LISOUS(IO)
  109. SEGACT IPT1
  110. ENDIF
  111.  
  112. NBELEM = NBELEM + IPT1.NUM(/2)
  113. SEGADJ,IPT2
  114. NBPTSJ=NBPTS
  115. NBPTS=NBPTS + IPT1.NUM(/2)
  116. SEGADJ,MCOORD
  117.  
  118. DO 13 J=1,IPT1.NUM(/2)
  119. XGRAV(1)=0.D0
  120. XGRAV(2)=0.D0
  121. XGRAV(3)=0.D0
  122. XGRAV(4)=0.D0
  123. DO 14 I=1,IPT1.NUM(/1)
  124. IREF=IDIMP1*(IPT1.NUM(I,J)-1)
  125. DO 15 L=1,IDIMP1
  126. 15 XGRAV(L)=XGRAV(L)+XCOOR(IREF+L)
  127. 14 CONTINUE
  128. C ON MET LE CENTRE DE GRAVITE DANS:
  129. C LE MAILLAGE IPT2 + LA TABLE DES POINTS XCOOR
  130. NBPTSJ=NBPTSJ+1
  131. J2=J2+1
  132. IPT2.NUM(1,J2)=NBPTSJ
  133. IPT2.ICOLOR(J2)=IPT1.ICOLOR(J)
  134. IREF=(NBPTSJ-1)*IDIMP1
  135. DO 17 I=1,IDIMP1
  136. XCOOR(IREF+I)=XGRAV(I)/IPT1.NUM(/1)
  137. 17 CONTINUE
  138. 13 CONTINUE
  139. IF (LISOUS(/1).NE.0) SEGDES IPT1
  140. 12 CONTINUE
  141.  
  142. C ERREUR SI MAILLAGE VIDE
  143. IF (NBELEM.EQ.0) THEN
  144. MOTERR(1:8)='MAILLAGE'
  145. CALL ERREUR(1027)
  146. RETURN
  147. ENDIF
  148.  
  149. SEGDES,MELEME
  150. SEGDES,IPT2
  151. CALL ECROBJ('MAILLAGE',IPT2)
  152.  
  153.  
  154. RETURN
  155. END
  156.  
  157.  
  158.  
  159.  
  160.  

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