1 : C KRCOA2 SOURCE NC 11/03/11 21:15:10 6899 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)*DEXP(-EXTINC*ZB(NF,I)) 97 : C 02/2011 appel à la fonction de Bickley-Naylor a l'ordre 3 98 : XX = EXTINC*ZB(NF,I) 98 : CALL KBICK1( XX, XKI1) 99 : C IF (KIMP.GE.4) write(6,*)'BICKLEY3: X, KI3: ',XX, XKI1 100 : C write(6,*)'BICKLEY3: X, KI3: ',XX, XKI1 101 : 102 : FF1(K) = FF1(K) + (PROD/NTY)*XKI1 103 : 104 : 100 CONTINUE 105 : 106 : 107 : ENDIF 108 : 501 CONTINUE 109 : 500 CONTINUE 110 : NCELL(K1) = NC 111 : 112 : 112 : CALL UTSOMM(FF1,MFACE,FFT) 113 : IF (KIMP.GE.4) THEN 114 : WRITE(6,1000) K1,SP1,NCELL(K1),FFT 115 : 1000 FORMAT(1X,' K1 ',I4,' SP1 ',E12.5,' NCELL ',I6,' FFT ',F10.5) 116 : ENDIF 117 : 118 : DO 600 K = 1,MFACE 119 : FF1(K) = SP1 * FF1(K) 120 : 600 CONTINUE 121 : C 122 : RETURN 123 : END 124 : 125 : 126 : 127 :
© Cast3M 2003 - All rights reserved.
Disclaimer