Télécharger kdme.eso

Retour à la liste

Numérotation des lignes :

  1. C KDME SOURCE CHAT 05/01/13 00:53:20 5004
  2. SUBROUTINE KDME
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C
  7. C OBJET : Cree un CHAMPOINT CENTRE contenant le diametre max des
  8. C éléments du domaine
  9. C
  10. C SYNTAXE : CHPC = KDME OBJDOM ;
  11. C
  12. C OBJDOM : TABLE de SOUSTYPE DOMAINE
  13. C
  14. C*************************************************************************
  15. -INC CCREEL
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMCOORD
  19. -INC SMCHPOI
  20.  
  21. * PARAMETER (XPETI2=XPETIT**2)
  22. PARAMETER (NTB=1)
  23. CHARACTER*8 LTAB(NTB),TYPE,TYPC
  24. DIMENSION KTAB(NTB)
  25. DATA LTAB/'DOMAINE '/
  26. C***
  27. XPETI2 = XPETIT
  28. NTO=NTB
  29. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  30. IF(IRET.EQ.0)RETURN
  31. MTABD=KTAB(1)
  32.  
  33. TYPE=' '
  34. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  35. IF(TYPE.NE.'MAILLAGE')GO TO 90
  36. NC=1
  37. TYPE='CENTRE'
  38. CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI)
  39. C In LICHT -> SEGACT MPOVAL*MOD
  40. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  41.  
  42. TYPE=' '
  43. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  44. IF(TYPE.NE.'MAILLAGE')GO TO 90
  45. SEGACT MELEME
  46.  
  47. NBSOUS=LISOUS(/1)
  48. IF(NBSOUS.EQ.0)NBSOUS=1
  49.  
  50. NELT=0
  51. DO 1 L=1,NBSOUS
  52. IF(NBSOUS.EQ.1)THEN
  53. IPT1=MELEME
  54. ELSE
  55. IPT1=LISOUS(L)
  56. SEGACT IPT1
  57. ENDIF
  58. NP=IPT1.NUM(/1)
  59. NEL=IPT1.NUM(/2)
  60.  
  61. DO 10 K=1,NEL
  62. NELT=NELT+1
  63.  
  64. C CALCUL DU DIAMETRE MAX
  65.  
  66. XMA2=0.D0
  67. DO 321 I=1,NP-1
  68. IPI=IPT1.NUM(I,K)
  69. DO 322 J=I+1,NP
  70. IPJ=IPT1.NUM(J,K)
  71. XM2=0.D0
  72. DO 323 N=1,IDIM
  73. XM2=XM2+(XCOOR((IPI-1)*(IDIM+1)+N)
  74. $ -XCOOR((IPJ-1)*(IDIM+1)+N))**2
  75. 323 CONTINUE
  76. XMA2=MAX(XMA2,XM2)
  77. 322 CONTINUE
  78. 321 CONTINUE
  79. C
  80. * IF(XMA2.LT.XPETI2) WRITE(6,*)
  81. * $ 'kdme.eso : un element est peut-etre degenere'
  82.  
  83. VPOCHA(NELT,1)=SQRT(XMA2)
  84. 10 CONTINUE
  85. SEGDES IPT1
  86. 1 CONTINUE
  87. IF(NBSOUS.NE.1) SEGDES MELEME
  88. SEGDES MPOVAL
  89. C
  90. CALL ECROBJ('CHPOINT ',MCHPOI)
  91.  
  92. RETURN
  93.  
  94. 90 CONTINUE
  95. * WRITE(6,*)' Interruption anormale dans kdme.eso'
  96. RETURN
  97. 1001 FORMAT(20(1X,I5))
  98. END
  99.  
  100.  
  101.  
  102.  
  103.  

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