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.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC SMELEME
  20. -INC SMCOORD
  21. -INC SMCHPOI
  22.  
  23. * PARAMETER (XPETI2=XPETIT**2)
  24. PARAMETER (NTB=1)
  25. CHARACTER*8 LTAB(NTB),TYPE,TYPC
  26. DIMENSION KTAB(NTB)
  27. DATA LTAB/'DOMAINE '/
  28. C***
  29. XPETI2 = XPETIT
  30. NTO=NTB
  31. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  32. IF(IRET.EQ.0)RETURN
  33. MTABD=KTAB(1)
  34.  
  35. TYPE=' '
  36. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  37. IF(TYPE.NE.'MAILLAGE')GO TO 90
  38. NC=1
  39. TYPE='CENTRE'
  40. CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI)
  41. C In LICHT -> SEGACT MPOVAL*MOD
  42. CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM)
  43.  
  44. TYPE=' '
  45. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  46. IF(TYPE.NE.'MAILLAGE')GO TO 90
  47. SEGACT MELEME
  48.  
  49. NBSOUS=LISOUS(/1)
  50. IF(NBSOUS.EQ.0)NBSOUS=1
  51.  
  52. NELT=0
  53. DO 1 L=1,NBSOUS
  54. IF(NBSOUS.EQ.1)THEN
  55. IPT1=MELEME
  56. ELSE
  57. IPT1=LISOUS(L)
  58. SEGACT IPT1
  59. ENDIF
  60. NP=IPT1.NUM(/1)
  61. NEL=IPT1.NUM(/2)
  62.  
  63. DO 10 K=1,NEL
  64. NELT=NELT+1
  65.  
  66. C CALCUL DU DIAMETRE MAX
  67.  
  68. XMA2=0.D0
  69. DO 321 I=1,NP-1
  70. IPI=IPT1.NUM(I,K)
  71. DO 322 J=I+1,NP
  72. IPJ=IPT1.NUM(J,K)
  73. XM2=0.D0
  74. DO 323 N=1,IDIM
  75. XM2=XM2+(XCOOR((IPI-1)*(IDIM+1)+N)
  76. $ -XCOOR((IPJ-1)*(IDIM+1)+N))**2
  77. 323 CONTINUE
  78. XMA2=MAX(XMA2,XM2)
  79. 322 CONTINUE
  80. 321 CONTINUE
  81. C
  82. * IF(XMA2.LT.XPETI2) WRITE(6,*)
  83. * $ 'kdme.eso : un element est peut-etre degenere'
  84.  
  85. VPOCHA(NELT,1)=SQRT(XMA2)
  86. 10 CONTINUE
  87. SEGDES IPT1
  88. 1 CONTINUE
  89. IF(NBSOUS.NE.1) SEGDES MELEME
  90. SEGDES MPOVAL
  91. C
  92. CALL ECROBJ('CHPOINT ',MCHPOI)
  93.  
  94. RETURN
  95.  
  96. 90 CONTINUE
  97. * WRITE(6,*)' Interruption anormale dans kdme.eso'
  98. RETURN
  99. 1001 FORMAT(20(1X,I5))
  100. END
  101.  
  102.  
  103.  
  104.  
  105.  

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