Télécharger kdom12.eso

Retour à la liste

Numérotation des lignes :

  1. C KDOM12 SOURCE CHAT 05/01/13 00:53:43 5004
  2. SUBROUTINE KDOM12(MELTFA,MELCEN,MELFAC,MCHPNO,MCHDIA)
  3. C
  4. C************************************************************************
  5. C
  6. C PROJET : CASTEM 2000
  7. C
  8. C NOM : KDOM12
  9. C
  10. C DESCRIPTION : Subroutine called by KDOM10 and KDOM4A in the
  11. C case of EULER model
  12. C We create the minimum diameter of each elts
  13. C
  14. C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
  15. C
  16. C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/LTMF
  17. C
  18. C************************************************************************
  19. C
  20. C INPUT :
  21. C
  22. C MELTFA : MELEME 'ELTFA'
  23. C
  24. C MELCEN : MELEME 'CENTRE'
  25. C
  26. C MELFAC : MELEME 'FACE'
  27. C
  28. C MCHPNO : CHPOINT 'XXNORMAF'
  29. C
  30. C OUTPUT
  31. C
  32. C MCHDIA : CHPOINT 'XXDIEMIN'
  33. C
  34. C
  35. C************************************************************************
  36. C
  37. C Created the 24/02/04
  38. C
  39. C
  40. C**** Variables de COOPTIO
  41. C
  42. C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
  43. C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ
  44. C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES
  45. C & ,IECHO, IIMPI, IOSPI
  46. C & ,IDIM, IFICLE, IPREFI
  47. CC & ,MCOORD
  48. C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
  49. C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
  50. C & ,NORINC,NORVAL,NORIND,NORVAD
  51. C & ,NUCROU, IPSAUV, IREFOR, ISAFOR
  52. CC
  53. IMPLICIT INTEGER(I-N)
  54. INTEGER JGN, JGM, NBS, ICEN, IELEM, NBELEM, NBNN, INOEU, IGEOM
  55. & , ISOUS, NCEN, NFAC, IFAC, MCHDIA, MCHPNO
  56. REAL*8 USDIA, RNORX, RNORY, RNORZ, RDISX, RDISY, RDISZ, USDIA0
  57. & ,XCEN(3)
  58. CHARACTER*8 TYPI
  59. C
  60. -INC CCOPTIO
  61. -INC SMELEME
  62. -INC SMLENTI
  63. -INC SMCHPOI
  64. -INC SMLMOTS
  65. -INC SMCOORD
  66. C
  67. POINTEUR MELTFA.MELEME, MELCEN.MELEME, MPOVNO.MPOVAL
  68. & , MPODIA.MPOVAL, MELFAC.MELEME
  69. C
  70. C**** Position of the FACE points into MELFAC
  71. C
  72. CALL KRIPAD(MELFAC,MLENTI)
  73. C SEGINI MLENTI
  74. C
  75. C**** Normals
  76. C
  77. CALL LICHT(MCHPNO,MPOVNO,TYPI,IGEOM)
  78. C SEGACT MPOVNO*MOD
  79. C
  80. C**** Diamin
  81. C
  82. TYPI='CENTRE '
  83. JGN=4
  84. JGM=1
  85. SEGINI MLMOTS
  86. MLMOTS.MOTS(1)='SCAL'
  87. CALL KRCHP1(TYPI,MELCEN,MCHDIA,MLMOTS)
  88. CALL LICHT(MCHDIA,MPODIA,TYPI,IGEOM)
  89. C SEGACT MPODIA*MOD
  90. SEGSUP MLMOTS
  91. C
  92. SEGACT MELTFA
  93. SEGACT MELCEN
  94. NBS=MELTFA.LISOUS(/1)
  95. IF(NBS .EQ. 0) NBS=1
  96. C
  97. ICEN=0
  98. DO ISOUS=1,NBS,1
  99. IF(NBS .NE. 1)THEN
  100. IPT1=MELTFA.LISOUS(ISOUS)
  101. SEGACT IPT1
  102. ELSE
  103. IPT1=MELTFA
  104. ENDIF
  105. C
  106. NBELEM=IPT1.NUM(/2)
  107. NBNN=IPT1.NUM(/1)
  108. C
  109. DO IELEM=1,NBELEM,1
  110. ICEN=ICEN+1
  111. NCEN=MELCEN.NUM(1,ICEN)
  112. USDIA=0.0D0
  113. XCEN(1)=XCOOR((NCEN-1)*(IDIM+1)+1)
  114. XCEN(2)=XCOOR((NCEN-1)*(IDIM+1)+2)
  115. IF(IDIM .EQ. 3) XCEN(3)=XCOOR((NCEN-1)*(IDIM+1)+3)
  116. DO INOEU=1,NBNN,1
  117. NFAC=IPT1.NUM(INOEU,IELEM)
  118. IFAC=MLENTI.LECT(NFAC)
  119. RNORX=MPOVNO.VPOCHA(IFAC,1)
  120. RNORY=MPOVNO.VPOCHA(IFAC,2)
  121. RDISX=XCOOR((NFAC-1)*(IDIM+1)+1)-XCEN(1)
  122. RDISY=XCOOR((NFAC-1)*(IDIM+1)+2)-XCEN(2)
  123. USDIA0=(RNORX*RDISX)+(RNORY*RDISY)
  124. IF(IDIM .EQ. 3)THEN
  125. RNORZ=MPOVNO.VPOCHA(IFAC,3)
  126. RDISZ=XCOOR((NFAC-1)*(IDIM+1)+3)-XCEN(3)
  127. USDIA0=USDIA0+(RNORZ*RDISZ)
  128. ENDIF
  129. USDIA0=1.0D0/ABS(USDIA0)
  130. IF(USDIA0 .GE. USDIA) USDIA=USDIA0
  131. ENDDO
  132. MPODIA.VPOCHA(ICEN,1)=2.0D0/USDIA
  133. ENDDO
  134. IF(NBS .NE. 1) SEGDES IPT1
  135. ENDDO
  136. C
  137. SEGDES MELTFA
  138. SEGDES MELCEN
  139. SEGDES MPODIA
  140. SEGDES MPOVNO
  141. SEGSUP MLENTI
  142. C
  143. RETURN
  144. C
  145. END
  146.  
  147.  
  148.  
  149.  

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