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.  
  61. -INC PPARAM
  62. -INC CCOPTIO
  63. -INC SMELEME
  64. -INC SMLENTI
  65. -INC SMCHPOI
  66. -INC SMLMOTS
  67. -INC SMCOORD
  68. C
  69. POINTEUR MELTFA.MELEME, MELCEN.MELEME, MPOVNO.MPOVAL
  70. & , MPODIA.MPOVAL, MELFAC.MELEME
  71. C
  72. C**** Position of the FACE points into MELFAC
  73. C
  74. CALL KRIPAD(MELFAC,MLENTI)
  75. C SEGINI MLENTI
  76. C
  77. C**** Normals
  78. C
  79. CALL LICHT(MCHPNO,MPOVNO,TYPI,IGEOM)
  80. C SEGACT MPOVNO*MOD
  81. C
  82. C**** Diamin
  83. C
  84. TYPI='CENTRE '
  85. JGN=4
  86. JGM=1
  87. SEGINI MLMOTS
  88. MLMOTS.MOTS(1)='SCAL'
  89. CALL KRCHP1(TYPI,MELCEN,MCHDIA,MLMOTS)
  90. CALL LICHT(MCHDIA,MPODIA,TYPI,IGEOM)
  91. C SEGACT MPODIA*MOD
  92. SEGSUP MLMOTS
  93. C
  94. SEGACT MELTFA
  95. SEGACT MELCEN
  96. NBS=MELTFA.LISOUS(/1)
  97. IF(NBS .EQ. 0) NBS=1
  98. C
  99. ICEN=0
  100. DO ISOUS=1,NBS,1
  101. IF(NBS .NE. 1)THEN
  102. IPT1=MELTFA.LISOUS(ISOUS)
  103. SEGACT IPT1
  104. ELSE
  105. IPT1=MELTFA
  106. ENDIF
  107. C
  108. NBELEM=IPT1.NUM(/2)
  109. NBNN=IPT1.NUM(/1)
  110. C
  111. DO IELEM=1,NBELEM,1
  112. ICEN=ICEN+1
  113. NCEN=MELCEN.NUM(1,ICEN)
  114. USDIA=0.0D0
  115. XCEN(1)=XCOOR((NCEN-1)*(IDIM+1)+1)
  116. XCEN(2)=XCOOR((NCEN-1)*(IDIM+1)+2)
  117. IF(IDIM .EQ. 3) XCEN(3)=XCOOR((NCEN-1)*(IDIM+1)+3)
  118. DO INOEU=1,NBNN,1
  119. NFAC=IPT1.NUM(INOEU,IELEM)
  120. IFAC=MLENTI.LECT(NFAC)
  121. RNORX=MPOVNO.VPOCHA(IFAC,1)
  122. RNORY=MPOVNO.VPOCHA(IFAC,2)
  123. RDISX=XCOOR((NFAC-1)*(IDIM+1)+1)-XCEN(1)
  124. RDISY=XCOOR((NFAC-1)*(IDIM+1)+2)-XCEN(2)
  125. USDIA0=(RNORX*RDISX)+(RNORY*RDISY)
  126. IF(IDIM .EQ. 3)THEN
  127. RNORZ=MPOVNO.VPOCHA(IFAC,3)
  128. RDISZ=XCOOR((NFAC-1)*(IDIM+1)+3)-XCEN(3)
  129. USDIA0=USDIA0+(RNORZ*RDISZ)
  130. ENDIF
  131. USDIA0=1.0D0/ABS(USDIA0)
  132. IF(USDIA0 .GE. USDIA) USDIA=USDIA0
  133. ENDDO
  134. MPODIA.VPOCHA(ICEN,1)=2.0D0/USDIA
  135. ENDDO
  136. IF(NBS .NE. 1) SEGDES IPT1
  137. ENDDO
  138. C
  139. SEGDES MELTFA
  140. SEGDES MELCEN
  141. SEGDES MPODIA
  142. SEGDES MPOVNO
  143. SEGSUP MLENTI
  144. C
  145. RETURN
  146. C
  147. END
  148.  
  149.  
  150.  
  151.  

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