1 | include(dom.inc)
2 |
3 | SUBROUTINE TFSCK_CASE(celldata, nelmts, all_WVNB, &
4 | & all_DWVNB, ngbands, &
5 | & nallbandes, nkabs, data_ref, WSGG_W, &
6 | & ieltd, ieltf, WSGG_Wb, Tf, nbfaces)
7 |
8 | USE mod_inout
9 | USE mod_pmm
10 | #ifdef USEPALM
11 | USE palmlib
12 | #endif
13 |
14 | IMPLICIT NONE
15 |
16 | include 'dom_constants.h'
17 |
18 | ! IN
19 | DOM_INT :: nallbandes
20 | DOM_INT :: nbfaces, ibnd
21 | DOM_INT :: nkabs, ieltd, ieltf
22 | DOM_INT :: nelmts, ngbands
23 | DOM_REAL,DIMENSION(nallbandes) :: all_WVNB,all_DWVNB
24 | DOM_REAL,DIMENSION(8,nelmts) :: celldata
25 | DOM_REAL,DIMENSION(8) :: data_ref
26 | DOM_REAL, DIMENSION(nbfaces) :: Tf
27 |
28 | ! OUT
29 | DOM_REAL,DIMENSION(nkabs,nelmts) :: WSGG_W
30 | DOM_REAL,DIMENSION(nkabs,nbfaces):: WSGG_Wb
31 |
32 | ! LOCAL
33 | DOM_REAL,DIMENSION(nkabs,nelmts) :: local_WSGG_W
34 | DOM_REAL,DIMENSION(ngbands,2) :: gasdata
35 | DOM_REAL,DIMENSION(ngbands) :: F
36 | DOM_REAL :: blae, planck
37 | DOM_REAL :: WVNB,DWVNB,WVNB_SI,DWVNB_SI
38 | DOM_INT :: ielt, i, ierr, j
39 | DOM_INT :: i_bande, n_cl
40 | DOM_INT :: ICO,ICO2,IH2O
41 | LOGICAL :: LICO,LICO2,LIH2O
42 |
43 | DOM_REAL,DIMENSION(ngbands,2) :: gasdata_ref
44 | DOM_REAL,DIMENSION(nkabs) :: k_ref, fdek, fdek_ref, w
45 | DOM_REAL :: fdek_i, Tp
46 |
47 | ! --------------------------------------------!
48 | ! STEP 1 : Calculation of the reference state !
49 | ! k_ref and fdek_ref !
50 | ! --------------------------------------------!
51 |
52 | F = 0.
53 | gasdata_ref = 0.
54 | fdek_ref = 0.
55 |
56 | Tp = s_Tp
57 |
58 | DO i_bande=1,ngbands
59 | WVNB = all_WVNB(i_bande)
60 | DWVNB = all_DWVNB(i_bande)
61 | WVNB_SI = 100.*WVNB
62 | DWVNB_SI= 100.*DWVNB
63 |
64 | IF (WVNB.le.9300.0) THEN
65 | CALL FINDI(LICO,LICO2,LIH2O,ICO,ICO2,IH2O,WVNB,DWVNB)
66 |
67 | CALL KBARANDPHI(data_ref(:),LICO,LICO2,LIH2O,ICO, &
68 | & ICO2,IH2O, &
69 | & gasdata_ref(i_bande,1:2), nallbandes)
70 | ENDIF
71 |
72 | IF (s_Tp.eq.0) Tp = data_ref(1)
73 | F(i_bande) = blae(WVNB_SI, Tp)*DWVNB_SI
74 |
75 | ENDDO
76 |
77 | F = F / SUM (F)
78 |
79 | CALL k_distributeur(F, ngbands, gasdata_ref, nkabs, k_ref,w)
80 |
81 | DO j = 1, nkabs
82 | DO i_bande=1,ngbands
83 |
84 | CALL pdf(gasdata_ref(i_bande,2), gasdata_ref(i_bande,1), &
85 | & k_ref(j),fdek_i)
86 |
87 | fdek_ref(j) = fdek_ref(j) + F(i_bande)*fdek_i
88 |
89 | ENDDO
90 | ENDDO
91 |
92 | IF (pmm_rank.eq.0) THEN
93 | PRINT*, " DATA_REF : T = ",data_ref(1)
94 | PRINT*, " P = ",data_ref(2)
95 | PRINT*, " XH2O = ",data_ref(3)
96 | PRINT*, " XCO2 = ", data_ref(4)
97 | PRINT*, " XCO = ", data_ref(5)
98 | PRINT*
99 | ! PRINT*, "K_ref :", k_ref
100 | ! PRINT*, "fdek_ref :", fdek_ref
101 | ENDIF
102 |
103 | ! ----------------------------------------------------------!
104 | ! Calculation of the absorption coefficient over the domain !
105 | ! ----------------------------------------------------------!
106 |
107 | local_WSGG_W = 0.
108 | WSGG_W = 0.
109 |
110 | ! ---------------------------------------------!
111 | ! Non-homogeneous system or homogeneous system !
112 | ! ---------------------------------------------!
113 | IF (homosyst.eq.'NO') THEN
114 | n_cl=ieltf
115 | ELSEIF (homosyst.eq.'YES') THEN
116 | n_cl=ieltd
117 | ENDIF
118 |
119 | DO ielt=ieltd,n_cl
120 |
121 | gasdata = 0.
122 | F = 0.
123 |
124 | ! ------------------------------------!
125 | ! Setting spectral data for each band !
126 | ! ------------------------------------!
127 |
128 | DO i_bande=1,ngbands
129 |
130 | WVNB = all_WVNB(i_bande)
131 | DWVNB = all_DWVNB(i_bande)
132 | WVNB_SI = 100.*WVNB
133 | DWVNB_SI= 100.*DWVNB
134 |
135 | ! ----------------------------------------!
136 | ! Spectral index lecture for each species !
137 | ! ----------------------------------------!
138 | IF (WVNB.le.9300.0) THEN
139 |
140 | CALL FINDI(LICO,LICO2,LIH2O,ICO,ICO2,IH2O,WVNB,DWVNB)
141 |
142 | CALL KBARANDPHI(celldata(:,ielt),LICO,LICO2,LIH2O,ICO, &
143 | & ICO2,IH2O, &
144 | & gasdata(i_bande,1:2), nallbandes)
145 |
146 | ENDIF
147 |
148 | ! -------------------------------------!
149 | ! Band groupment multiplicative factor !
150 | ! -------------------------------------!
151 |
152 | IF (s_Tp.eq.0) Tp = celldata(1,ielt)
153 | F(i_bande) = blae(WVNB_SI,Tp)*DWVNB_SI
154 |
155 | ENDDO
156 |
157 | F = F / SUM(F)
158 |
159 | ! --------------------------------------!
160 | ! STEP 2 : Calculate f(T,phi_ref,k_ref) !
161 | ! --------------------------------------!
162 |
163 | fdek = 0.
164 |
165 | DO j = 1, nkabs
166 | DO i_bande=1,ngbands
167 |
168 | CALL pdf(gasdata_ref(i_bande,2), gasdata_ref(i_bande:,1), &
169 | & k_ref(j), fdek_i)
170 |
171 | fdek(j) = fdek(j) + F(i_bande)*fdek_i
172 |
173 | ENDDO
174 | ENDDO
175 |
176 | ! ----------------------------------------------------------------!
177 | ! STEP 4 : Calculation of the weight function !
178 | ! a(T,T_ref,g_ref)= fdek(T,phi_ref)/fdek_(T_ref,phi_ref) !
179 | ! ----------------------------------------------------------------!
180 |
181 | DO i = 1, nkabs
182 | IF(fdek_ref(i).ne.0) THEN
183 | local_WSGG_W(i,ielt) = fdek(i)/fdek_ref(i)
184 | ELSE
185 | local_WSGG_W(i,ielt) = 1.
186 | ENDIF
187 | ENDDO
188 |
189 | IF ((MOD(ielt,100).eq.0).and.(pmm_rank.eq.0)) THEN
190 | ! print*, ">> Node:",ielt-ieltd,"/",n_cl-ieltd
191 | ENDIF
192 |
193 | ENDDO
194 |
195 | IF (homosyst.eq.'YES') THEN
196 | DO i=ieltd+1,ieltf
197 | local_WSGG_W(:,ielt) = local_WSGG_W(:,ieltd)
198 | ENDDO
199 | ENDIF
200 |
201 | ! ------------------------------------------------------------------!
202 | ! STEP 5 : Calculation of the weight function at walls !
203 | ! a(Tw,T_ref,g_ref)= fdek(Tw,phi_ref)/fdek_(T_ref,phi_ref) !
204 | ! ------------------------------------------------------------------!
205 |
206 | WSGG_Wb = 0.
207 |
208 | DO ibnd=1,nbfaces
209 |
210 | fdek = 0.
211 |
212 | DO i_bande=1,ngbands
213 | DWVNB = all_DWVNB(i_bande)
214 | DWVNB_SI= 100.*DWVNB
215 |
216 | IF(s_TP.eq.0) Tp = Tf(ibnd)
217 | F(i_bande) = blae(WVNB_SI,Tp)*DWVNB_SI
218 |
219 | ENDDO
220 |
221 | F = F / SUM (F)
222 |
223 | DO j = 1, nkabs
224 | DO i_bande=1,ngbands
225 |
226 | CALL pdf(gasdata_ref(i_bande,2), gasdata_ref(i_bande:,1), &
227 | & k_ref(j),fdek_i)
228 |
229 | fdek(j) = fdek(j) + F(i_bande)*fdek_i
230 |
231 | ENDDO
232 |
233 | IF(fdek_ref(j).ne.0) THEN
234 | WSGG_Wb(j,ibnd) = fdek(j)/fdek_ref(j)
235 | ELSE
236 | WSGG_Wb(j,ibnd) = 1.
237 | ENDIF
238 |
239 | ENDDO
240 | ENDDO
241 |
242 | ! ------------------------------------------------!
243 | ! sending all_k_abs....change to a pmm subroutine !
244 | ! ------------------------------------------------!
245 |
246 | CALL MPI_ALLREDUCE(local_WSGG_W, WSGG_W, nkabs*nelmts, &
247 | & MPI_DOUBLE_PRECISION, MPI_SUM, COMM_PARA , &
248 | & ierr)
249 |
250 | END SUBROUTINE TFSCK_CASE
tfsck_case.F could be called by: