Line data Source code
1 : !-----------------------------------------------------------------------
2 : ! $Id$
3 : !===============================================================================
4 : module diagnose_correlations_module
5 :
6 : use clubb_precision, only: &
7 : core_rknd
8 :
9 : implicit none
10 :
11 : public :: calc_mean, calc_varnce, calc_w_corr, &
12 : calc_cholesky_corr_mtx_approx, &
13 : cholesky_to_corr_mtx_approx, setup_corr_cholesky_mtx, &
14 : diagnose_correlations
15 :
16 :
17 : private :: diagnose_corr, rearrange_corr_array, &
18 : corr_array_assertion_checks
19 :
20 : private ! Default scope
21 : contains
22 :
23 : !-----------------------------------------------------------------------
24 0 : subroutine diagnose_correlations( pdf_dim, corr_array_pre, & ! Intent(in)
25 : l_calc_w_corr, & ! Intent(in)
26 0 : corr_array ) ! Intent(out)
27 : ! Description:
28 : ! This subroutine diagnoses the correlation matrix in order to feed it
29 : ! into SILHS microphysics.
30 :
31 : ! References:
32 : ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02
33 : ! (see CLUBB Trac ticket#514)
34 : !-----------------------------------------------------------------------
35 :
36 : use clubb_precision, only: &
37 : core_rknd ! Variable(s)
38 :
39 : ! use array_index, only: &
40 : ! iiPDF_w ! Variable(s)
41 :
42 : use constants_clubb, only: &
43 : zero
44 :
45 : implicit none
46 :
47 : intrinsic :: max, sqrt, transpose
48 :
49 : ! Input Variables
50 : integer, intent(in) :: &
51 : pdf_dim ! number of diagnosed correlations
52 :
53 : real( kind = core_rknd ), dimension(pdf_dim, pdf_dim), intent(in) :: &
54 : corr_array_pre ! Prescribed correlations
55 :
56 : logical, intent(in) :: &
57 : l_calc_w_corr ! Calculate the correlations between w and the hydrometeors
58 :
59 : ! Output variables
60 : real( kind = core_rknd ), dimension(pdf_dim, pdf_dim), intent(out) :: &
61 : corr_array
62 :
63 : ! Local Variables
64 : real( kind = core_rknd ), dimension(pdf_dim, pdf_dim) :: &
65 0 : corr_array_pre_swapped, &
66 0 : corr_array_swapped
67 :
68 : ! We actually don't need this right now
69 : real( kind = core_rknd ), dimension(pdf_dim) :: &
70 0 : sigma2_on_mu2_ip_array ! Ratios: sigma_x^2/mu_x^2 (ith PDF comp.) ip [-]
71 :
72 : integer :: i ! Loop iterator
73 :
74 : !-------------------- Begin code --------------------
75 :
76 : ! Initialize sigma2_on_mu2_ip_array
77 0 : do i = 1, pdf_dim
78 0 : sigma2_on_mu2_ip_array(i) = zero
79 : end do
80 :
81 : ! Swap the w-correlations to the first row for the prescribed correlations
82 : call rearrange_corr_array( pdf_dim, corr_array_pre, & ! Intent(in)
83 0 : corr_array_pre_swapped) ! Intent(inout)
84 :
85 : ! diagnose correlations
86 :
87 0 : if ( .not. l_calc_w_corr ) then
88 0 : corr_array_swapped = corr_array_pre_swapped
89 : endif
90 :
91 : call diagnose_corr( pdf_dim, sqrt(sigma2_on_mu2_ip_array), & ! intent(in)
92 : corr_array_pre_swapped, & ! intent(in)
93 0 : corr_array_swapped ) ! intent(inout)
94 :
95 : ! Swap rows back
96 : call rearrange_corr_array( pdf_dim, corr_array_swapped, & ! Intent(in)
97 0 : corr_array) ! Intent(out)
98 :
99 0 : end subroutine diagnose_correlations
100 :
101 :
102 : !-----------------------------------------------------------------------
103 0 : subroutine diagnose_corr( n_variables, sqrt_sigma2_on_mu2_ip, & ! intent(in)
104 0 : corr_matrix_prescribed, & !intent(in)
105 0 : corr_matrix_approx ) ! intent(inout)
106 :
107 : ! Description:
108 : ! This subroutine diagnoses the correlation matrix for each timestep.
109 :
110 : ! References:
111 : ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02
112 : ! (see CLUBB Trac ticket#514)
113 : !-----------------------------------------------------------------------
114 :
115 : use clubb_precision, only: &
116 : core_rknd ! Variable(s)
117 :
118 : use constants_clubb, only: &
119 : max_mag_correlation
120 :
121 : implicit none
122 :
123 : intrinsic :: &
124 : sqrt, abs, sign
125 :
126 : ! Input Variables
127 : integer, intent(in) :: &
128 : n_variables ! number of variables in the correlation matrix [-]
129 :
130 : real( kind = core_rknd ), dimension(n_variables), intent(in) :: &
131 : sqrt_sigma2_on_mu2_ip ! sqrt of sigma_x^2/mu_x^2 (ith PDF comp.) ip [-]
132 :
133 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: &
134 : corr_matrix_prescribed ! correlation matrix [-]
135 :
136 : ! Input/Output Variables
137 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(inout) :: &
138 : corr_matrix_approx ! correlation matrix [-]
139 :
140 :
141 : ! Local Variables
142 : integer :: i, j ! Loop iterator
143 :
144 : real( kind = core_rknd ) :: &
145 : f_ij
146 : ! f_ij_o
147 :
148 : real( kind = core_rknd ), dimension(n_variables) :: &
149 0 : s_1j ! s_1j = sqrt(1-c_1j^2)
150 :
151 :
152 : !-------------------- Begin code --------------------
153 :
154 : ! Remove compiler warnings about unused variables.
155 : if ( .false. ) then
156 : print *, "sqrt_sigma2_on_mu2_ip = ", sqrt_sigma2_on_mu2_ip
157 : endif
158 :
159 : ! calculate all square roots
160 0 : do i = 1, n_variables
161 :
162 0 : s_1j(i) = sqrt(1._core_rknd-corr_matrix_approx(i,1)**2)
163 :
164 : end do
165 :
166 :
167 : ! Diagnose the missing correlations (upper triangle)
168 0 : do j = 2, (n_variables-1)
169 0 : do i = (j+1), n_variables
170 :
171 : ! formula (16) in the ref. paper (Larson et al. (2011))
172 : !f_ij = alpha_corr * sqrt_sigma2_on_mu2_ip(i) * sqrt_sigma2_on_mu2_ip(j) &
173 : ! * sign(1.0_core_rknd,corr_matrix_approx(1,i)*corr_matrix_approx(1,j))
174 :
175 : ! If the predicting c1i's are small then cij will be closer to the prescribed value. If
176 : ! the c1i's are bigger, then cij will be closer to formular (15) from the ref. paper. See
177 : ! clubb:ticket:514:comment:61 for details.
178 : !f_ij = (1-abs(corr_matrix_approx(1,i)*corr_matrix_approx(1,j)))*corr_matrix_prescribed(i,j) &
179 : ! + abs(corr_matrix_approx(1,i)*corr_matrix_approx(1,j))*f_ij_o
180 :
181 0 : f_ij = corr_matrix_prescribed(i,j)
182 :
183 : ! make sure -1 < f_ij < 1
184 0 : if ( f_ij < -max_mag_correlation ) then
185 :
186 : f_ij = -max_mag_correlation
187 :
188 0 : else if ( f_ij > max_mag_correlation ) then
189 :
190 0 : f_ij = max_mag_correlation
191 :
192 : end if
193 :
194 :
195 : ! formula (15) in the ref. paper (Larson et al. (2011))
196 0 : corr_matrix_approx(i,j) = corr_matrix_approx(i,1) * corr_matrix_approx(j,1) &
197 0 : + f_ij * s_1j(i) * s_1j(j)
198 :
199 : end do ! do j
200 : end do ! do i
201 :
202 0 : end subroutine diagnose_corr
203 :
204 :
205 : !-----------------------------------------------------------------------
206 : ! subroutine approx_w_corr( nz, pdf_dim, pdf_params, & ! Intent(in)
207 : ! rrm, Nrm, Ncnm, &
208 : ! stdev_w, sigma_rr_1, &
209 : ! sigma_Nr_1, sigma_Ncn_1, &
210 : ! corr_array) ! Intent(out)
211 : ! ! Description:
212 : ! ! Approximate the correlations of w with the hydrometeors.
213 : !
214 : ! ! References:
215 : ! ! clubb:ticket:514
216 : ! !-----------------------------------------------------------------------
217 : !
218 : ! use clubb_precision, only: &
219 : ! core_rknd ! Variable(s)
220 : !
221 : ! use pdf_parameter_module, only: &
222 : ! pdf_parameter ! Type
223 : !
224 : ! use constants_clubb, only: &
225 : ! one, & ! Constant(s)
226 : ! rr_tol, &
227 : ! Nr_tol, &
228 : ! Ncn_tol, &
229 : ! w_tol, & ! [m/s]
230 : ! chi_tol ! [kg/kg]
231 : !
232 : ! implicit none
233 : !
234 : ! ! Input Variables
235 : ! integer, intent(in) :: &
236 : ! pdf_dim, & ! Number of diagnosed correlations
237 : ! nz ! Number of model vertical grid levels
238 : !
239 : ! type(pdf_parameter), dimension(nz), intent(in) :: &
240 : ! pdf_params ! PDF parameters [units vary]
241 : !
242 : ! real( kind = core_rknd ), dimension(nz), intent(in) :: &
243 : ! rrm, & ! Mean rain water mixing ratio, < r_r > [kg/kg]
244 : ! Nrm, & ! Mean rain drop concentration, < N_r > [num/kg]
245 : ! Ncnm, & ! Mean cloud nuclei conc., < N_cn > [num/kg]
246 : ! stdev_w ! Standard deviation of w [m/s]
247 : !
248 : ! real( kind = core_rknd ), intent(in) :: &
249 : ! sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF component) [num/kg]
250 : ! sigma_Nr_1, & ! Standard deviation of Nr (2nd PDF component) [num/kg]
251 : ! sigma_rr_1 ! Standard dev. of ln rr (1st PDF comp.) ip [ln(kg/kg)]
252 : !
253 : ! ! Output Variables
254 : ! real( kind = core_rknd ), dimension(pdf_dim, pdf_dim, nz), intent(out) :: &
255 : ! corr_array
256 : !
257 : ! ! Local Variables
258 : ! real( kind = core_rknd ), dimension(nz) :: &
259 : ! corr_chi_w, & ! Correlation between w and chi(s_mellor) (both components) [-]
260 : ! corr_wrr, & ! Correlation between w and rr (both components) [-]
261 : ! corr_wNr, & ! Correlation between w and Nr (both components) [-]
262 : ! corr_wNcn ! Correlation between w and Ncn (both components) [-]
263 : !
264 : ! real( kind = core_rknd ), dimension(nz) :: &
265 : ! wpchip_zt, & ! Covariance of chi and w on the zt-grid [(m/s)(kg/kg)]
266 : ! wprrp_zt, & ! Covariance of r_r and w on the zt-grid [(m/s)(kg/kg)]
267 : ! wpNrp_zt, & ! Covariance of N_r and w on the zt-grid [(m/s)(#/kg)]
268 : ! wpNcnp_zt ! Covariance of N_cn and w on the zt-grid [(m/s)(#/kg)]
269 : !
270 : ! real( kind = core_rknd ) :: &
271 : ! chi_m, & ! Mean of chi (s_mellor) [kg/kg]
272 : ! stdev_chi ! Standard deviation of chi (s_mellor) [kg/kg]
273 : !
274 : ! integer :: k ! vertical loop iterator
275 : !
276 : ! ! ----- Begin Code -----
277 : !
278 : ! call approx_w_covar( nz, pdf_params, rrm, Nrm, Ncnm, & ! Intent(in)
279 : ! wpchip_zt, wprrp_zt, wpNrp_zt, wpNcnp_zt ) ! Intent(out)
280 : !
281 : ! do k = 1, nz
282 : !
283 : ! chi_m &
284 : ! = calc_mean( pdf_params(k)%mixt_frac, pdf_params(k)%chi_1, &
285 : ! pdf_params(k)%chi_2 )
286 : !
287 : ! stdev_chi &
288 : ! = sqrt( pdf_params(k)%mixt_frac &
289 : ! * ( ( pdf_params(k)%chi_1 - chi_m )**2 &
290 : ! + pdf_params(k)%stdev_chi_1**2 ) &
291 : ! + ( one - pdf_params(k)%mixt_frac ) &
292 : ! * ( ( pdf_params(k)%chi_2 - chi_m )**2 &
293 : ! + pdf_params(k)%stdev_chi_2**2 ) &
294 : ! )
295 : !
296 : ! corr_chi_w(k) &
297 : ! = calc_w_corr( wpchip_zt(k), stdev_w(k), stdev_chi, &
298 : ! w_tol, chi_tol )
299 : !
300 : ! corr_wrr(k) &
301 : ! = calc_w_corr( wprrp_zt(k), stdev_w(k), sigma_rr_1, w_tol, rr_tol )
302 : !
303 : ! corr_wNr(k) &
304 : ! = calc_w_corr( wpNrp_zt(k), stdev_w(k), sigma_Nr_1, w_tol, Nr_tol )
305 : !
306 : ! corr_wNcn(k) &
307 : ! = calc_w_corr( wpNcnp_zt(k), stdev_w(k), sigma_Ncn_1, w_tol, Ncn_tol )
308 : !
309 : ! enddo
310 : !
311 : ! call set_w_corr( nz, pdf_dim, & ! Intent(in)
312 : ! corr_chi_w, corr_wrr, corr_wNr, corr_wNcn, &
313 : ! corr_array ) ! Intent(inout)
314 : !
315 : ! end subroutine approx_w_corr
316 :
317 :
318 : !-----------------------------------------------------------------------
319 : ! subroutine approx_w_covar( nz, pdf_params, rrm, Nrm, Ncnm, Kh_zm, & ! Intent(in)
320 : ! wpchip_zt, wprrp_zt, wpNrp_zt, wpNcnp_zt ) ! Intent(out)
321 : ! ! Description:
322 : ! ! Approximate the covariances of w with the hydrometeors using Eddy
323 : ! ! diffusivity.
324 : !
325 : ! ! References:
326 : ! ! clubb:ticket:514
327 : ! !-----------------------------------------------------------------------
328 : !
329 : ! use clubb_precision, only: &
330 : ! core_rknd ! Variable(s)
331 : !
332 : ! use grid_class, only: &
333 : ! gr, & ! Variable(s)
334 : ! zm2zt, & ! Procedure(s)
335 : ! zt2zm
336 : !
337 : ! use pdf_parameter_module, only: &
338 : ! pdf_parameter ! Type
339 : !
340 : ! use constants_clubb, only: &
341 : ! one ! Constant(s)
342 : !
343 : ! use advance_windm_edsclrm_module, only: &
344 : ! xpwp_fnc ! Procedure(s)
345 : !
346 : ! implicit none
347 : !
348 : ! ! Input Variables
349 : ! integer, intent(in) :: &
350 : ! nz ! Number of model vertical grid levels
351 : !
352 : ! type(pdf_parameter), dimension(nz), intent(in) :: &
353 : ! pdf_params ! PDF parameters [units vary]
354 : !
355 : ! real( kind = core_rknd ), dimension(nz), intent(in) :: &
356 : ! rrm, & ! Mean rain water mixing ratio, < r_r > [kg/kg]
357 : ! Nrm, & ! Mean rain drop concentration, < N_r > [num/kg]
358 : ! Ncnm, & ! Mean cloud nuclei concentration, < N_cn > [num/kg]
359 : ! Kh_zm ! Eddy diffusivity coef. on momentum levels [m^2/s]
360 : !
361 : ! ! Output Variables
362 : ! real( kind = core_rknd ), dimension(nz), intent(out) :: &
363 : ! wpchip_zt, & ! Covariance of chi(s) and w on the zt-grid [(m/s)(kg/kg)]
364 : ! wprrp_zt, & ! Covariance of r_r and w on the zt-grid [(m/s)(kg/kg)]
365 : ! wpNrp_zt, & ! Covariance of N_r and w on the zt-grid [(m/s)(#/kg)]
366 : ! wpNcnp_zt ! Covariance of N_cn and w on the zt-grid [(m/s)(#/kg)]
367 : !
368 : ! ! Local Variables
369 : ! real( kind = core_rknd ), dimension(nz) :: &
370 : ! wpchip_zm, & ! Covariance of chi(s) and w on the zm-grid [(m/s)(kg/kg)]
371 : ! wprrp_zm, & ! Covariance of r_r and w on the zm-grid [(m/s)(kg/kg)]
372 : ! wpNrp_zm, & ! Covariance of N_r and w on the zm-grid [(m/s)(#/kg)]
373 : ! wpNcnp_zm ! Covariance of N_cn and w on the zm-grid [(m/s)(#/kg)]
374 : !
375 : ! integer :: k ! vertical loop iterator
376 : !
377 : ! ! ----- Begin Code -----
378 : !
379 : ! ! calculate the covariances of w with the hydrometeors
380 : ! do k = 1, nz
381 : ! wpchip_zm(k) = pdf_params(k)%mixt_frac &
382 : ! * ( one - pdf_params(k)%mixt_frac ) &
383 : ! * ( pdf_params(k)%chi_1 - pdf_params(k)%chi_2 ) &
384 : ! * ( pdf_params(k)%w_1 - pdf_params(k)%w_2 )
385 : ! enddo
386 : !
387 : !! same for wpNrp
388 : !! wprrp_zm(1:nz-1) &
389 : !! = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), &
390 : !! rrm(1:nz-1) / max( precip_frac(1:nz-1), eps ), &
391 : !! rrm(2:nz) / max( precip_frac(2:nz), eps ), &
392 : !! gr%invrs_dzm(1:nz-1) )
393 : !
394 : ! wprrp_zm(1:nz-1) &
395 : ! = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), &
396 : ! rrm(1:nz-1), rrm(2:nz), &
397 : ! gr%invrs_dzm(1:nz-1) )
398 : !
399 : ! wpNrp_zm(1:nz-1) &
400 : ! = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), &
401 : ! Nrm(1:nz-1), Nrm(2:nz), &
402 : ! gr%invrs_dzm(1:nz-1) )
403 : !
404 : ! wpNcnp_zm(1:nz-1) = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), Ncnm(1:nz-1), &
405 : ! Ncnm(2:nz), gr%invrs_dzm(1:nz-1) )
406 : !
407 : ! ! Boundary conditions; We are assuming constant flux at the top.
408 : ! wprrp_zm(nz) = wprrp_zm(nz-1)
409 : ! wpNrp_zm(nz) = wpNrp_zm(nz-1)
410 : ! wpNcnp_zm(nz) = wpNcnp_zm(nz-1)
411 : !
412 : ! ! interpolate back to zt-grid
413 : ! wpchip_zt = zm2zt(wpchip_zm)
414 : ! wprrp_zt = zm2zt(wprrp_zm)
415 : ! wpNrp_zt = zm2zt(wpNrp_zm)
416 : ! wpNcnp_zt = zm2zt(wpNcnp_zm)
417 : !
418 : ! end subroutine approx_w_covar
419 :
420 : !-----------------------------------------------------------------------
421 0 : function calc_w_corr( wpxp, stdev_w, stdev_x, w_tol, x_tol )
422 : ! Description:
423 : ! Compute the correlations of w with the hydrometeors.
424 :
425 : ! References:
426 : ! clubb:ticket:514
427 : !-----------------------------------------------------------------------
428 :
429 : use clubb_precision, only: &
430 : core_rknd ! Variable(s)
431 :
432 : use constants_clubb, only: &
433 : max_mag_correlation
434 :
435 : implicit none
436 :
437 : intrinsic :: max
438 :
439 : ! Input Variables
440 : real( kind = core_rknd ), intent(in) :: &
441 : stdev_w, & ! standard deviation of w [m/s]
442 : stdev_x, & ! standard deviation of x [units vary]
443 : wpxp, & ! Covariances of w with the hydrometeors [units vary]
444 : w_tol, & ! tolerance for w [m/s]
445 : x_tol ! tolerance for x [units vary]
446 :
447 : real( kind = core_rknd ) :: &
448 : calc_w_corr
449 :
450 : ! --- Begin Code ---
451 :
452 0 : calc_w_corr = wpxp / ( max(stdev_x, x_tol) * max(stdev_w, w_tol) )
453 :
454 : ! Make sure the correlation is in [-1,1]
455 0 : if ( calc_w_corr < -max_mag_correlation ) then
456 :
457 : calc_w_corr = -max_mag_correlation
458 :
459 0 : else if ( calc_w_corr > max_mag_correlation ) then
460 :
461 0 : calc_w_corr = max_mag_correlation
462 :
463 : end if
464 :
465 0 : end function calc_w_corr
466 :
467 :
468 : !-----------------------------------------------------------------------
469 0 : function calc_varnce( mixt_frac, x1, x2, xm, x1p2, x2p2 )
470 :
471 : ! Description:
472 : ! Calculate the variance xp2 from the components x1, x2.
473 :
474 : ! References:
475 : ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02,
476 : ! page 3535
477 : !-----------------------------------------------------------------------
478 :
479 : use clubb_precision, only: &
480 : core_rknd ! Variable(s)
481 :
482 : implicit none
483 :
484 : ! Input Variables
485 : real( kind = core_rknd ), intent(in) :: &
486 : mixt_frac, & ! mixing ratio [-]
487 : x1, & ! first component of the double gaussian [units vary]
488 : x2, & ! second component of the double gaussian [units vary]
489 : xm, & ! mean of x [units vary]
490 : x1p2, & ! variance of the first component [units vary]
491 : x2p2 ! variance of the second component [units vary]
492 :
493 : ! Return Variable
494 : real( kind = core_rknd ) :: &
495 : calc_varnce ! variance of x (both components) [units vary]
496 :
497 : ! --- Begin Code ---
498 :
499 : calc_varnce &
500 : = mixt_frac * ( ( x1 - xm )**2 + x1p2 ) &
501 0 : + ( 1.0_core_rknd - mixt_frac ) * ( ( x2 - xm )**2 + x2p2 )
502 :
503 : return
504 : end function calc_varnce
505 :
506 : !-----------------------------------------------------------------------
507 0 : function calc_mean( mixt_frac, x1, x2 )
508 :
509 : ! Description:
510 : ! Calculate the mean xm from the components x1, x2.
511 :
512 : ! References:
513 : ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02,
514 : ! page 3535
515 : !-----------------------------------------------------------------------
516 :
517 : use clubb_precision, only: &
518 : core_rknd ! Variable(s)
519 :
520 : implicit none
521 :
522 : ! Input Variables
523 : real( kind = core_rknd ), intent(in) :: &
524 : mixt_frac, & ! mixing ratio [-]
525 : x1, & ! first component of the double gaussian [units vary]
526 : x2 ! second component of the double gaussian [units vary]
527 :
528 : ! Return Variable
529 : real( kind = core_rknd ) :: &
530 : calc_mean ! mean of x (both components) [units vary]
531 :
532 : ! --- Begin Code ---
533 :
534 0 : calc_mean = mixt_frac * x1 + (1.0_core_rknd - mixt_frac) * x2
535 :
536 : return
537 : end function calc_mean
538 :
539 :
540 : !-----------------------------------------------------------------------
541 0 : subroutine calc_cholesky_corr_mtx_approx &
542 0 : ( n_variables, corr_matrix, & ! intent(in)
543 0 : corr_cholesky_mtx, corr_mtx_approx ) ! intent(out)
544 :
545 : ! Description:
546 : ! This subroutine calculates the transposed correlation cholesky matrix
547 : ! from the correlation matrix
548 : !
549 : ! References:
550 : ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02
551 : ! 2 CLUBB Trac ticket#514
552 : !-----------------------------------------------------------------------
553 :
554 : use clubb_precision, only: &
555 : core_rknd ! Variable(s)
556 :
557 : use constants_clubb, only: &
558 : zero ! Variable(s)
559 :
560 : implicit none
561 :
562 : ! Input Variables
563 : integer, intent(in) :: &
564 : n_variables ! number of variables in the correlation matrix [-]
565 :
566 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: &
567 : corr_matrix ! correlation matrix [-]
568 :
569 : ! Output Variables
570 :
571 : ! correlation cholesky matrix transposed L', C = LL'; see reference 1 formula 10
572 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: &
573 : corr_cholesky_mtx, & ! Transposed correlation cholesky matrix [-]
574 : corr_mtx_approx ! Approximated correlation matrix (C = LL') [-]
575 :
576 : ! Local Variables
577 : integer :: i, j ! Loop iterators
578 :
579 : ! Swapped means that the w-correlations are swapped to the first row
580 : real( kind = core_rknd ), dimension(n_variables,n_variables) :: &
581 0 : corr_cholesky_mtx_swap, & ! Swapped correlation cholesky matrix [-]
582 0 : corr_mtx_approx_swap, & ! Swapped correlation matrix (approx.) [-]
583 0 : corr_mtx_swap ! Swapped correlation matrix [-]
584 :
585 : !-------------------- Begin code --------------------
586 :
587 : call rearrange_corr_array( n_variables, corr_matrix, & ! Intent(in)
588 0 : corr_mtx_swap ) ! Intent(inout)
589 :
590 : call setup_corr_cholesky_mtx( n_variables, corr_mtx_swap, & ! intent(in)
591 0 : corr_cholesky_mtx_swap ) ! intent(out)
592 :
593 : call rearrange_corr_array( n_variables, corr_cholesky_mtx_swap, & ! Intent(in)
594 0 : corr_cholesky_mtx ) ! Intent(inout)
595 :
596 : call cholesky_to_corr_mtx_approx( n_variables, corr_cholesky_mtx_swap, & ! intent(in)
597 0 : corr_mtx_approx_swap ) ! intent(out)
598 :
599 : call rearrange_corr_array( n_variables, corr_mtx_approx_swap, & ! Intent(in)
600 0 : corr_mtx_approx ) ! Intent(inout)
601 :
602 0 : call corr_array_assertion_checks( n_variables, corr_mtx_approx ) ! intent(in)
603 :
604 : ! Set lower triangle to zero for conformity
605 0 : do i = 2, n_variables
606 0 : do j = 1, i-1
607 0 : corr_mtx_approx(j,i) = zero
608 : end do
609 : end do
610 :
611 0 : return
612 :
613 : end subroutine calc_cholesky_corr_mtx_approx
614 : !-----------------------------------------------------------------------
615 :
616 : !-----------------------------------------------------------------------
617 0 : subroutine setup_corr_cholesky_mtx( n_variables, corr_matrix, & ! intent(in)
618 0 : corr_cholesky_mtx_t ) ! intent(out)
619 :
620 : ! Description:
621 : ! This subroutine calculates the transposed correlation cholesky matrix
622 : ! from the correlation matrix
623 : !
624 : ! References:
625 : ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02
626 : ! 2 CLUBB Trac ticket#514
627 : !-----------------------------------------------------------------------
628 :
629 : use clubb_precision, only: &
630 : core_rknd ! Variable(s)
631 :
632 : use constants_clubb, only: &
633 : zero, & ! Variable(s)
634 : one
635 :
636 : implicit none
637 :
638 : intrinsic :: sqrt
639 :
640 : ! Input Variables
641 : integer, intent(in) :: &
642 : n_variables ! number of variables in the correlation matrix [-]
643 :
644 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: &
645 : corr_matrix ! correlation matrix [-]
646 :
647 : ! Output Variables
648 :
649 : ! correlation cholesky matrix transposed L', C = LL'; see reference 1 formula 10
650 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: &
651 : corr_cholesky_mtx_t ! transposed correlation cholesky matrix [-]
652 :
653 : ! Local Variables
654 : integer :: i, j, k ! Loop iterators
655 :
656 : real( kind = core_rknd ), dimension(n_variables, n_variables) :: &
657 0 : s ! s(i,j) = sqrt(1-c(i,j)^2); see ref 1
658 :
659 : !-------------------- Begin code --------------------
660 :
661 : ! calculate all necessary square roots
662 0 : do i = 1, n_variables-1
663 0 : do j = i+1, n_variables
664 :
665 0 : s(j,i) = sqrt(1._core_rknd - corr_matrix(j,i)**2)
666 :
667 : end do
668 : end do
669 :
670 : !!! calculate transposed correlation cholesky matrix; ref 1 formula 10
671 :
672 : ! initialize matrix to zero
673 0 : do i = 1, n_variables
674 0 : do j = 1, n_variables
675 :
676 0 : corr_cholesky_mtx_t(j,i) = zero
677 :
678 : end do
679 : end do
680 :
681 : ! initialize upper triangle and diagonal to one
682 0 : do i = 1, n_variables
683 0 : do j = i, n_variables
684 :
685 0 : corr_cholesky_mtx_t(j,i) = one
686 :
687 : end do
688 : end do
689 :
690 : ! set diagonal elements
691 0 : do j = 2, n_variables
692 0 : do i = 1, j-1
693 :
694 0 : corr_cholesky_mtx_t(j,j) = corr_cholesky_mtx_t(j,j)*s(j,i)
695 : ! print *, "s(", j, ",", i, ") = ", s(j,i)
696 :
697 : end do
698 : end do
699 :
700 : ! set first row
701 0 : do j = 2, n_variables
702 :
703 0 : corr_cholesky_mtx_t(j,1) = corr_matrix(j,1)
704 :
705 : end do
706 :
707 : ! set upper triangle
708 0 : do i = 2, n_variables-1
709 0 : do j = i+1, n_variables
710 0 : do k = 1, i-1
711 :
712 0 : corr_cholesky_mtx_t(j,i) = corr_cholesky_mtx_t(j,i)*s(j,k)
713 :
714 : end do
715 :
716 0 : corr_cholesky_mtx_t(j,i) = corr_cholesky_mtx_t(j,i)*corr_matrix(j,i)
717 :
718 : end do
719 : end do
720 :
721 0 : return
722 :
723 : end subroutine setup_corr_cholesky_mtx
724 : !-----------------------------------------------------------------------
725 :
726 :
727 : !-----------------------------------------------------------------------
728 0 : subroutine cholesky_to_corr_mtx_approx( n_variables, corr_cholesky_mtx_t, & ! intent(in)
729 0 : corr_matrix_approx ) ! intent(out)
730 :
731 : ! Description:
732 : ! This subroutine approximates the correlation matrix from the correlation
733 : ! cholesky matrix
734 : !
735 : ! References:
736 : ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02
737 : ! 2 CLUBB Trac ticket#514
738 : !-----------------------------------------------------------------------
739 :
740 : use clubb_precision, only: &
741 : core_rknd ! Variable(s)
742 :
743 : implicit none
744 :
745 : intrinsic :: matmul, transpose
746 :
747 : ! Input Variables
748 : integer, intent(in) :: &
749 : n_variables ! number of variables in the correlation matrix [-]
750 :
751 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: &
752 : corr_cholesky_mtx_t ! transposed correlation cholesky matrix [-]
753 :
754 : ! Output Variables
755 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: &
756 : corr_matrix_approx ! correlation matrix [-]
757 :
758 : !-------------------- Begin code --------------------
759 :
760 : ! approximate the correlation matrix; see ref 1 formula (8)
761 0 : corr_matrix_approx = matmul(corr_cholesky_mtx_t, transpose(corr_cholesky_mtx_t))
762 :
763 0 : return
764 :
765 : end subroutine cholesky_to_corr_mtx_approx
766 : !-----------------------------------------------------------------------
767 :
768 :
769 : !-----------------------------------------------------------------------
770 0 : subroutine corr_array_assertion_checks( n_variables, corr_array )
771 :
772 : ! Description:
773 : ! This subroutine does the assertion checks for the corr_array.
774 :
775 : ! References:
776 : !
777 : !
778 : !-----------------------------------------------------------------------
779 :
780 : use clubb_precision, only: &
781 : core_rknd ! Variable(s)
782 :
783 : use constants_clubb, only: &
784 : max_mag_correlation ! Variable(s)
785 :
786 : use constants_clubb, only: &
787 : one ! Variable(s)
788 :
789 : use error_code, only: &
790 : clubb_at_least_debug_level ! Procedure
791 :
792 : implicit none
793 :
794 : ! Input Variables
795 : integer, intent(in) :: &
796 : n_variables ! number of variables in the correlation matrix [-]
797 :
798 : real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: &
799 : corr_array ! correlation matrix [-]
800 :
801 : ! Local Variables
802 : integer :: i, j ! Loop iterator
803 :
804 : real( kind = core_rknd ), parameter :: &
805 : tol = 1.e-6_core_rknd ! Maximum acceptable tolerance for the difference of the diagonal
806 : ! elements of corr_array to one
807 :
808 : !-------------------- Begin code --------------------
809 :
810 0 : if ( clubb_at_least_debug_level( 1 ) ) then
811 :
812 0 : do i = 1, n_variables - 1
813 0 : do j = i+1, n_variables
814 :
815 : ! Check if upper and lower triangle values are within the correlation boundaries
816 0 : if ( ( corr_array(i,j) < -max_mag_correlation ) &
817 : .or. ( corr_array(i,j) > max_mag_correlation ) &
818 : .or. ( corr_array(j,i) < -max_mag_correlation ) &
819 0 : .or. ( corr_array(j,i) > max_mag_correlation ) ) &
820 0 : then
821 :
822 0 : error stop "Error: A value in the correlation matrix is out of range."
823 :
824 : endif
825 :
826 : enddo
827 : enddo
828 :
829 : endif
830 :
831 0 : if ( clubb_at_least_debug_level( 2 ) ) then
832 :
833 0 : do i = 1, n_variables
834 : ! Check if the diagonal elements are one (up to a tolerance)
835 0 : if ( ( corr_array(i,i) > one + tol ) .or. (corr_array(i,i) < one - tol ) ) then
836 :
837 0 : error stop "Error: Diagonal element(s) of the correlation matrix are unequal to one."
838 :
839 : endif
840 : enddo
841 :
842 : endif
843 :
844 0 : return
845 :
846 : end subroutine corr_array_assertion_checks
847 :
848 :
849 : !-----------------------------------------------------------------------
850 0 : subroutine rearrange_corr_array( pdf_dim, corr_array, & ! Intent(in)
851 0 : corr_array_swapped) ! Intent(out)
852 : ! Description:
853 : ! This subroutine swaps the w-correlations to the first row if the input
854 : ! matrix is in the same order as the *_corr_array_cloud.in files. It swaps
855 : ! the rows back to the order of the *_corr_array_cloud.in files if the
856 : ! input matrix is already swapped (first row w-correlations).
857 : !
858 : ! References:
859 : !
860 : !-----------------------------------------------------------------------
861 :
862 : use clubb_precision, only: &
863 : core_rknd ! Variable(s)
864 :
865 : use array_index, only: &
866 : iiPDF_w ! Variable(s)
867 :
868 : implicit none
869 :
870 : intrinsic :: max, sqrt, transpose
871 :
872 : ! Input Variables
873 : integer, intent(in) :: &
874 : pdf_dim ! number of diagnosed correlations
875 :
876 : real( kind = core_rknd ), dimension(pdf_dim, pdf_dim), intent(in) :: &
877 : corr_array ! Correlation matrix
878 :
879 : ! Output variables
880 : real( kind = core_rknd ), dimension(pdf_dim, pdf_dim), intent(out) :: &
881 : corr_array_swapped ! Swapped correlation matrix
882 :
883 : ! Local Variables
884 : real( kind = core_rknd ), dimension(pdf_dim) :: &
885 0 : swap_array
886 :
887 : !-------------------- Begin code --------------------
888 :
889 :
890 : ! Swap the w-correlations to the first row for the prescribed correlations
891 0 : corr_array_swapped = corr_array
892 0 : swap_array = corr_array_swapped (:,1)
893 0 : corr_array_swapped(1:iiPDF_w, 1) = corr_array_swapped(iiPDF_w, iiPDF_w:1:-1)
894 0 : corr_array_swapped((iiPDF_w+1):pdf_dim, 1) = corr_array_swapped( &
895 0 : (iiPDF_w+1):pdf_dim, iiPDF_w)
896 0 : corr_array_swapped(iiPDF_w, 1:iiPDF_w) = swap_array(iiPDF_w:1:-1)
897 0 : corr_array_swapped((iiPDF_w+1):pdf_dim, iiPDF_w) = swap_array((iiPDF_w+1):pdf_dim)
898 :
899 0 : return
900 :
901 : end subroutine rearrange_corr_array
902 : !-----------------------------------------------------------------------
903 :
904 :
905 : !-----------------------------------------------------------------------
906 : ! subroutine set_w_corr( nz, pdf_dim, & ! Intent(in)
907 : ! corr_chi_w, corr_wrr, corr_wNr, corr_wNcn, &
908 : ! corr_array ) ! Intent(inout)
909 : !
910 : ! ! Description:
911 : ! ! Set the first row of corr_array to the according w-correlations.
912 : !
913 : ! ! References:
914 : ! ! clubb:ticket:514
915 : ! !-----------------------------------------------------------------------
916 : !
917 : ! use clubb_precision, only: &
918 : ! core_rknd ! Variable(s)
919 : !
920 : ! use array_index, only: &
921 : ! iiPDF_w, & ! Variable(s)
922 : ! iiPDF_chi, &
923 : ! iiPDF_rr, &
924 : ! iiPDF_Nr, &
925 : ! iiPDF_Ncn
926 : !
927 : ! implicit none
928 : !
929 : ! ! Input Variables
930 : ! integer, intent(in) :: &
931 : ! nz, & ! Number of model vertical grid levels
932 : ! pdf_dim ! Number of Variables to be diagnosed
933 : !
934 : ! real( kind = core_rknd ), dimension(nz), intent(in) :: &
935 : ! corr_chi_w, & ! Correlation between chi (s) & w (both components) [-]
936 : ! corr_wrr, & ! Correlation between rr & w (both components) [-]
937 : ! corr_wNr, & ! Correlation between Nr & w (both components) [-]
938 : ! corr_wNcn ! Correlation between Ncn & w (both components) [-]
939 : !
940 : ! ! Input/Output Variables
941 : ! real( kind = core_rknd ), dimension(pdf_dim, pdf_dim, nz), &
942 : ! intent(inout) :: &
943 : ! corr_array
944 : !
945 : ! ! ----- Begin Code -----
946 : !
947 : ! corr_array(iiPDF_w, iiPDF_chi, :) = corr_chi_w
948 : ! corr_array(iiPDF_w, iiPDF_rr, :) = corr_wrr
949 : ! corr_array(iiPDF_w, iiPDF_Nr, :) = corr_wNr
950 : ! corr_array(iiPDF_w, iiPDF_Ncn, :) = corr_wNcn
951 : !
952 : ! end subroutine set_w_corr
953 :
954 : !=============================================================================
955 : ! subroutine unpack_correlations( pdf_dim, corr_array, & ! Intent(in)
956 : ! corr_w_chi, corr_wrr, corr_wNr, corr_wNcn, &
957 : ! corr_chi_eta, corr_chi_rr, corr_chi_Nr, corr_chi_Ncn, &
958 : ! corr_eta_rr, corr_eta_Nr, corr_eta_Ncn, corr_rrNr )
959 : !
960 : ! ! Description:
961 : !
962 : ! ! References:
963 : ! !-----------------------------------------------------------------------
964 :
965 : ! use clubb_precision, only: &
966 : ! core_rknd ! Variable(s)
967 :
968 : ! use array_index, only: &
969 : ! iiPDF_w, & ! Variable(s)
970 : ! iiPDF_chi, &
971 : ! iiPDF_eta, &
972 : ! iiPDF_rr, &
973 : ! iiPDF_Nr, &
974 : ! iiPDF_Ncn
975 :
976 : ! implicit none
977 :
978 : ! intrinsic :: max, sqrt, transpose
979 :
980 : ! ! Input Variables
981 : ! integer, intent(in) :: &
982 : ! pdf_dim ! number of diagnosed correlations
983 :
984 : ! real( kind = core_rknd ), dimension(pdf_dim, pdf_dim), intent(in) :: &
985 : ! corr_array ! Prescribed correlations
986 :
987 : ! ! Output variables
988 : ! real( kind = core_rknd ), intent(out) :: &
989 : ! corr_w_chi, & ! Correlation between w and chi(s) (1st PDF component) [-]
990 : ! corr_wrr, & ! Correlation between w and rr (1st PDF component) ip [-]
991 : ! corr_wNr, & ! Correlation between w and Nr (1st PDF component) ip [-]
992 : ! corr_wNcn, & ! Correlation between w and Ncn (1st PDF component) [-]
993 : ! corr_chi_eta, & ! Correlation between chi(s) and eta(t) (1st PDF component) [-]
994 : ! corr_chi_rr, & ! Correlation between chi(s) and rr (1st PDF component) ip [-]
995 : ! corr_chi_Nr, & ! Correlation between chi(s) and Nr (1st PDF component) ip [-]
996 : ! corr_chi_Ncn, & ! Correlation between chi(s) and Ncn (1st PDF component) [-]
997 : ! corr_eta_rr, & ! Correlation between eta(t) and rr (1st PDF component) ip [-]
998 : ! corr_eta_Nr, & ! Correlation between eta(t) and Nr (1st PDF component) ip [-]
999 : ! corr_eta_Ncn, & ! Correlation between (t) and Ncn (1st PDF component) [-]
1000 : ! corr_rrNr ! Correlation between rr & Nr (1st PDF component) ip [-]
1001 :
1002 : ! ---- Begin Code ----
1003 :
1004 : ! corr_w_chi = corr_array(iiPDF_w, iiPDF_chi)
1005 : ! corr_wrr = corr_array(iiPDF_w, iiPDF_rr)
1006 : ! corr_wNr = corr_array(iiPDF_w, iiPDF_Nr)
1007 : ! corr_wNcn = corr_array(iiPDF_w, iiPDF_Ncn)
1008 : ! corr_chi_eta = corr_array(iiPDF_chi, iiPDF_eta)
1009 : ! corr_chi_rr = corr_array(iiPDF_chi, iiPDF_rr)
1010 : ! corr_chi_Nr = corr_array(iiPDF_chi, iiPDF_Nr)
1011 : ! corr_chi_Ncn = corr_array(iiPDF_chi, iiPDF_Ncn)
1012 : ! corr_eta_rr = corr_array(iiPDF_eta, iiPDF_rr)
1013 : ! corr_eta_Nr = corr_array(iiPDF_eta, iiPDF_Nr)
1014 : ! corr_eta_Ncn = corr_array(iiPDF_eta, iiPDF_Ncn)
1015 : ! corr_rrNr = corr_array(iiPDF_rr, iiPDF_Nr)
1016 :
1017 : ! corr_w_chi = corr_array(iiPDF_chi, iiPDF_w)
1018 : ! corr_wrr = corr_array(iiPDF_rr, iiPDF_w)
1019 : ! corr_wNr = corr_array(iiPDF_Nr, iiPDF_w)
1020 : ! corr_wNcn = corr_array(iiPDF_Ncn, iiPDF_w)
1021 : ! corr_chi_eta = corr_array(iiPDF_eta, iiPDF_chi)
1022 : ! corr_chi_rr = corr_array(iiPDF_rr, iiPDF_chi)
1023 : ! corr_chi_Nr = corr_array(iiPDF_Nr, iiPDF_chi)
1024 : ! corr_chi_Ncn = corr_array(iiPDF_Ncn, iiPDF_chi)
1025 : ! corr_eta_rr = corr_array(iiPDF_rr, iiPDF_eta)
1026 : ! corr_eta_Nr = corr_array(iiPDF_Nr, iiPDF_eta)
1027 : ! corr_eta_Ncn = corr_array(iiPDF_Ncn, iiPDF_eta)
1028 : ! corr_rrNr = corr_array(iiPDF_rr, iiPDF_Nr)
1029 :
1030 : ! end subroutine unpack_correlations
1031 :
1032 : !===============================================================================
1033 :
1034 : end module diagnose_correlations_module
|