Télécharger krcoa2.eso

Retour à la liste

Numérotation des lignes :

  1. C KRCOA2 SOURCE CB215821 16/04/21 21:17:35 8920
  2. SUBROUTINE KRCOA2 (K1,SP1,SHC2D,SKFAC2,SKBUF2,SKRESO,EXTINC)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. -INC CCREEL
  6. C
  7. C par rapport à KRCOM2 tient compte de l'absoption du milieu
  8. C caracterisé par le coefficient d'extinction EXTINC
  9. C
  10. C 02/2011 correction
  11. C
  12. C RECOMBINAISON
  13. C -------------
  14. C CONTRIBUTION DUE A UN PATCH DONNE
  15.  
  16. C-----------------------------------------------------------------------
  17. SEGMENT SKRESO
  18. INTEGER KFC,NRES,KES,KIMP
  19. ENDSEGMENT
  20. C KFC : NOMBRE DE FACES H.C
  21. C NRES: RESOLUTION
  22. C KES : DIM ESPACE
  23. C KIMP: IMPRESSION
  24. C-----------------------------------------------------------------------
  25. C-----------------------------------------------------------------------
  26. SEGMENT SHC2D
  27. INTEGER IR(NR),KA(NFC),IM(NFC,NFC)
  28. INTEGER KRO(NFC,NES),KSI(NFC,NES)
  29. REAL*8 V(NES,NR),G(NR)
  30. ENDSEGMENT
  31.  
  32. C DESCRIPTION DU H.C DE PROJECTION
  33. C --------------------------------
  34. C V : DIRECTION UNITAIRE DES CELLULES
  35. C G : FACTEUR DE FORME ASSOCIE
  36. C IR: CORRESPONDANCE
  37. C KRO , KSI : POUR LE CHANGEMENT DE REPERE
  38. C IM : REFERENCE
  39. C NR : RESOLUTION
  40. C NFC : NOMBRE DE FACES
  41. C-----------------------------------------------------------------------
  42. SEGMENT SKFAC2
  43. INTEGER NUK(MS,MFACE),KPATCH(MFACE)
  44. INTEGER NCELL(MFACE)
  45. REAL*8 U(3,MFACE),S(MFACE)
  46. REAL*8 FF1(MFACE)
  47. ENDSEGMENT
  48. SEGMENT IPATCH
  49. REAL*8 GP(MSP,NPATCH),SP(NPATCH)
  50. ENDSEGMENT
  51. C
  52. C DESCRIPTION DES ELEMENTS
  53. C ------------------------
  54. C MFACE : NOMBRE DE FACES
  55. C NUK : CONNECTIVITES
  56. C U : NORMALE UNITAIRE ET EQUATION DU PLAN DE L'ELEMENT
  57. C S : SURFACE
  58. C KVU : VISIBILITE A PRIORI
  59. C FF : FACTEURS DE FORME
  60. C FF1 : TRAVAIL
  61. C NCELL : NOMBRE TOTAL DE CELLULES VUES PAR UN POINT
  62. C KPATCH: POINTEUR SUR IPATCH
  63. C NPATCH: NOMBRE DE POINTS SUR L'ELEMENT (REDECOUPAGE)
  64. C GP : COORDONNEES DES POINTS
  65. C SP : ET SURFACES
  66. C-----------------------------------------------------------------------
  67. SEGMENT SKBUF2
  68. INTEGER NUMF(NFC,NOC,NR),NTYP(NFC,NR)
  69. REAL*8 ZB(NFC,NR),PSC(NFC,NR)
  70. ENDSEGMENT
  71. C
  72. C BUFFER ASSOCIE AU H.C
  73. C ---------------------
  74. C NUMF : INDICE DE LE DERNIERE FACE RENCONTREE
  75. C NTYP : TYPES ASSOCIES
  76. C ZB : PROFONDEUR
  77. C PSC : PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE)
  78. C-----------------------------------------------------------------------
  79. MFACE = FF1(/1)
  80. DO 400 K = 1,MFACE
  81. FF1(K) = 0.
  82. 400 CONTINUE
  83.  
  84. NC = 0
  85. DO 500 NF = 1,KFC
  86. DO 501 I = 1,NRES
  87.  
  88. NTY = NTYP(NF,I)
  89. IF ( (NTY.NE.0) .AND. (PSC(NF,I).GT.-1.) ) THEN
  90. NC = NC + 1
  91. PROD = PSC(NF,I)*G(I)
  92. C* PROD = G(I)
  93. DO 100 KT=1,NTY
  94. K = NUMF(NF,KT,I)
  95.  
  96. C! avant FF1(K) = FF1(K) + (PROD/NTY)*EXP(-EXTINC*ZB(NF,I))
  97. C 02/2011 appel à la fonction de Bickley-Naylor a l'ordre 3
  98. XX = EXTINC*ZB(NF,I)
  99. CALL KBICK1( XX, XKI1)
  100. C IF (KIMP.GE.4) write(6,*)'BICKLEY3: X, KI3: ',XX, XKI1
  101. C write(6,*)'BICKLEY3: X, KI3: ',XX, XKI1
  102.  
  103. FF1(K) = FF1(K) + (PROD/NTY)*XKI1
  104.  
  105. 100 CONTINUE
  106.  
  107.  
  108. ENDIF
  109. 501 CONTINUE
  110. 500 CONTINUE
  111. NCELL(K1) = NC
  112.  
  113.  
  114. CALL UTSOMM(FF1,MFACE,FFT)
  115. IF (KIMP.GE.4) THEN
  116. WRITE(6,1000) K1,SP1,NCELL(K1),FFT
  117. 1000 FORMAT(1X,' K1 ',I4,' SP1 ',E12.5,' NCELL ',I6,' FFT ',F10.5)
  118. ENDIF
  119.  
  120. DO 600 K = 1,MFACE
  121. FF1(K) = SP1 * FF1(K)
  122. 600 CONTINUE
  123. C
  124. RETURN
  125. END
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  

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