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

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