Sources Esope | Cast3M

krcoa2
C KRCOA2    SOURCE    CB215821  16/04/21    21:17:35     8920
      SUBROUTINE KRCOA2 (K1,SP1,SHC2D,SKFAC2,SKBUF2,SKRESO,EXTINC)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCREEL
C
C     par rapport à KRCOM2 tient compte de l'absoption du milieu
C     caracterisé par le coefficient d'extinction EXTINC
C
C     02/2011 correction
C
C     RECOMBINAISON
C     -------------
C     CONTRIBUTION DUE A UN PATCH DONNE
 
C-----------------------------------------------------------------------
      SEGMENT SKRESO
      INTEGER KFC,NRES,KES,KIMP
      ENDSEGMENT
C     KFC : NOMBRE DE FACES H.C
C     NRES: RESOLUTION
C     KES : DIM ESPACE
C     KIMP: IMPRESSION
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      SEGMENT SHC2D
      INTEGER IR(NR),KA(NFC),IM(NFC,NFC)
      INTEGER KRO(NFC,NES),KSI(NFC,NES)
      REAL*8  V(NES,NR),G(NR)
      ENDSEGMENT
 
C     DESCRIPTION DU H.C DE PROJECTION
C     --------------------------------
C     V : DIRECTION UNITAIRE DES CELLULES
C     G : FACTEUR DE FORME ASSOCIE
C     IR: CORRESPONDANCE
C     KRO , KSI : POUR LE CHANGEMENT DE REPERE
C     IM  : REFERENCE
C     NR  : RESOLUTION
C     NFC : NOMBRE DE FACES
C-----------------------------------------------------------------------
      SEGMENT SKFAC2
      INTEGER  NUK(MS,MFACE),KPATCH(MFACE)
      INTEGER  NCELL(MFACE)
      REAL*8   U(3,MFACE),S(MFACE)
      REAL*8  FF1(MFACE)
      ENDSEGMENT
      SEGMENT IPATCH
      REAL*8   GP(MSP,NPATCH),SP(NPATCH)
      ENDSEGMENT
C
C     DESCRIPTION DES ELEMENTS
C     ------------------------
C     MFACE : NOMBRE DE FACES
C     NUK   : CONNECTIVITES
C     U     : NORMALE UNITAIRE ET EQUATION DU PLAN DE L'ELEMENT
C     S     : SURFACE
C     KVU   : VISIBILITE A PRIORI
C     FF    : FACTEURS DE FORME
C     FF1   : TRAVAIL
C     NCELL : NOMBRE TOTAL DE CELLULES VUES PAR UN POINT
C     KPATCH: POINTEUR SUR IPATCH
C     NPATCH: NOMBRE DE POINTS SUR L'ELEMENT (REDECOUPAGE)
C     GP    : COORDONNEES DES POINTS
C     SP    : ET SURFACES
C-----------------------------------------------------------------------
      SEGMENT SKBUF2
      INTEGER  NUMF(NFC,NOC,NR),NTYP(NFC,NR)
      REAL*8   ZB(NFC,NR),PSC(NFC,NR)
      ENDSEGMENT
C
C     BUFFER ASSOCIE AU H.C
C     ---------------------
C     NUMF : INDICE DE LE DERNIERE FACE RENCONTREE
C     NTYP :  TYPES ASSOCIES
C     ZB  : PROFONDEUR
C     PSC  :  PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE)
C-----------------------------------------------------------------------
      MFACE = FF1(/1)
      DO 400 K = 1,MFACE
      FF1(K) = 0.
 400  CONTINUE
 
      NC = 0
      DO 500 NF = 1,KFC
      DO 501 I = 1,NRES
 
         NTY = NTYP(NF,I)
         IF ( (NTY.NE.0) .AND. (PSC(NF,I).GT.-1.) ) THEN
           NC = NC + 1
           PROD  =  PSC(NF,I)*G(I)
C*         PROD  =            G(I)
             DO 100 KT=1,NTY
              K = NUMF(NF,KT,I)
 
C! avant      FF1(K) = FF1(K) + (PROD/NTY)*EXP(-EXTINC*ZB(NF,I))
C  02/2011 appel à la fonction de Bickley-Naylor a l'ordre 3
              XX = EXTINC*ZB(NF,I)
              CALL  KBICK1( XX, XKI1)
C             IF (KIMP.GE.4) write(6,*)'BICKLEY3: X, KI3: ',XX, XKI1
C                            write(6,*)'BICKLEY3: X, KI3: ',XX, XKI1
 
              FF1(K) = FF1(K) + (PROD/NTY)*XKI1
 
 100         CONTINUE
 
 
         ENDIF
 501  CONTINUE
 500  CONTINUE
      NCELL(K1) = NC
 
 
      CALL UTSOMM(FF1,MFACE,FFT)
      IF (KIMP.GE.4) THEN
      WRITE(6,1000) K1,SP1,NCELL(K1),FFT
 1000 FORMAT(1X,' K1 ',I4,' SP1 ',E12.5,' NCELL ',I6,' FFT ',F10.5)
      ENDIF
 
      DO 600 K = 1,MFACE
      FF1(K) = SP1 * FF1(K)
 600  CONTINUE
C
      RETURN
      END