Télécharger crectr.eso

Retour à la liste

Numérotation des lignes :

  1. C CRECTR SOURCE CHAT 05/01/12 22:29:02 5004
  2. SUBROUTINE CRECTR
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C
  7. C OBJET : Cree un point au centre de gravite des éléments d'un maillage
  8. C (On ignore si ce point existe déja dans le cas d'éléments quadratiques)
  9. C SYNTAXE : OBJ2 = KCTR OBJ1 <'INCL' TABDOM> ;
  10. C
  11. C OBJ1 : objet 'MAILLAGE'
  12. C OBJ2 : objet 'MAILLAGE' constitué d'éléments POI1
  13. C
  14. C*************************************************************************
  15. -INC SMELEME
  16. POINTEUR MP1.MELEME
  17. POINTEUR MELEMC.MELEME,MELEF1.MELEME
  18. -INC SMTABLE
  19. POINTEUR MTABD.MTABLE
  20. -INC SMCOORD
  21. -INC CCOPTIO
  22. CHARACTER*4 LISMO(1)
  23. PARAMETER (NTB=1)
  24. DIMENSION KTAB(NTB)
  25. CHARACTER*8 LTAB(NTB),TYPE
  26. DATA LISMO /'INCL'/
  27. DATA LTAB /'DOMAINE '/
  28.  
  29. C***
  30.  
  31. CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  32. IF(IRET.EQ.0)RETURN
  33.  
  34. KINC=0
  35. CALL LIRMOT(LISMO,1,IP,0)
  36. IF(IP.NE.0)THEN
  37. KINC=1
  38. NTO=1
  39. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  40. IF(IRET.EQ.0)RETURN
  41. CALL LIRREE(XVAL,1,IRET)
  42. IF(IRET.EQ.0)RETURN
  43. MTABD=KTAB(1)
  44. TYPE=' '
  45. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  46. C call ecrobj('MAILLAGE',MELEMC)
  47. IF(TYPE.NE.'MAILLAGE')RETURN
  48. TYPE=' '
  49. CALL ACMO(MTABD,'FACE',TYPE,MELEF1)
  50. ENDIF
  51.  
  52. CALL KNBEL(MELEME,NELN)
  53.  
  54. NBPTI=XCOOR(/1)/(IDIM+1)
  55. NBPTS=NBPTI+NELN
  56. SEGADJ MCOORD
  57.  
  58. NBSOUS=0
  59. NBREF=0
  60. NBNN=1
  61. NBELEM=NELN
  62. SEGINI MP1
  63. MP1.ITYPEL=1
  64. SEGACT MELEME
  65. NBSOUS=LISOUS(/1)
  66. IF(NBSOUS.EQ.0)NBSOUS=1
  67. K0=0
  68.  
  69. DO 1 L=1,NBSOUS
  70. IF(NBSOUS.NE.1)THEN
  71. IPT1=LISOUS(L)
  72. SEGACT IPT1
  73. ELSE
  74. IPT1=MELEME
  75. ENDIF
  76. NP=IPT1.NUM(/1)
  77. NEL=IPT1.NUM(/2)
  78.  
  79. IF(IDIM.EQ.2)THEN
  80. DO 2 K=1,NEL
  81. NK=K0+K
  82. XC=0.D0
  83. YC=0.D0
  84. DO 21 I=1,NP
  85. IP=IPT1.NUM(I,K)
  86. XC=XC+XCOOR((IP-1)*(IDIM+1)+1)
  87. YC=YC+XCOOR((IP-1)*(IDIM+1)+2)
  88. 21 CONTINUE
  89. XC=XC/DBLE(NP)
  90. YC=YC/DBLE(NP)
  91. XD=XCOOR(IP*(IDIM+1))
  92.  
  93. IP=NBPTI+NK
  94. XCOOR((IP-1)*(IDIM+1)+1)=XC
  95. XCOOR((IP-1)*(IDIM+1)+2)=YC
  96. XCOOR(IP*(IDIM+1))=XD
  97. MP1.NUM(1,NK)=IP
  98.  
  99. 2 CONTINUE
  100.  
  101.  
  102. ELSEIF(IDIM.EQ.3)THEN
  103. DO 3 K=1,NEL
  104. NK=K0+K
  105. XC=0.D0
  106. YC=0.D0
  107. ZC=0.D0
  108. DO 31 I=1,NP
  109. IP=IPT1.NUM(I,K)
  110. XC=XC+XCOOR((IP-1)*(IDIM+1)+1)
  111. YC=YC+XCOOR((IP-1)*(IDIM+1)+2)
  112. ZC=ZC+XCOOR((IP-1)*(IDIM+1)+3)
  113. 31 CONTINUE
  114. XC=XC/DBLE(NP)
  115. YC=YC/DBLE(NP)
  116. ZC=ZC/DBLE(NP)
  117. XD=XCOOR(IP*(IDIM+1))
  118.  
  119. IP=NBPTI+NK
  120. XCOOR((IP-1)*(IDIM+1)+1)=XC
  121. XCOOR((IP-1)*(IDIM+1)+2)=YC
  122. XCOOR((IP-1)*(IDIM+1)+3)=ZC
  123. XCOOR(IP*(IDIM+1))=XD
  124. MP1.NUM(1,NK)=IP
  125.  
  126. 3 CONTINUE
  127. ENDIF
  128. K0=K0+NEL
  129. IF(NBSOUS.NE.1)THEN
  130. SEGDES IPT1
  131. ENDIF
  132. 1 CONTINUE
  133. SEGDES MELEME
  134. IF(KINC.NE.0)THEN
  135. WRITE(6,1951)NELN
  136. 1951 FORMAT(1X,'KCTR : Creation des points centre :',
  137. & ' Nombre de points a eliminer :',I7)
  138. CALL ECMO(MTABD,'BIDON','MAILLAGE',MP1)
  139. CALL ECRREE(XVAL)
  140. CALL ECROBJ('MAILLAGE',MELEMC)
  141. CALL ECROBJ('MAILLAGE',MP1 )
  142. CALL PRELIM(0)
  143. CALL LIROBJ('MAILLAGE',IP,1,IRET)
  144. C write(6,*)' Retour prelim melemc,mp1,ip=',melemc,mp1,ip
  145. IF(MELEF1.NE.0)THEN
  146. WRITE(6,*)' Elimination avec les faces'
  147. CALL ECRREE(XVAL)
  148. CALL ECROBJ('MAILLAGE',MELEF1)
  149. CALL ECROBJ('MAILLAGE',MP1)
  150. CALL PRELIM(0)
  151. CALL LIROBJ('MAILLAGE',IP,1,IRET)
  152. C write(6,*)' Retour prelim melemc,mp1,ip=',melemc,mp1,ip
  153. ENDIF
  154. ELSE
  155. C Car normalement, ELIM a sans doute desactive MP1
  156. SEGDES MP1
  157. ENDIF
  158. CALL ECROBJ('MAILLAGE',MP1)
  159. RETURN
  160.  
  161. END
  162.  
  163.  
  164.  
  165.  

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