├── latin_hypercube_arrays.F90 ├── version_silhs.txt ├── ChangeLog ├── math_utilities.F90 ├── lh_microphys_var_covar_module.F90 ├── generate_uniform_sample_module.F90 ├── output_2D_samples_module.F90 ├── parameters_silhs.F90 ├── est_kessler_microphys_module.F90 ├── transform_to_pdf_module.F90 └── silhs_api_module.F90 /latin_hypercube_arrays.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module latin_hypercube_arrays 5 | 6 | use clubb_precision, only: & 7 | core_rknd 8 | 9 | implicit none 10 | 11 | public :: cleanup_latin_hypercube_arrays 12 | 13 | private 14 | 15 | integer, allocatable, dimension(:,:), public :: & 16 | one_height_time_matrix ! matrix of rand ints 17 | 18 | !$omp threadprivate(one_height_time_matrix) 19 | 20 | contains 21 | 22 | !----------------------------------------------------------------------------- 23 | subroutine cleanup_latin_hypercube_arrays( ) 24 | 25 | ! Description: 26 | ! De-allocate latin hypercube arrays 27 | ! References: 28 | ! None 29 | !--------------------------------------------------------------------------- 30 | implicit none 31 | 32 | ! External 33 | intrinsic :: allocated 34 | 35 | ! ---- Begin Code ---- 36 | 37 | if ( allocated( one_height_time_matrix ) ) then 38 | deallocate( one_height_time_matrix ) 39 | end if 40 | 41 | return 42 | end subroutine cleanup_latin_hypercube_arrays 43 | 44 | end module latin_hypercube_arrays 45 | -------------------------------------------------------------------------------- /version_silhs.txt: -------------------------------------------------------------------------------- 1 | commit b0575cc936312f99dcffe9f1f7bea6932cd1fd4a 2 | Author: pbroels <56004443+pbroels@users.noreply.github.com> 3 | Date: Thu Feb 20 14:08:48 2020 -0600 4 | 5 | Removing blank line to trigger bitten tests. larson-group/sys_admin#680 6 | 7 | commit 10c3a3974e3aea4c5c0aa7739f50148ac9b439af 8 | Merge: cc749d3 ae411ce 9 | Author: bmg929 10 | Date: Thu Feb 20 13:49:21 2020 -0600 11 | 12 | Merge branch 'master' of https://github.com/larson-group/clubb 13 | 14 | Whoops, forgot to git pull first. Sorry folks. 15 | 16 | commit cc749d30b1f3d21677eb1ee06377dfcebe0bf209 17 | Author: bmg929 18 | Date: Thu Feb 20 13:47:48 2020 -0600 19 | 20 | I added some code I used in the special input fields branch to make 21 | the PDF of w symmetric, so that the PDF at a value of positive skewness 22 | of w (for example, +2) looks like a mirror image of the PDF at the opposite 23 | value of negative skewness (for example, -2). 24 | 25 | commit ae411ce2fd2443fe360ece019732bec493375543 26 | Author: pbroels <56004443+pbroels@users.noreply.github.com> 27 | Date: Thu Feb 20 13:24:12 2020 -0600 28 | 29 | Adding a line to trigger the bitten tests. larson-group/sys_admin#680 30 | 31 | commit f6aace9982a06222eb20027b0efe5b0e72f703fd 32 | Author: bmg929 33 | Date: Sat Feb 15 08:58:49 2020 -0600 34 | 35 | I added the new l_update_pressure configurable flag to clubb_config_flags. 36 | When this flag is enabled (which it is by default), CLUBB updates 37 | pressure and exner every timestep. This new flags allows this feature 38 | to easily be turned off within the context of host models, such as 39 | CAM and E3SM. 40 | 41 | The results in GrADS output files from this revision are an exact match 42 | to the results in GrADS output files from the previous revision for 43 | all cases. 44 | 45 | commit 8be0be97456a82711c6945dcb7f4d138cd88788f 46 | Author: Steffen Domke 47 | Date: Fri Feb 14 17:44:12 2020 -0600 48 | 49 | Added new VariableGroup VariableGroupSamProfiles, changed image files to .png, 50 | fixed problem with relative paths in gallery.py, 51 | added constant specifying automatic sci limits 52 | 53 | https://github.com/larson-group/sys_admin/542 54 | 55 | commit fbcbd865f97bc8f9b7c16d2c80326368a637a204 56 | Author: Niklas Selke 57 | Date: Fri Feb 14 17:20:11 2020 -0600 58 | 59 | I changed the dummy argument 'value' in the 'stat_update_var' subroutine from explicit to assumed size. #874 60 | 61 | commit e7ebb4c73149dbd627f09c21ec4ada1884826ff9 62 | Author: Steffen Domke 63 | Date: Fri Feb 14 17:15:11 2020 -0600 64 | 65 | Finshed migrating SAM budgets into pyplotgen. Added labels to all budgets listed in VariableGroupSamBudgets.py 66 | 67 | commit 200b3f2b11e886962705fa2dd674f16dd4a6dea6 68 | Author: Gunther Huebler 69 | Date: Thu Feb 6 17:14:20 2020 -0600 70 | 71 | Making some data copying regions asyncronous with compute regions, improving performance. This is bit-for-bit. larson-group/clubb#869 72 | 73 | commit c255f61b0d0cc2ed8e99db39cd07acb635ba3735 74 | Author: Gunther Huebler 75 | Date: Thu Feb 6 14:51:33 2020 -0600 76 | 77 | GPUizing clip_transform_silhs_output and pushing data directives up call tree. This is all bit-for-bit. larson-group/clubb#869 78 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | ====================================================================== 2 | 3 | Tag: silhs_clubb_release_b76a124_20200220_c20200320 4 | Tag creator: cacraig, Brian Griffin 5 | Date created: March 20, 2020 6 | Command(s) issued: 7 | git clone https://github.com/larson-group/clubb_release 8 | cd clubb_release 9 | git checkout b76a124 10 | 11 | No CAM specific changes needed to be made 12 | ====================================================================== 13 | 14 | Tag: silhs_ncar_backwards_compat_20181205_c20191001 15 | Tag creator: cacraig, nusbaume 16 | Date created: Oct 1, 2019 17 | Command(s) issued: 18 | git clone https://github.com/larson-group/clubb_release 19 | cd clubb_release 20 | git checkout ncar_backwards_compat_20181205 21 | cd ~/clubb_release/src/SILHS 22 | 23 | commit everything in this directory, adding in the ChangeLog from CAM's vendor tags repo 24 | 25 | ====================================================================== 26 | 27 | Tag: silhs_ncar_backwards_compat_20181205 28 | Tag creator: cacraig 29 | Date created: April 29, 2019 30 | Command(s) issued: 31 | git clone https://github.com/larson-group/clubb_release 32 | cd clubb_release 33 | git checkout ncar_backwards_compat_20181205 34 | 35 | svn co https://svn-ccsm-models.cgd.ucar.edu/silhs/vendor_trunk 36 | cd vendor_trunk 37 | cp ~/clubb_release/src/SILHS/* . 38 | 39 | Status: 40 | M ChangeLog 41 | A README 42 | M est_kessler_microphys_module.F90 43 | M generate_uniform_sample_module.F90 44 | M latin_hypercube_arrays.F90 45 | M latin_hypercube_driver_module.F90 46 | M lh_microphys_var_covar_module.F90 47 | M math_utilities.F90 48 | M output_2D_samples_module.F90 49 | M parameters_silhs.F90 50 | M silhs_api_module.F90 51 | M silhs_importance_sample_module.F90 52 | M transform_to_pdf_module.F90 53 | 54 | ====================================================================== 55 | Tag: silhs_r8099 56 | Tag creator: cacraig 57 | Date created: April 11, 2016 58 | Command(s) issued: 59 | svn co https://svn-ccsm-models.cgd.ucar.edu/silhs/vendor_trunk silhs_r8099 60 | cd silhs_r8099 61 | svn merge -r8029:8099 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/SILHS 62 | 63 | Status: 64 | M latin_hypercube_driver_module.F90 65 | 66 | ====================================================================== 67 | Tag: silhs_r8029 68 | Tag creator: cacraig 69 | Date created: April 11, 2016 70 | Command(s) issued: 71 | svn co https://svn-ccsm-models.cgd.ucar.edu/silhs/vendor_trunk silhs_r8029 72 | cd silhs_r8029 73 | svn merge -r7416:8029 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/SILHS 74 | svn resolve --accept=working generate_lh_sample_module.F90 75 | svn delete generate_lh_sample_module.F90 76 | svn resolve --accept=working permute_height_time_module.F90 77 | svn delete permute_height_time_module.F90 78 | 79 | Status: 80 | M ChangeLog 81 | M est_kessler_microphys_module.F90 82 | D generate_lh_sample_module.F90 83 | A generate_uniform_sample_module.F90 84 | M latin_hypercube_arrays.F90 85 | M latin_hypercube_driver_module.F90 86 | A lh_microphys_var_covar_module.F90 87 | M math_utilities.F90 88 | M output_2D_samples_module.F90 89 | M parameters_silhs.F90 90 | D permute_height_time_module.F90 91 | M silhs_api_module.F90 92 | A silhs_importance_sample_module.F90 93 | A transform_to_pdf_module.F90 94 | 95 | ====================================================================== 96 | Tag: silhs_r7416 97 | Tag creator: cacraig 98 | Date created: April 11, 2016 99 | Command(s) issued: 100 | svn co -r7416 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/SILHS silhs_r7416 101 | svn import silhs_r7416 https://svn-ccsm-models.cgd.ucar.edu/silhs/vendor_trunk -m"Initial checkout of revision 7416 from UWM" 102 | ====================================================================== 103 | -------------------------------------------------------------------------------- /math_utilities.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | module math_utilities 5 | !----------------------------------------------------------------------- 6 | ! Various mathematical utilities 7 | !----------------------------------------------------------------------- 8 | implicit none 9 | 10 | public :: compute_sample_mean, compute_sample_variance, compute_sample_covariance, & 11 | rand_integer_in_range 12 | 13 | private 14 | 15 | contains 16 | 17 | !----------------------------------------------------------------------- 18 | pure function compute_sample_mean( n_levels, n_samples, weight, x_sample ) & 19 | result( mean ) 20 | ! Description: 21 | ! Find the mean of a set of sample points 22 | 23 | ! References: 24 | ! None 25 | !----------------------------------------------------------------------- 26 | 27 | use clubb_precision, only: & 28 | core_rknd ! Variable(s) 29 | 30 | implicit none 31 | 32 | ! External 33 | intrinsic :: real, sum 34 | 35 | ! Input Varibles 36 | integer, intent(in) :: & 37 | n_levels, & 38 | n_samples 39 | 40 | real( kind = core_rknd ),dimension(n_levels,n_samples), intent(in) :: & 41 | weight ! Weights for individual points of the vector 42 | 43 | real( kind = core_rknd ),dimension(n_levels,n_samples), intent(in) :: & 44 | x_sample ! Collection of sample points [units vary] 45 | 46 | ! Return type 47 | real( kind = core_rknd ), dimension(n_levels) :: mean 48 | 49 | integer :: k 50 | 51 | ! ---- Begin Code ---- 52 | 53 | ! Get rid of an annoying compiler warning. 54 | k = 1 55 | k = k 56 | 57 | forall( k = 1:n_levels ) 58 | mean(k) = sum( weight(k,1:n_samples) * x_sample(k,1:n_samples) ) & 59 | / real( n_samples, kind=core_rknd ) 60 | end forall 61 | 62 | 63 | return 64 | 65 | end function compute_sample_mean 66 | 67 | !----------------------------------------------------------------------- 68 | pure function compute_sample_variance( n_levels, n_samples, x_sample, weight, x_mean ) & 69 | result( variance ) 70 | 71 | ! Description: 72 | ! Compute the variance of a set of sample points 73 | 74 | ! References: 75 | ! None 76 | !----------------------------------------------------------------------- 77 | 78 | use clubb_precision, only: & 79 | core_rknd ! Variable(s) 80 | 81 | implicit none 82 | 83 | ! Input Variables 84 | integer, intent(in) :: & 85 | n_levels, & ! Number of sample levels in the mean / variance 86 | n_samples ! Number of sample points compute the variance of 87 | 88 | real( kind = core_rknd ),dimension(n_levels,n_samples), intent(in) :: & 89 | x_sample ! Collection of sample points [units vary] 90 | 91 | real( kind = core_rknd ),dimension(n_levels,n_samples), intent(in) :: & 92 | weight ! Coefficient to weight the nth sample point by [-] 93 | 94 | real( kind = core_rknd ),dimension(n_levels), intent(in) :: & 95 | x_mean ! Mean sample points [units vary] 96 | 97 | ! Output Variable 98 | real( kind = core_rknd ),dimension(n_levels) :: & 99 | variance ! Variance of x [(units vary)^2] 100 | 101 | ! Local Variable(s) 102 | integer :: sample ! Loop iterator 103 | 104 | ! ---- Begin Code ---- 105 | 106 | variance(1:n_levels) = 0.0_core_rknd 107 | 108 | do sample=1, n_samples 109 | variance(1:n_levels) = variance(1:n_levels) & 110 | + weight(1:n_levels,sample) * ( x_sample(1:n_levels,sample) - x_mean(1:n_levels) )**2 111 | end do 112 | 113 | variance(1:n_levels) = variance(1:n_levels) / real( n_samples, kind=core_rknd ) 114 | 115 | return 116 | end function compute_sample_variance 117 | 118 | !----------------------------------------------------------------------- 119 | pure function compute_sample_covariance( n_levels, n_samples, weight, & 120 | x_sample, x_mean, y_sample, y_mean ) & 121 | result( covariance ) 122 | 123 | ! Description: 124 | ! Compute the covariance of a set of sample points of 2 variables 125 | !----------------------------------------------------------------------- 126 | 127 | use clubb_precision, only: & 128 | core_rknd ! Variable(s) 129 | 130 | implicit none 131 | 132 | ! Input Variables 133 | integer, intent(in) :: & 134 | n_levels, & ! Number of sample levels in the mean / variance 135 | n_samples ! Number of sample points compute the variance of 136 | 137 | real( kind = core_rknd ),dimension(n_levels,n_samples), intent(in) :: & 138 | x_sample, & ! Collection of sample points [units vary] 139 | y_sample 140 | 141 | real( kind = core_rknd ),dimension(n_levels,n_samples), intent(in) :: & 142 | weight ! Coefficient to weight the nth sample point by [-] 143 | 144 | real( kind = core_rknd ),dimension(n_levels), intent(in) :: & 145 | x_mean, & ! Mean sample points [units vary] 146 | y_mean 147 | 148 | ! Output Variable 149 | real( kind = core_rknd ),dimension(n_levels) :: & 150 | covariance ! Coariance of x and y [(units vary)^2] 151 | 152 | ! Local Variable(s) 153 | integer :: sample ! Loop iterator 154 | 155 | ! ---- Begin Code ---- 156 | 157 | covariance(1:n_levels) = 0.0_core_rknd 158 | 159 | do sample=1, n_samples 160 | covariance(1:n_levels) = covariance(1:n_levels) & 161 | + weight(1:n_levels,sample) * ( x_sample(1:n_levels,sample) - x_mean(1:n_levels) ) & 162 | * ( y_sample(1:n_levels,sample) - y_mean(1:n_levels) ) 163 | end do 164 | 165 | covariance(1:n_levels) = covariance(1:n_levels) / real( n_samples, kind=core_rknd ) 166 | 167 | return 168 | end function compute_sample_covariance 169 | 170 | !----------------------------------------------------------------------- 171 | function rand_integer_in_range(low, high) 172 | 173 | ! Description: 174 | ! Returns a uniformly distributed integer in the range [low,high] 175 | ! using the Mersenne Twister PRNG library. 176 | ! 177 | ! The integers returned from this function are actually not quite 178 | ! evenly distributed because of the use of MOD. Smaller numbers are 179 | ! slightly more likely than larger ones. This could be fixed someday. 180 | 181 | ! References: 182 | ! None 183 | !----------------------------------------------------------------------- 184 | 185 | ! Included Modules 186 | use mt95, only: & 187 | genrand_intg, & ! Constant 188 | genrand_int32 ! Procedure 189 | 190 | implicit none 191 | 192 | ! Local Constants 193 | 194 | ! Input Variables 195 | integer, intent(in) :: & 196 | low, & ! Lowest possible returned value 197 | high ! Highest possible returned value 198 | 199 | ! Output Variable 200 | integer :: & 201 | rand_integer_in_range ! Random integer in range [low,high] 202 | 203 | ! Local Variables 204 | integer( kind = genrand_intg ) :: & 205 | rand_32 ! Random integer in range[-2^31, +2^31-1] 206 | 207 | integer :: & 208 | range_width 209 | 210 | !----------------------------------------------------------------------- 211 | !----- Begin Code ----- 212 | 213 | range_width = high - low + 1 214 | call genrand_int32( rand_32 ) 215 | rand_integer_in_range = abs( mod( rand_32, range_width ) ) + low 216 | 217 | return 218 | end function rand_integer_in_range 219 | !----------------------------------------------------------------------- 220 | 221 | 222 | end module math_utilities 223 | -------------------------------------------------------------------------------- /lh_microphys_var_covar_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module lh_microphys_var_covar_module 5 | 6 | implicit none 7 | 8 | public :: lh_microphys_var_covar_driver 9 | 10 | private ! Default scope 11 | 12 | contains 13 | 14 | !----------------------------------------------------------------------- 15 | subroutine lh_microphys_var_covar_driver & 16 | ( nz, num_samples, dt, lh_sample_point_weights, & 17 | pdf_params, lh_rt_all, lh_thl_all, lh_w_all, & 18 | lh_rcm_mc_all, lh_rvm_mc_all, lh_thlm_mc_all, & 19 | l_lh_instant_var_covar_src, & 20 | lh_rtp2_mc_zt, lh_thlp2_mc_zt, lh_wprtp_mc_zt, & 21 | lh_wpthlp_mc_zt, lh_rtpthlp_mc_zt ) 22 | 23 | ! Description: 24 | ! Computes the effect of microphysics on gridbox variances and covariances 25 | 26 | ! More description: 27 | ! The equations for the (co)variance microphysical tendencies, when 28 | ! integrated forward in time explicitly, are: 29 | ! 30 | ! rtp2_mc = 2*covar(rt,rt_mc) + dt*var(rt_mc) 31 | ! thlp2_mc = 2*covar(thl,thl_mc) + dt*var(thl_mc) 32 | ! wprtp_mc = covar(w,rt_mc) 33 | ! wpthlp_mc = covar(w,thl_mc) 34 | ! rtpthlp_mc = covar(thl,rt_mc) + covar(rt,thl_mc) + dt*covar(rt_mc,thl_mc) 35 | ! 36 | ! This code can optionally take the limit of these equations at an 37 | ! infinitesimally small time step, such that the terms involving 38 | ! dt drop out. This configuration agrees with the KK upscaled analytic 39 | ! solution. (See clubb:ticket:753 for more discussion on this.) 40 | 41 | ! References: 42 | ! None 43 | !----------------------------------------------------------------------- 44 | 45 | ! Included Modules 46 | use clubb_precision, only: & 47 | core_rknd ! Constant 48 | 49 | use math_utilities, only: & 50 | compute_sample_mean, & ! Procedure(s) 51 | compute_sample_variance, & 52 | compute_sample_covariance 53 | 54 | use constants_clubb, only: & 55 | zero, one, two ! Constant(s) 56 | 57 | use pdf_parameter_module, only: & 58 | pdf_parameter 59 | 60 | use grid_class, only: & 61 | zt2zm 62 | 63 | implicit none 64 | 65 | ! Input Variables! 66 | integer, intent(in) :: & 67 | nz, & ! Number of vertical levels 68 | num_samples ! Number of SILHS sample points 69 | 70 | real( kind = core_rknd ), intent(in) :: & 71 | dt ! Model time step [s] 72 | 73 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 74 | lh_sample_point_weights ! Weight of SILHS sample points 75 | 76 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 77 | lh_rt_all, & ! SILHS samples of total water [kg/kg] 78 | lh_thl_all, & ! SILHS samples of potential temperature [K] 79 | lh_w_all, & ! SILHS samples of vertical velocity [m/s] 80 | lh_rcm_mc_all, & ! SILHS microphys. tendency of rcm [kg/kg/s] 81 | lh_rvm_mc_all, & ! SILHS microphys. tendency of rvm [kg/kg/s] 82 | lh_thlm_mc_all ! SILHS microphys. tendency of thlm [K/s] 83 | 84 | logical, intent(in) :: & 85 | l_lh_instant_var_covar_src ! Produce instantaneous var/covar tendencies [-] 86 | 87 | ! Output Variables 88 | real( kind = core_rknd ), dimension(nz), intent(out) :: & 89 | lh_rtp2_mc_zt, & ! SILHS microphys. est. tendency of [(kg/kg)^2/s] 90 | lh_thlp2_mc_zt, & ! SILHS microphys. est. tendency of [K^2/s] 91 | lh_wprtp_mc_zt, & ! SILHS microphys. est. tendency of [m*(kg/kg)/s^2] 92 | lh_wpthlp_mc_zt, & ! SILHS microphys. est. tendency of [m*K/s^2] 93 | lh_rtpthlp_mc_zt ! SILHS microphys. est. tendency of [K*(kg/kg)/s] 94 | 95 | ! Local Variables 96 | real( kind = core_rknd ), dimension(nz,num_samples) :: & 97 | lh_rt_mc_all 98 | 99 | real( kind = core_rknd ), dimension(nz) :: & 100 | mean_rt, & 101 | mean_rt_mc, & 102 | covar_rt_rt_mc, & 103 | mean_thl, & 104 | mean_thl_mc, & 105 | covar_thl_thl_mc, & 106 | mean_w, & 107 | covar_w_rt_mc, & 108 | covar_w_thl_mc, & 109 | covar_thl_rt_mc, & 110 | covar_rt_thl_mc 111 | 112 | ! For timestep-dependent terms 113 | real( kind = core_rknd ), dimension(nz) :: & 114 | var_rt_mc, & 115 | var_thl_mc, & 116 | covar_rt_mc_thl_mc 117 | 118 | type(pdf_parameter), intent(in) :: & 119 | pdf_params ! The PDF parameters_silhs 120 | 121 | !----------------------------------------------------------------------- 122 | 123 | !----- Begin Code ----- 124 | lh_rt_mc_all = lh_rcm_mc_all + lh_rvm_mc_all 125 | 126 | ! Calculate means, variances, and covariances needed for the tendency terms 127 | mean_rt = pdf_params%mixt_frac * pdf_params%rt_1 & 128 | + (one - pdf_params%mixt_frac) * pdf_params%rt_2 129 | mean_rt(1) = zero 130 | 131 | mean_thl = pdf_params%mixt_frac * pdf_params%thl_1 & 132 | + (one - pdf_params%mixt_frac) * pdf_params%thl_2 133 | mean_thl(1) = zero 134 | 135 | mean_w = pdf_params%mixt_frac * pdf_params%w_1 & 136 | + (one - pdf_params%mixt_frac) * pdf_params%w_2 137 | mean_w(1) = zero 138 | 139 | ! Calculate means, variances, and covariances needed for the tendency terms 140 | mean_rt_mc = compute_sample_mean( nz, num_samples, lh_sample_point_weights, lh_rt_mc_all ) 141 | covar_rt_rt_mc = compute_sample_covariance( nz, num_samples, lh_sample_point_weights, & 142 | lh_rt_all, mean_rt, lh_rt_mc_all, mean_rt_mc ) 143 | 144 | mean_thl_mc = compute_sample_mean( nz, num_samples, lh_sample_point_weights, lh_thlm_mc_all ) 145 | covar_thl_thl_mc = compute_sample_covariance( nz, num_samples, lh_sample_point_weights, & 146 | lh_thl_all, mean_thl, lh_thlm_mc_all, mean_thl_mc ) 147 | 148 | covar_w_rt_mc = compute_sample_covariance( nz, num_samples, lh_sample_point_weights, & 149 | lh_w_all, mean_w, lh_rt_mc_all, mean_rt_mc ) 150 | covar_w_thl_mc = compute_sample_covariance( nz, num_samples, lh_sample_point_weights, & 151 | lh_w_all, mean_w, lh_thlm_mc_all, mean_thl_mc ) 152 | covar_thl_rt_mc = compute_sample_covariance( nz, num_samples, lh_sample_point_weights, & 153 | lh_thl_all, mean_thl, lh_rt_mc_all, mean_rt_mc ) 154 | covar_rt_thl_mc = compute_sample_covariance( nz, num_samples, lh_sample_point_weights, & 155 | lh_rt_all, mean_rt, lh_thlm_mc_all, mean_thl_mc ) 156 | 157 | ! Variances and covariances for timestep-dependent terms 158 | if ( .not. l_lh_instant_var_covar_src ) then 159 | 160 | ! NOTE: these terms arise in rtp2 and thlp2 when rtm and thlm are 161 | ! explicitly integrated forward in time. These terms are not included 162 | ! in KK upscaled, so using these terms causes non-convergence with KK 163 | ! upscaled. 164 | 165 | var_rt_mc = compute_sample_variance & 166 | ( nz, num_samples, lh_rt_mc_all, lh_sample_point_weights, & 167 | mean_rt_mc ) 168 | var_thl_mc = compute_sample_variance & 169 | ( nz, num_samples, lh_thlm_mc_all, lh_sample_point_weights, & 170 | mean_thl_mc ) 171 | covar_rt_mc_thl_mc = compute_sample_covariance & 172 | ( nz, num_samples, lh_sample_point_weights, & 173 | lh_rt_mc_all, mean_rt_mc, lh_thlm_mc_all, mean_thl_mc ) 174 | 175 | end if ! .not. l_lh_instant_var_covar_src 176 | 177 | ! Compute the microphysical variance and covariance tendencies 178 | lh_rtp2_mc_zt = two*covar_rt_rt_mc 179 | lh_thlp2_mc_zt = two*covar_thl_thl_mc 180 | lh_wprtp_mc_zt = covar_w_rt_mc 181 | lh_wpthlp_mc_zt = covar_w_thl_mc 182 | lh_rtpthlp_mc_zt = covar_thl_rt_mc + covar_rt_thl_mc 183 | 184 | if ( .not. l_lh_instant_var_covar_src ) then 185 | ! Add timestep-dependent terms 186 | lh_rtp2_mc_zt = lh_rtp2_mc_zt + dt*var_rt_mc 187 | lh_thlp2_mc_zt = lh_thlp2_mc_zt + dt*var_thl_mc 188 | lh_rtpthlp_mc_zt = lh_rtpthlp_mc_zt + dt*covar_rt_mc_thl_mc 189 | end if ! .not. l_lh_instant_var_covar_src 190 | 191 | return 192 | end subroutine lh_microphys_var_covar_driver 193 | !----------------------------------------------------------------------- 194 | end module lh_microphys_var_covar_module 195 | -------------------------------------------------------------------------------- /generate_uniform_sample_module.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | module generate_uniform_sample_module 5 | 6 | implicit none 7 | 8 | public :: permute_height_time, rand_permute, rand_uniform_real, generate_uniform_lh_sample, & 9 | choose_permuted_random 10 | 11 | private ! Default Scope 12 | 13 | integer, private :: & 14 | prior_iter ! Prior iteration number (for diagnostic purposes) 15 | !$omp threadprivate( prior_iter ) 16 | 17 | contains 18 | 19 | !----------------------------------------------------------------------- 20 | function rand_uniform_real( ) 21 | 22 | ! Description: 23 | ! Generates a uniformly distributed random real number in the range 24 | ! (0,1) using the Mersenne Twister random number generator 25 | 26 | ! References: 27 | ! None 28 | !----------------------------------------------------------------------- 29 | 30 | use clubb_precision, only: & 31 | core_rknd ! Precision 32 | 33 | use mt95, only: & 34 | genrand_real, & ! Precision 35 | genrand_real3 ! Procedure 36 | 37 | use constants_clubb, only: & 38 | one ! Constant 39 | 40 | implicit none 41 | 42 | ! Output Variable 43 | real( kind = core_rknd ) :: & 44 | rand_uniform_real ! A randomly distributed real number in the range (0,1) 45 | 46 | ! Local Variable 47 | real( kind = genrand_real ) :: & 48 | rand_uniform_real_genrand_real 49 | 50 | !----------------------------------------------------------------------- 51 | !----- Begin Code ----- 52 | call genrand_real3( rand_uniform_real_genrand_real ) 53 | 54 | rand_uniform_real = real( rand_uniform_real_genrand_real, kind=core_rknd ) 55 | 56 | ! It is theoretically possible that the resulting real number is equal to 57 | ! one if core_rknd is not the same as genrand_real. Here, we apply clipping 58 | ! to prevent the output real number from being exactly equal to one. 59 | if ( rand_uniform_real >= one ) then 60 | rand_uniform_real = one - epsilon( rand_uniform_real ) 61 | end if 62 | 63 | return 64 | end function rand_uniform_real 65 | !----------------------------------------------------------------------- 66 | 67 | !------------------------------------------------------------------------------- 68 | subroutine generate_uniform_lh_sample( iter, num_samples, sequence_length, n_vars, & 69 | X_u_one_lev ) 70 | 71 | ! Description: 72 | ! Generates a matrix X that contains a Latin Hypercube sample. 73 | ! The sample is uniformly distributed. 74 | ! References: 75 | ! https://arxiv.org/pdf/1711.03675v1.pdf#nameddest=url:lh_algorithm 76 | ! 77 | ! See Art B. Owen (2003), ``Quasi-Monte Carlo Sampling," 78 | ! a chapter from SIGGRAPH 2003 79 | !------------------------------------------------------------------------------- 80 | 81 | use clubb_precision, only: & 82 | core_rknd ! Precision 83 | 84 | use latin_hypercube_arrays, only: & 85 | one_height_time_matrix ! Variable 86 | 87 | use constants_clubb, only: & 88 | fstderr ! Constant 89 | 90 | implicit none 91 | 92 | ! Local Constants 93 | logical, parameter :: & 94 | l_diagnostic_iter_check = .true. ! Perform check to make sure SILHS is being called 95 | ! correctly 96 | 97 | ! Input Variables 98 | integer, intent(in) :: & 99 | iter, & ! Model iteration number 100 | num_samples, & ! `n' Number of samples generated 101 | sequence_length, & ! `n_t' Num. random samples before sequence repeats 102 | n_vars ! Number of uniform variables to generate 103 | 104 | ! Output Variables 105 | 106 | real(kind=core_rknd), intent(out), dimension(num_samples,n_vars) :: & 107 | X_u_one_lev ! num_samples by n_vars matrix, X 108 | ! each row of which is a n_vars-dimensional sample 109 | 110 | ! Local Variables 111 | 112 | integer :: j, k, nt_repeat, i_rmd 113 | 114 | ! ---- Begin Code ---- 115 | 116 | nt_repeat = num_samples * sequence_length 117 | 118 | if ( .not. allocated( one_height_time_matrix ) ) then 119 | ! If this is first time latin_hypercube_driver is called, then allocate 120 | ! the one_height_time_matrix and set the prior iteration number for debugging 121 | ! purposes. 122 | allocate( one_height_time_matrix(nt_repeat, n_vars) ) 123 | 124 | prior_iter = iter 125 | 126 | else if ( l_diagnostic_iter_check .and. sequence_length > 1 ) then 127 | ! Check for a bug where the iteration number isn't incrementing correctly, 128 | ! which will lead to improper sampling. 129 | 130 | if ( prior_iter /= iter-1 ) then 131 | write(fstderr,*) "The iteration number in latin_hypercube_driver is"// & 132 | " not incrementing properly." 133 | else 134 | prior_iter = iter 135 | end if 136 | end if ! First call to the driver 137 | 138 | ! Latin hypercube sample generation 139 | ! Generate one_height_time_matrix, an nt_repeat x pdf_dimarray of random integers 140 | i_rmd = mod( iter-1, sequence_length ) 141 | 142 | if ( i_rmd == 0 ) then 143 | call permute_height_time( nt_repeat, n_vars, & ! intent(in) 144 | one_height_time_matrix ) ! intent(out) 145 | end if 146 | ! End Latin hypercube sample generation 147 | 148 | ! Choose values of sample using permuted vector and random number generator 149 | do j = 1,num_samples 150 | do k = 1,n_vars 151 | X_u_one_lev(j,k) = choose_permuted_random( nt_repeat, one_height_time_matrix(j,k) ) 152 | end do 153 | end do 154 | 155 | return 156 | end subroutine generate_uniform_lh_sample 157 | !---------------------------------------------------------------------- 158 | 159 | !---------------------------------------------------------------------- 160 | function choose_permuted_random( nt_repeat, p_matrix_element ) 161 | 162 | ! Description: 163 | ! Chooses a permuted random using the Mersenne Twister algorithm. 164 | ! 165 | ! References: 166 | ! None 167 | !---------------------------------------------------------------------- 168 | 169 | use clubb_precision, only: & 170 | core_rknd 171 | 172 | use constants_clubb, only: & 173 | one ! Constant 174 | 175 | implicit none 176 | 177 | ! Input Variables 178 | integer, intent(in) :: & 179 | nt_repeat, & ! Number of samples before the sequence repeats 180 | p_matrix_element ! Permuted integer 181 | 182 | ! Output Variable 183 | real(kind=core_rknd) :: choose_permuted_random 184 | 185 | ! Local Variable 186 | real(kind=core_rknd) :: & 187 | rand ! Random float with a range of (0,1) 188 | 189 | ! ---- Begin Code ---- 190 | 191 | rand = rand_uniform_real( ) 192 | 193 | choose_permuted_random = (one / real( nt_repeat, kind=core_rknd) ) & 194 | *( real( p_matrix_element, kind=core_rknd ) + rand ) 195 | 196 | return 197 | end function choose_permuted_random 198 | !----------------------------------------------------------------------- 199 | 200 | !----------------------------------------------------------------------- 201 | subroutine permute_height_time( nt_repeat, n_vars, one_height_time_matrix ) 202 | 203 | ! Description: 204 | ! Generates a matrix one_height_time_matrix, which is a nt_repeat x n_vars 205 | ! matrix whose 1st dimension is random permutations of the integer sequence 206 | ! (0,...,nt_repeat-1). 207 | 208 | ! References: 209 | ! None 210 | !----------------------------------------------------------------------- 211 | 212 | implicit none 213 | 214 | ! Input Variables 215 | 216 | integer, intent(in) :: & 217 | nt_repeat, & ! Total number of sample points before sequence repeats. 218 | n_vars ! The number of variates in the uniform sample 219 | 220 | ! Output Variables 221 | 222 | integer, dimension(nt_repeat,n_vars), intent(out) :: & 223 | one_height_time_matrix ! nt_repeat x n_vars matrix of integers 224 | 225 | ! Local Variables 226 | 227 | integer :: i 228 | 229 | ! Choose elements of one_height_time_matrix, with a random integer LH sample 230 | ! for each variate 231 | do i = 1, n_vars 232 | call rand_permute( nt_repeat, one_height_time_matrix(1:nt_repeat,i) ) 233 | end do 234 | 235 | return 236 | end subroutine permute_height_time 237 | !------------------------------------------------------------------------ 238 | 239 | !------------------------------------------------------------------------ 240 | subroutine rand_permute( n, pvect ) 241 | ! Description: 242 | ! Generates a vector of length n 243 | ! containing the integers 0, ... , n-1 in random order. 244 | ! We do not use a new seed. 245 | 246 | ! References: 247 | ! Follow `Quasi-Monte Carlo sampling' by Art Owen, Section 1.3 248 | ! He follows, in turn, Luc Devroye 'Non-uniform random ...' (1986) 249 | !---------------------------------------------------------------------- 250 | 251 | use mt95, only: genrand_real3 ! Procedures 252 | 253 | use mt95, only: genrand_real ! Constants 254 | 255 | implicit none 256 | 257 | ! External 258 | 259 | intrinsic :: int 260 | 261 | ! Input Variables 262 | 263 | integer, intent(in) :: n ! Number of elements to permute 264 | 265 | ! Output Variables 266 | 267 | integer, dimension(n), intent(out) :: & 268 | pvect ! Array of n numbers in random order 269 | 270 | ! Local Variables 271 | 272 | integer j, k, temp 273 | 274 | real(kind=genrand_real) :: rand ! Random float on interval (0,1) 275 | 276 | ! Start with an ordered vector, pvect 277 | do j=1,n 278 | pvect(j) = j 279 | end do 280 | 281 | ! Now re-arrange the elements 282 | do j=n,2,-1 283 | temp = pvect(j) 284 | call genrand_real3( rand ) ! real3 excludes 0 and 1. 285 | ! choose an element randomly between 1 and j 286 | k = int( real( j, kind=genrand_real )*rand+1.0_genrand_real ) 287 | ! swap elements j and k 288 | pvect(j) = pvect(k) 289 | pvect(k) = temp 290 | end do 291 | 292 | ! Convert range of array from 1:n to 0:n-1 293 | do j=1,n 294 | pvect(j) = pvect(j) - 1 295 | end do 296 | 297 | return 298 | end subroutine rand_permute 299 | !------------------------------------------------------------------------ 300 | 301 | end module generate_uniform_sample_module 302 | -------------------------------------------------------------------------------- /output_2D_samples_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module output_2D_samples_module 5 | 6 | use stat_file_module, only : stat_file ! Type 7 | 8 | implicit none 9 | 10 | public :: open_2D_samples_file, close_2D_samples_file, & 11 | output_2D_uniform_dist_file, output_2D_lognormal_dist_file 12 | 13 | private ! Default scope 14 | 15 | type(stat_file), public :: & 16 | lognormal_sample_file, & 17 | uniform_sample_file 18 | 19 | !$omp threadprivate( lognormal_sample_file, uniform_sample_file ) 20 | 21 | contains 22 | !------------------------------------------------------------------------------- 23 | subroutine open_2D_samples_file( nz, num_samples, n_2D_variables, & 24 | fname_prefix, fdir, & 25 | time, dtwrite, zgrid, variable_names, & 26 | variable_descriptions, variable_units, & 27 | sample_file ) 28 | ! Description: 29 | ! Open a 2D sample file 30 | ! References: 31 | ! None 32 | !------------------------------------------------------------------------------- 33 | #ifdef NETCDF 34 | use output_netcdf, only: open_netcdf_for_writing ! Procedure(s) 35 | #endif 36 | 37 | use clubb_precision, only: time_precision, core_rknd ! Constant(s) 38 | 39 | implicit none 40 | 41 | ! Parameter Constants 42 | integer, parameter :: & 43 | day = 1, & ! Made up times for GrADS 44 | month = 1, & 45 | year = 1900 46 | 47 | ! Input Variables 48 | integer, intent(in) :: & 49 | nz, & ! Number of vertical levels 50 | num_samples, & ! Number of samples per variable 51 | n_2D_variables ! Number variables to output 52 | 53 | character(len=*), intent(in) :: & 54 | fdir, & ! Output directory 55 | fname_prefix ! Prefix for the netCDF output 56 | 57 | character(len=*), intent(in), dimension(n_2D_variables) :: & 58 | variable_names, & ! Names of the variables to be used in the 2D netCDF file 59 | variable_descriptions, & ! Description of the variables in the 2D file 60 | variable_units ! Units on the variables 61 | 62 | real(kind=time_precision), intent(in) :: & 63 | time ! Start time [s] 64 | 65 | real(kind=core_rknd), intent(in) :: & 66 | dtwrite ! Interval for writing to disk [s] 67 | 68 | real( kind = core_rknd ), intent(in), dimension(nz) :: & 69 | zgrid ! Vertical grid levels [m] 70 | 71 | ! Input/Output Variables 72 | type(stat_file), intent(inout) :: & 73 | sample_file ! File that is being opened 74 | 75 | ! Local Variables 76 | integer :: nlat, nlon ! Not actually latitudes and longitudes 77 | 78 | real( kind = core_rknd ), dimension(num_samples) :: rlat 79 | 80 | real( kind = core_rknd ), dimension(1) :: rlon 81 | 82 | character(len=100) :: fname 83 | integer :: i 84 | 85 | ! ---- Begin Code ---- 86 | 87 | fname = trim( fname_prefix )//"_lh_sample_points_2D" 88 | i =1 ! This assignment prevents a g 95 compiler warning 89 | 90 | ! We need to set this like a latitude to trick GrADS and allow of viewing of 91 | ! the sample points with the GrADS application and sdfopen. 92 | nlat = num_samples 93 | nlon = 1 94 | 95 | allocate( sample_file%rlat(num_samples), sample_file%rlon(1) ) 96 | allocate( sample_file%var(n_2D_variables) ) 97 | allocate( sample_file%z(nz) ) 98 | 99 | forall( i=1:num_samples ) 100 | rlat(i) = real( i, kind = core_rknd ) ! Use made up arbitrary values for degrees north 101 | end forall 102 | 103 | rlon = 1.0_core_rknd ! Also made up 104 | 105 | do i=1, n_2D_variables 106 | sample_file%var(i)%name = trim( variable_names(i) ) 107 | sample_file%var(i)%description = trim( variable_descriptions(i) ) 108 | sample_file%var(i)%units = trim( variable_units(i) ) 109 | end do 110 | 111 | #ifdef NETCDF 112 | call open_netcdf_for_writing( nlat, nlon, fdir, fname, 1, nz, zgrid, & 113 | day, month, year, rlat, rlon, & 114 | time, dtwrite, n_2D_variables, sample_file ) 115 | #else 116 | stop "This version of CLUBB was not compiled for netCDF output" 117 | #endif 118 | 119 | return 120 | end subroutine open_2D_samples_file 121 | 122 | !------------------------------------------------------------------------------- 123 | subroutine output_2D_lognormal_dist_file & 124 | ( nz, num_samples, pdf_dim, X_nl_all_levs, & 125 | l_uv_nudge, & 126 | l_tke_aniso, & 127 | l_standard_term_ta, & 128 | l_single_C2_Skw ) 129 | ! Description: 130 | ! Output a 2D snapshot of latin hypercube samples 131 | ! References: 132 | ! None 133 | !------------------------------------------------------------------------------- 134 | #ifdef NETCDF 135 | use output_netcdf, only: write_netcdf ! Procedure(s) 136 | #endif 137 | 138 | use clubb_precision, only: stat_rknd ! Constant(s) 139 | 140 | implicit none 141 | 142 | ! Input Variables 143 | integer, intent(in) :: & 144 | nz, & ! Number of vertical levels 145 | num_samples, & ! Number of samples per variable 146 | pdf_dim ! Number variates being sampled 147 | 148 | real(kind=stat_rknd), intent(in), dimension(nz,num_samples,pdf_dim) :: & 149 | X_nl_all_levs ! Sample that is transformed ultimately to normal-lognormal 150 | 151 | logical, intent(in) :: & 152 | l_uv_nudge, & ! For wind speed nudging 153 | l_tke_aniso, & ! For anisotropic turbulent kinetic energy, i.e. TKE = 1/2 154 | ! (u'^2 + v'^2 + w'^2) 155 | l_standard_term_ta, & ! Use the standard discretization for the turbulent advection terms. 156 | ! Setting to .false. means that a_1 and a_3 are pulled outside of the 157 | ! derivative in advance_wp2_wp3_module.F90 and in 158 | ! advance_xp2_xpyp_module.F90. 159 | l_single_C2_Skw ! Use a single Skewness dependent C2 for rtp2, thlp2, and rtpthlp 160 | 161 | integer :: sample, j 162 | 163 | ! ---- Begin Code ---- 164 | 165 | do j = 1, pdf_dim 166 | allocate( lognormal_sample_file%var(j)%ptr(num_samples,1,nz) ) 167 | end do 168 | 169 | do sample = 1, num_samples 170 | do j = 1, pdf_dim 171 | lognormal_sample_file%var(j)%ptr(sample,1,1:nz) = X_nl_all_levs(1:nz,sample,j) 172 | end do 173 | end do 174 | 175 | #ifdef NETCDF 176 | call write_netcdf( l_uv_nudge, & 177 | l_tke_aniso, & 178 | l_standard_term_ta, & 179 | l_single_C2_Skw, & 180 | lognormal_sample_file ) 181 | #else 182 | stop "This version of CLUBB was not compiled for netCDF output" 183 | #endif 184 | 185 | do j = 1, pdf_dim 186 | deallocate( lognormal_sample_file%var(j)%ptr ) 187 | end do 188 | 189 | return 190 | end subroutine output_2D_lognormal_dist_file 191 | 192 | !------------------------------------------------------------------------------- 193 | subroutine output_2D_uniform_dist_file & 194 | ( nz, num_samples, dp2, X_u_all_levs, X_mixt_comp_all_levs, & 195 | lh_sample_point_weights, & 196 | l_uv_nudge, & 197 | l_tke_aniso, & 198 | l_standard_term_ta, & 199 | l_single_C2_Skw ) 200 | ! Description: 201 | ! Output a 2D snapshot of latin hypercube uniform distribution, i.e. (0,1) 202 | ! References: 203 | ! None 204 | !------------------------------------------------------------------------------- 205 | #ifdef NETCDF 206 | use output_netcdf, only: write_netcdf ! Procedure(s) 207 | #endif 208 | 209 | use clubb_precision, only: & 210 | core_rknd, & ! Precision(s) 211 | stat_rknd 212 | 213 | implicit none 214 | 215 | ! Input Variables 216 | integer, intent(in) :: & 217 | nz, & ! Number of vertical levels 218 | num_samples, & ! Number of samples per variable 219 | dp2 ! Number of variates being sampled + 2 220 | 221 | real(kind=core_rknd), intent(in), dimension(nz,num_samples,dp2) :: & 222 | X_u_all_levs ! Uniformly distributed numbers between (0,1) 223 | 224 | integer, intent(in), dimension(nz,num_samples) :: & 225 | X_mixt_comp_all_levs ! Either 1 or 2 226 | 227 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 228 | lh_sample_point_weights ! Weight of each sample 229 | 230 | logical, intent(in) :: & 231 | l_uv_nudge, & ! For wind speed nudging 232 | l_tke_aniso, & ! For anisotropic turbulent kinetic energy, i.e. TKE = 1/2 233 | ! (u'^2 + v'^2 + w'^2) 234 | l_standard_term_ta, & ! Use the standard discretization for the turbulent advection terms. 235 | ! Setting to .false. means that a_1 and a_3 are pulled outside of the 236 | ! derivative in advance_wp2_wp3_module.F90 and in 237 | ! advance_xp2_xpyp_module.F90. 238 | l_single_C2_Skw ! Use a single Skewness dependent C2 for rtp2, thlp2, and rtpthlp 239 | 240 | integer :: sample, j, k 241 | 242 | ! ---- Begin Code ---- 243 | 244 | do j = 1, dp2+2 245 | allocate( uniform_sample_file%var(j)%ptr(num_samples,1,nz) ) 246 | end do 247 | 248 | do sample = 1, num_samples 249 | do j = 1, dp2 250 | uniform_sample_file%var(j)%ptr(sample,1,1:nz) = & 251 | real( X_u_all_levs(1:nz,sample,j), kind = stat_rknd ) 252 | end do 253 | uniform_sample_file%var(dp2+1)%ptr(sample,1,1:nz) = & 254 | real( X_mixt_comp_all_levs(1:nz,sample), kind=stat_rknd ) 255 | do k = 1, nz 256 | uniform_sample_file%var(dp2+2)%ptr(sample,1,k) = & 257 | real( lh_sample_point_weights(k,sample), kind=stat_rknd ) 258 | end do 259 | end do 260 | 261 | #ifdef NETCDF 262 | call write_netcdf( l_uv_nudge, & 263 | l_tke_aniso, & 264 | l_standard_term_ta, & 265 | l_single_C2_Skw, & 266 | uniform_sample_file ) 267 | #else 268 | stop "This version of CLUBB was not compiled for netCDF output" 269 | #endif 270 | 271 | do j = 1, dp2+2 272 | deallocate( uniform_sample_file%var(j)%ptr ) 273 | end do 274 | 275 | return 276 | end subroutine output_2D_uniform_dist_file 277 | 278 | !------------------------------------------------------------------------------- 279 | subroutine close_2D_samples_file( sample_file ) 280 | ! Description: 281 | ! Close a 2D sample file 282 | ! References: 283 | ! None 284 | !------------------------------------------------------------------------------- 285 | #ifdef NETCDF 286 | use output_netcdf, only: close_netcdf ! Procedure 287 | #endif 288 | 289 | implicit none 290 | 291 | type(stat_file), intent(inout) :: & 292 | sample_file ! File that is being opened 293 | 294 | ! ---- Begin Code ---- 295 | 296 | #ifdef NETCDF 297 | call close_netcdf( sample_file ) 298 | #else 299 | stop "This version of CLUBB was not compiled for netCDF output" 300 | #endif 301 | 302 | deallocate( sample_file%rlat, sample_file%rlon ) 303 | deallocate( sample_file%var) 304 | deallocate( sample_file%z) 305 | 306 | return 307 | end subroutine close_2D_samples_file 308 | 309 | end module output_2D_samples_module 310 | -------------------------------------------------------------------------------- /parameters_silhs.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module parameters_silhs 5 | 6 | ! Description: 7 | ! Parameters for SILHS! 8 | 9 | ! References: 10 | ! None 11 | !------------------------------------------------------------------------- 12 | 13 | use clubb_precision, only: & 14 | core_rknd ! Constant 15 | 16 | implicit none 17 | 18 | ! Cluster allocation strategies!!! 19 | integer, parameter, public :: & 20 | ! All eight categories, effectively no clustering 21 | eight_cluster_allocation_opt = 1, & 22 | ! Four clusters for the combinations of cloud/no cloud and component 1/2. 23 | ! Precipitation fraction is ignored. 24 | four_cluster_allocation_opt = 2, & 25 | ! Two clusters, one containing all categories with either cloud or precip, 26 | ! and the other containing categories with neither 27 | two_cluster_cp_nocp_opt = 3 28 | 29 | ! The following type defines parameters that control the sample point 30 | ! allocation for the clustered sampling scheme 31 | ! (l_lh_clustered_sampling = .true.). 32 | type eight_cluster_presc_probs_type 33 | 34 | real( kind = core_rknd ) :: & 35 | cloud_precip_comp1 = 0.15_core_rknd, & 36 | cloud_precip_comp2 = 0.15_core_rknd, & 37 | nocloud_precip_comp1 = 0.15_core_rknd, & 38 | nocloud_precip_comp2 = 0.15_core_rknd, & 39 | cloud_noprecip_comp1 = 0.15_core_rknd, & 40 | cloud_noprecip_comp2 = 0.15_core_rknd, & 41 | nocloud_noprecip_comp1 = 0.05_core_rknd, & 42 | nocloud_noprecip_comp2 = 0.05_core_rknd 43 | 44 | end type eight_cluster_presc_probs_type 45 | 46 | ! Flags for the SILHS sampling code 47 | type silhs_config_flags_type 48 | 49 | integer :: & 50 | cluster_allocation_strategy 51 | logical :: & 52 | l_lh_importance_sampling, & ! Do importance sampling 53 | l_Lscale_vert_avg, & ! Vertically average Lscale 54 | l_lh_straight_mc, & ! Do not apply LH or importance sampling at all 55 | l_lh_clustered_sampling, & ! Use prescribed probability sampling with clusters 56 | l_rcm_in_cloud_k_lh_start, & ! Determine k_lh_start based on maximum within-cloud rcm 57 | l_random_k_lh_start, & ! k_lh_start found randomly between max rcm and rcm_in_cloud 58 | l_max_overlap_in_cloud, & ! Use maximum vertical overlap in cloud 59 | l_lh_instant_var_covar_src, & ! Produce instantaneous var/covar tendencies 60 | l_lh_limit_weights, & ! Ensure weights stay under a given value 61 | l_lh_var_frac, & ! Prescribe variance fractions 62 | l_lh_normalize_weights ! Normalize weights to sum to num_samples 63 | 64 | end type silhs_config_flags_type 65 | 66 | type(eight_cluster_presc_probs_type), public, save :: & 67 | eight_cluster_presc_probs ! Prescribed probabilities for 68 | ! l_lh_clustered_sampling = .true. 69 | 70 | !$omp threadprivate( eight_cluster_presc_probs ) 71 | 72 | real( kind = core_rknd ), public :: & 73 | importance_prob_thresh = 1.0e-8_core_rknd, & ! Minimum PDF probability of category for 74 | ! importance sampling 75 | vert_decorr_coef = 0.03_core_rknd ! Empirically defined de-correlation constant [-] 76 | 77 | !$omp threadprivate( importance_prob_thresh, vert_decorr_coef ) 78 | 79 | 80 | real( kind = core_rknd ), public, parameter :: & 81 | single_prec_thresh = 3.e-8_core_rknd ! Uniform samples are expected to be in the range 82 | ! [3.e-8_core_rknd,1-3.e-8_core_rknd] since the 83 | ! algorithm used to calculate the inverse cdf is 84 | ! only accurate for single precision values 85 | 86 | private ! Default Scope 87 | 88 | public :: eight_cluster_presc_probs_type, silhs_config_flags_type, & 89 | set_default_silhs_config_flags, initialize_silhs_config_flags_type, & 90 | print_silhs_config_flags 91 | 92 | contains 93 | 94 | !------------------------------------------------------------------------------- 95 | subroutine set_default_silhs_config_flags( cluster_allocation_strategy, & 96 | l_lh_importance_sampling, & 97 | l_Lscale_vert_avg, & 98 | l_lh_straight_mc, & 99 | l_lh_clustered_sampling, & 100 | l_rcm_in_cloud_k_lh_start, & 101 | l_random_k_lh_start, & 102 | l_max_overlap_in_cloud, & 103 | l_lh_instant_var_covar_src, & 104 | l_lh_limit_weights, & 105 | l_lh_var_frac, & 106 | l_lh_normalize_weights ) 107 | 108 | ! Description: 109 | ! Sets all SILHS flags to a default setting. 110 | 111 | ! References: 112 | ! None 113 | !--------------------------------------------------------------------------- 114 | 115 | implicit none 116 | 117 | ! Output variables 118 | integer, intent(out) :: & 119 | cluster_allocation_strategy ! Two clusters, one containing all categories with either 120 | ! cloud or precip, and the other containing categories with 121 | ! neither 122 | 123 | logical, intent(out) :: & 124 | l_lh_importance_sampling, & ! Limit noise by performing importance sampling 125 | l_Lscale_vert_avg, & ! Calculate Lscale_vert_avg in generate_silhs_sample 126 | l_lh_straight_mc, & ! Use true Monte Carlo sampling with no Latin 127 | ! hypercube sampling and no importance sampling 128 | l_lh_clustered_sampling, & ! Use the "new" SILHS importance sampling 129 | ! scheme with prescribed probabilities 130 | l_rcm_in_cloud_k_lh_start, & ! Determine k_lh_start based on maximum within-cloud rcm 131 | l_random_k_lh_start, & ! Place k_lh_start at a random grid level between 132 | ! maximum rcm and maximum rcm_in_cloud 133 | l_max_overlap_in_cloud, & ! Assume maximum vertical overlap when grid-box rcm 134 | ! exceeds cloud threshold 135 | l_lh_instant_var_covar_src, & ! Produces "instantaneous" variance-covariance 136 | ! microphysical source terms, ignoring 137 | ! discretization effects 138 | l_lh_limit_weights, & ! Limit SILHS sample point weights for stability 139 | l_lh_var_frac, & ! Prescribe variance fractions 140 | l_lh_normalize_weights ! Scale sample point weights to sum to num_samples 141 | ! (the "ratio estimate") 142 | 143 | !----------------------------------------------------------------------- 144 | ! Begin code 145 | 146 | cluster_allocation_strategy = two_cluster_cp_nocp_opt 147 | l_lh_importance_sampling = .true. ! Limit noise by performing importance sampling 148 | l_Lscale_vert_avg = .true. ! Calculate Lscale_vert_avg in generate_silhs_sample 149 | l_lh_straight_mc = .false. ! Use true Monte Carlo sampling with no Latin 150 | ! hypercube sampling and no importance sampling 151 | l_lh_clustered_sampling = .true. ! Use the "new" SILHS importance sampling 152 | ! scheme with prescribed probabilities 153 | l_rcm_in_cloud_k_lh_start = .true. ! Determine k_lh_start based on maximum within-cloud rcm 154 | l_random_k_lh_start = .false. ! Place k_lh_start at a random grid level between 155 | ! maximum rcm and maximum rcm_in_cloud 156 | l_max_overlap_in_cloud = .true. ! Assume maximum vertical overlap when grid-box rcm 157 | ! exceeds cloud threshold 158 | l_lh_instant_var_covar_src = .true. ! Produces "instantaneous" variance-covariance 159 | ! microphysical source terms, ignoring 160 | ! discretization effects 161 | l_lh_limit_weights = .true. ! Limit SILHS sample point weights for stability 162 | l_lh_var_frac = .false. ! Prescribe variance fractions 163 | l_lh_normalize_weights = .true. ! Scale sample point weights to sum to num_samples 164 | ! (the "ratio estimate") 165 | 166 | return 167 | end subroutine set_default_silhs_config_flags 168 | !----------------------------------------------------------------------- 169 | 170 | !------------------------------------------------------------------------------- 171 | subroutine initialize_silhs_config_flags_type( cluster_allocation_strategy, & 172 | l_lh_importance_sampling, & 173 | l_Lscale_vert_avg, & 174 | l_lh_straight_mc, & 175 | l_lh_clustered_sampling, & 176 | l_rcm_in_cloud_k_lh_start, & 177 | l_random_k_lh_start, & 178 | l_max_overlap_in_cloud, & 179 | l_lh_instant_var_covar_src, & 180 | l_lh_limit_weights, & 181 | l_lh_var_frac, & 182 | l_lh_normalize_weights, & 183 | silhs_config_flags ) 184 | 185 | ! Description: 186 | ! Initialize the silhs_config_flags_type. 187 | 188 | ! References: 189 | ! None 190 | !--------------------------------------------------------------------------- 191 | 192 | implicit none 193 | 194 | ! Input variables 195 | integer, intent(in) :: & 196 | cluster_allocation_strategy ! Two clusters, one containing all categories with either 197 | ! cloud or precip, and the other containing categories with 198 | ! neither 199 | 200 | logical, intent(in) :: & 201 | l_lh_importance_sampling, & ! Limit noise by performing importance sampling 202 | l_Lscale_vert_avg, & ! Calculate Lscale_vert_avg in generate_silhs_sample 203 | l_lh_straight_mc, & ! Use true Monte Carlo sampling with no Latin 204 | ! hypercube sampling and no importance sampling 205 | l_lh_clustered_sampling, & ! Use the "new" SILHS importance sampling 206 | ! scheme with prescribed probabilities 207 | l_rcm_in_cloud_k_lh_start, & ! Determine k_lh_start based on maximum within-cloud rcm 208 | l_random_k_lh_start, & ! Place k_lh_start at a random grid level between 209 | ! maximum rcm and maximum rcm_in_cloud 210 | l_max_overlap_in_cloud, & ! Assume maximum vertical overlap when grid-box rcm 211 | ! exceeds cloud threshold 212 | l_lh_instant_var_covar_src, & ! Produces "instantaneous" variance-covariance 213 | ! microphysical source terms, ignoring 214 | ! discretization effects 215 | l_lh_limit_weights, & ! Limit SILHS sample point weights for stability 216 | l_lh_var_frac, & ! Prescribe variance fractions 217 | l_lh_normalize_weights ! Scale sample point weights to sum to num_samples 218 | ! (the "ratio estimate") 219 | 220 | ! Output variables 221 | type(silhs_config_flags_type), intent(out) :: & 222 | silhs_config_flags ! Derived type holding all configurable SILHS flags 223 | 224 | !----------------------------------------------------------------------- 225 | ! Begin code 226 | 227 | silhs_config_flags%cluster_allocation_strategy = cluster_allocation_strategy 228 | silhs_config_flags%l_lh_importance_sampling = l_lh_importance_sampling 229 | silhs_config_flags%l_Lscale_vert_avg = l_Lscale_vert_avg 230 | silhs_config_flags%l_lh_straight_mc = l_lh_straight_mc 231 | silhs_config_flags%l_lh_clustered_sampling = l_lh_clustered_sampling 232 | silhs_config_flags%l_rcm_in_cloud_k_lh_start = l_rcm_in_cloud_k_lh_start 233 | silhs_config_flags%l_random_k_lh_start = l_random_k_lh_start 234 | silhs_config_flags%l_max_overlap_in_cloud = l_max_overlap_in_cloud 235 | silhs_config_flags%l_lh_instant_var_covar_src = l_lh_instant_var_covar_src 236 | silhs_config_flags%l_lh_limit_weights = l_lh_limit_weights 237 | silhs_config_flags%l_lh_var_frac = l_lh_var_frac 238 | silhs_config_flags%l_lh_normalize_weights = l_lh_normalize_weights 239 | 240 | return 241 | end subroutine initialize_silhs_config_flags_type 242 | !----------------------------------------------------------------------- 243 | 244 | !------------------------------------------------------------------------------- 245 | subroutine print_silhs_config_flags( iunit, silhs_config_flags ) 246 | 247 | ! Description: 248 | ! Prints the silhs_config_flags. 249 | 250 | ! References: 251 | ! None 252 | !--------------------------------------------------------------------------- 253 | 254 | implicit none 255 | 256 | ! Input variables 257 | integer, intent(in) :: & 258 | iunit ! The file to write to 259 | 260 | type(silhs_config_flags_type), intent(in) :: & 261 | silhs_config_flags ! Derived type holding all configurable SILHS flags 262 | 263 | !----------------------------------------------------------------------- 264 | ! Begin code 265 | 266 | write(iunit,*) "cluster_allocation_strategy = ", silhs_config_flags%cluster_allocation_strategy 267 | write(iunit,*) "l_lh_importance_sampling = ", silhs_config_flags%l_lh_importance_sampling 268 | write(iunit,*) "l_Lscale_vert_avg = ", silhs_config_flags%l_Lscale_vert_avg 269 | write(iunit,*) "l_lh_straight_mc = ", silhs_config_flags%l_lh_straight_mc 270 | write(iunit,*) "l_lh_clustered_sampling = ", silhs_config_flags%l_lh_clustered_sampling 271 | write(iunit,*) "l_rcm_in_cloud_k_lh_start = ", silhs_config_flags%l_rcm_in_cloud_k_lh_start 272 | write(iunit,*) "l_random_k_lh_start = ", silhs_config_flags%l_random_k_lh_start 273 | write(iunit,*) "l_max_overlap_in_cloud = ", silhs_config_flags%l_max_overlap_in_cloud 274 | write(iunit,*) "l_lh_instant_var_covar_src = ", silhs_config_flags%l_lh_instant_var_covar_src 275 | write(iunit,*) "l_lh_limit_weights = ", silhs_config_flags%l_lh_limit_weights 276 | write(iunit,*) "l_lh_var_frac = ", silhs_config_flags%l_lh_var_frac 277 | write(iunit,*) "l_lh_normalize_weights = ", silhs_config_flags%l_lh_normalize_weights 278 | 279 | return 280 | end subroutine print_silhs_config_flags 281 | !----------------------------------------------------------------------- 282 | 283 | end module parameters_silhs 284 | -------------------------------------------------------------------------------- /est_kessler_microphys_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | 5 | module est_kessler_microphys_module 6 | 7 | implicit none 8 | 9 | public :: est_kessler_microphys 10 | 11 | private :: calc_estimate 12 | 13 | private ! Default Scope 14 | 15 | contains 16 | 17 | !------------------------------------------------------------------------ 18 | 19 | subroutine est_kessler_microphys & 20 | ( nz, num_samples, pdf_dim, & 21 | X_nl_all_levs, pdf_params, rcm, cloud_frac, & 22 | X_mixt_comp_all_levs, lh_sample_point_weights, & 23 | l_lh_importance_sampling, & 24 | lh_AKm, AKm, AKstd, AKstd_cld, & 25 | AKm_rcm, AKm_rcc, lh_rcm_avg ) 26 | ! Description: 27 | ! This subroutine computes microphysical grid box averages of the 28 | ! Kessler autoconversion scheme, using both Latin hypercube sampling 29 | ! and analytic integration, given a Latin Hypercube sample. 30 | ! References: 31 | ! None 32 | !------------------------------------------------------------------------ 33 | 34 | use constants_clubb, only: & 35 | pi, & ! Variables(s) 36 | chi_tol, & 37 | zero_threshold, & 38 | zero, & 39 | g_per_kg, & 40 | one 41 | 42 | use pdf_parameter_module, only: & 43 | pdf_parameter ! Type 44 | 45 | use clubb_precision, only: & 46 | core_rknd 47 | 48 | implicit none 49 | 50 | ! Input Variables 51 | 52 | integer, intent(in) :: & 53 | nz, & ! Number of vertical levels 54 | num_samples, & ! Number of sample points 55 | pdf_dim ! Number of variates 56 | 57 | real( kind = core_rknd ), dimension(nz,num_samples,pdf_dim), intent(in) :: & 58 | X_nl_all_levs ! Sample that is transformed ultimately to normal-lognormal 59 | 60 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 61 | cloud_frac ! Cloud fraction [-] 62 | 63 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 64 | rcm ! Liquid water mixing ratio [kg/kg] 65 | 66 | type(pdf_parameter), intent(in) :: & 67 | pdf_params ! PDF parameters [units vary] 68 | 69 | integer, dimension(nz,num_samples), intent(in) :: & 70 | X_mixt_comp_all_levs ! Whether we're in mixture component 1 or 2 71 | 72 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 73 | lh_sample_point_weights ! Weight for cloud weighted sampling 74 | 75 | logical, intent(in) :: & 76 | l_lh_importance_sampling ! Do importance sampling (SILHS) [-] 77 | 78 | real( kind = core_rknd ), dimension(nz), intent(out) :: & 79 | lh_AKm, & ! Monte Carlo estimate of Kessler autoconversion [kg/kg/s] 80 | AKm, & ! Exact Kessler autoconversion, AKm, [kg/kg/s] 81 | AKstd, & ! Exact standard deviation of gba Kessler [kg/kg/s] 82 | AKstd_cld, & ! Exact w/in cloud std of gba Kessler [kg/kg/s] 83 | AKm_rcm, & ! Exact local gba Kessler auto based on rcm [kg/kg/s] 84 | AKm_rcc ! Exact local gba Kessler based on w/in cloud rc [kg/kg/s] 85 | 86 | ! For comparison, estimate kth liquid water using Monte Carlo 87 | real( kind = core_rknd ), dimension(nz), intent(out) :: & 88 | lh_rcm_avg ! LH estimate of grid box avg liquid water [kg/kg] 89 | 90 | ! Local Variables 91 | 92 | ! Level on which calculations are occuring 93 | integer :: level 94 | 95 | ! PDF parameters 96 | real( kind = core_rknd ) :: mixt_frac 97 | ! real( kind = core_rknd ) :: w1, w2 98 | ! real( kind = core_rknd ) :: sw1, sw2 99 | ! real( kind = core_rknd ) :: thl1, thl2, sthl1, sthl2 100 | ! real( kind = core_rknd ) :: rt1,rt2 101 | ! real( kind = core_rknd ) :: srt1, srt2 102 | real( kind = core_rknd ) :: stdev_chi_1, stdev_chi_2, chi_1, chi_2 103 | real( kind = core_rknd ) :: cloud_frac_1, cloud_frac_2 104 | ! real( kind = core_rknd ) :: rc1, rc2 105 | 106 | ! Cloud fraction 0 one .or. mixt_frac < zero ) then 355 | write(fstderr,*) 'Error in calc_estimate: ', & 356 | 'mixture fraction, mixt_frac, does not lie in [0,1].' 357 | write(fstderr,*) 'mixt_frac = ', mixt_frac 358 | stop 359 | end if 360 | if ( cloud_frac_1 > one .or. cloud_frac_1 < zero ) then 361 | write(fstderr,*) 'Error in calc_estimate: ', & 362 | 'cloud fraction 1, cloud_frac_1, does not lie in [0,1].' 363 | write(fstderr,*) 'cloud_frac_1 = ', cloud_frac_1 364 | stop 365 | end if 366 | if ( cloud_frac_2 > one .or. cloud_frac_2 < zero ) then 367 | write(fstderr,*) 'Error in calc_estimate: ', & 368 | 'cloud fraction 2, cloud_frac_2, does not lie in [0,1].' 369 | write(fstderr,*) 'cloud_frac_2 = ', cloud_frac_2 370 | stop 371 | end if 372 | 373 | ! Initialize autoconversion in each mixture component 374 | est_m1 = zero 375 | est_m2 = zero 376 | 377 | ! Initialize numbers of sample points corresponding 378 | ! to each mixture component 379 | n1 = 0 380 | n2 = 0 381 | 382 | do sample = 1, num_samples 383 | 384 | ! Choose which mixture fraction we are in. 385 | ! Account for cloud fraction. 386 | ! Follow M. E. Johnson (1987), p. 56. 387 | ! fraction_1 = mixt_frac*cloud_frac_1 / & 388 | ! max( mixt_frac*cloud_frac_1+(1-mixt_frac)*cloud_frac_2, epsilon( mixt_frac ) ) 389 | ! print*, 'fraction_1= ', fraction_1 390 | 391 | ! V. Larson change to try to fix sampling 392 | ! if ( in_mixt_frac_1( X_u_one_lev(sample,pdf_dim+1), fraction_1 ) ) then 393 | ! print*, '-1+2*int((sample+1)/2)= ', -1+2*int((sample+1)/2) 394 | ! print*, '-1+2*int((sample+1)/2)= ', int(sample) 395 | if ( X_mixt_comp_one_lev(sample) == 1 ) then 396 | ! End of V. Larson fix 397 | 398 | ! Use an idealized formula to compute autoconversion 399 | ! in mixture comp. 1 400 | ! A_K = (1e-3/s)*(rc-0.5g/kg)*H(rc-0.5g/kg) 401 | ! This is the first of two lines where 402 | ! a user must add a new microphysics scheme. 403 | if ( l_lh_importance_sampling ) then 404 | est_m1 = est_m1 + coeff*max(zero,rc(sample)-r_crit)& 405 | * lh_sample_point_weights(sample) 406 | else 407 | est_m1 = est_m1 + coeff*max(zero,rc(sample)-r_crit) 408 | end if 409 | n1 = n1 + 1 410 | else 411 | ! Use an idealized formula to compute autoconversion 412 | ! in mixture comp. 2 413 | ! A_K = (1e-3/s)*(rc-0.5g/kg)*H(rc-0.5g/kg) 414 | ! This is the second and last line where 415 | ! a user must add a new microphysics scheme. 416 | 417 | if ( l_lh_importance_sampling ) then 418 | est_m2 = est_m2 + coeff*max(zero,rc(sample)-r_crit) & 419 | * lh_sample_point_weights(sample) 420 | else 421 | est_m2 = est_m2 + coeff*max(zero,rc(sample)-r_crit) 422 | end if 423 | 424 | n2 = n2 + 1 425 | end if 426 | 427 | ! Loop to get new sample 428 | end do ! sample = 1, num_samples 429 | 430 | !! Convert sums to averages. 431 | !! Old code that underestimates if a plume has no sample points 432 | ! if (n1 .eq. 0) then 433 | ! ac_m1 = 0._core_rknd 434 | ! else 435 | ! ac_m1 = ac_m1/n1 436 | ! end if 437 | 438 | ! if (n2 .eq. 0) then 439 | ! ac_m2 = 0._core_rknd 440 | ! else 441 | ! ac_m2 = ac_m2/n2 442 | ! end if 443 | 444 | if ( n1 == 0 .and. n2 == 0 ) then 445 | stop 'Error: no sample points in calc_estimate' 446 | end if 447 | 448 | if ( l_cloud_weighted_averaging ) then 449 | ! Convert sums to averages. 450 | ! If we have no sample points for a certain plume, 451 | ! then we estimate the plume liquid water by the 452 | ! other plume's value. 453 | if ( .not. (n1 == 0) ) then 454 | est_m1 = est_m1/ real( n1, kind=core_rknd ) 455 | end if 456 | 457 | if ( .not. (n2 == 0) ) then 458 | est_m2 = est_m2/ real( n2, kind=core_rknd ) 459 | end if 460 | 461 | if ( n1 == 0 ) then 462 | est_m1 = est_m2 463 | end if 464 | 465 | if ( n2 == 0 ) then 466 | est_m2 = est_m1 467 | end if 468 | 469 | ! Grid box average. 470 | est_m = mixt_frac*cloud_frac_1*est_m1 + (one-mixt_frac)*cloud_frac_2*est_m2 471 | 472 | else 473 | est_m = ( est_m1 + est_m2 ) / real( num_samples, kind=core_rknd ) 474 | 475 | end if 476 | 477 | ! print*, 'autoconv_estimate: acm=', ac_m 478 | 479 | return 480 | end subroutine calc_estimate 481 | !--------------------------------------------------------------- 482 | 483 | end module est_kessler_microphys_module 484 | -------------------------------------------------------------------------------- /transform_to_pdf_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | module transform_to_pdf_module 5 | 6 | implicit none 7 | 8 | public :: ltqnorm, multiply_Cholesky, transform_uniform_samples_to_pdf, chi_eta_2_rtthl 9 | 10 | private ! Default scope 11 | 12 | contains 13 | 14 | !------------------------------------------------------------------------------- 15 | subroutine transform_uniform_samples_to_pdf & 16 | ( nz, num_samples, pdf_dim, d_uniform_extra, & ! In 17 | Sigma_Cholesky1, Sigma_Cholesky2, & ! In 18 | mu1, mu2, X_mixt_comp_all_levs, & ! In 19 | X_u_all_levs, cloud_frac, & ! In 20 | l_in_precip_all_levs, & ! In 21 | X_nl_all_levs ) ! Out 22 | ! Description: 23 | ! This subroutine transforms a uniform sample to a sample from CLUBB's PDF. 24 | 25 | ! References: 26 | ! https://arxiv.org/pdf/1711.03675v1.pdf#nameddest=url:uniform2pdf 27 | ! 28 | ! ``Supplying Local Microphysical Parameterizations with Information about 29 | ! Subgrid Variability: Latin Hypercube Sampling'', JAS Vol. 62, 30 | ! p. 4010--4026, Larson, et al. 2005 31 | !------------------------------------------------------------------------------- 32 | 33 | use array_index, only: & 34 | iiPDF_chi, & ! Variable(s) 35 | iiPDF_eta, & 36 | iiPDF_w 37 | 38 | use constants_clubb, only: & 39 | one, & 40 | zero 41 | 42 | use clubb_precision, only: & 43 | core_rknd 44 | 45 | use array_index, only: & 46 | iiPDF_Ncn ! Variable 47 | 48 | implicit none 49 | 50 | ! External 51 | intrinsic :: max 52 | 53 | ! Input Variables 54 | integer, intent(in) :: & 55 | nz, & ! Number of vertical grid levels 56 | num_samples, & ! Number of subcolumn samples 57 | pdf_dim, & ! `d' Number of variates (normally 3 + microphysics specific variables) 58 | d_uniform_extra ! Number of variates included in uniform sample only (often 2) 59 | 60 | real( kind = core_rknd ), dimension(pdf_dim,pdf_dim,nz), intent(in) :: & 61 | Sigma_Cholesky1, & ! Correlations Cholesky matrix, 1st component [-] 62 | Sigma_Cholesky2 ! Correlations Cholesky matrix, 2nd component [-] 63 | 64 | real( kind = core_rknd ), dimension(pdf_dim,nz), intent(in) :: & 65 | mu1, & ! Means of the hydrometeors,(chi, eta, w, ), 1st component [units vary] 66 | mu2 ! Means of the hydrometeors,(chi, eta, w, ), 2nd component [units vary] 67 | 68 | real( kind = core_rknd ), intent(in), dimension(nz,num_samples,pdf_dim+d_uniform_extra) :: & 69 | X_u_all_levs ! Sample drawn from uniform distribution from a particular grid level 70 | 71 | real( kind = core_rknd ), intent(in), dimension(nz,num_samples) :: & 72 | cloud_frac ! Cloud fraction [-] 73 | 74 | logical, intent(in), dimension(nz,num_samples) :: & 75 | l_in_precip_all_levs ! Whether we are in precipitation (T/F) 76 | 77 | integer, dimension(nz,num_samples), intent(in) :: & 78 | X_mixt_comp_all_levs ! Whether we're in the first or second mixture component 79 | 80 | ! Output Variable 81 | 82 | real( kind = core_rknd ), intent(out), dimension(nz,num_samples,pdf_dim) :: & 83 | X_nl_all_levs ! Sample that is transformed ultimately to normal-lognormal 84 | 85 | ! Local Variables 86 | 87 | logical, dimension(pdf_dim) :: & 88 | l_d_variable_lognormal ! Whether a given variable in X_nl has a lognormal dist. 89 | 90 | integer :: i, k, sample 91 | 92 | real( kind = core_rknd ), dimension(nz,num_samples,pdf_dim) :: & 93 | std_normal ! vector of d-variate standard normal distribution [-] 94 | 95 | ! Flag to clip sample point values of chi in extreme situations. 96 | logical, parameter :: & 97 | l_clip_extreme_chi_sample_pts = .true. 98 | 99 | ! ---- Begin Code ---- 100 | 101 | ! Determine which variables are a lognormal distribution 102 | i = max( iiPDF_chi, iiPDF_eta, iiPDF_w ) 103 | l_d_variable_lognormal(1:i) = .false. ! The 1st 3 variates 104 | l_d_variable_lognormal(i+1:pdf_dim) = .true. ! Hydrometeors 105 | 106 | !--------------------------------------------------------------------------- 107 | ! Generate a set of sample points for a microphysics/radiation scheme 108 | !--------------------------------------------------------------------------- 109 | 110 | !$acc data create(std_normal) async(1) 111 | 112 | ! From Latin hypercube sample, generate standard normal sample 113 | call cdfnorminv( pdf_dim, nz, num_samples, X_u_all_levs, & ! In 114 | std_normal ) ! Out 115 | 116 | ! Computes the nonstd_normal from the Cholesky factorization of Sigma, std_normal, and mu. 117 | call multiply_Cholesky( nz, num_samples, pdf_dim, std_normal, & ! In 118 | Sigma_Cholesky1, Sigma_Cholesky2, & ! In 119 | mu1, mu2, X_mixt_comp_all_levs, & ! In 120 | X_nl_all_levs ) ! Out 121 | !$acc end data 122 | 123 | !$acc kernels default(present) async(1) 124 | 125 | ! Convert lognormal variates (e.g. Ncn and rr) to lognormal 126 | do i = max( iiPDF_chi, iiPDF_eta, iiPDF_w )+1, pdf_dim 127 | do sample = 1, num_samples 128 | do k = 1, nz 129 | ! Convert lognormal variates (e.g. Ncn and rr) to lognormal 130 | X_nl_all_levs(k,sample,i) = exp( X_nl_all_levs(k,sample,i) ) 131 | end do 132 | end do 133 | end do 134 | 135 | ! Zero precipitation hydrometeors if not in precipitation 136 | do sample = 1, num_samples 137 | do k = 1, nz 138 | 139 | ! Zero precipitation hydrometeors if not in precipitation 140 | if ( .not. l_in_precip_all_levs(k,sample) ) then 141 | 142 | X_nl_all_levs(k,sample,iiPDF_Ncn+1:pdf_dim) = zero 143 | 144 | end if 145 | 146 | end do 147 | end do 148 | 149 | ! Clip extreme sample point values of chi, when necessary. 150 | ! The values of PDF component cloud fraction have been clipped within PDF 151 | ! closure under extreme conditions. This code forces the sample point 152 | ! values of chi to be saturated or unsaturated to match the condition 153 | ! enforced by the clipping of PDF component cloud fraction. 154 | if ( l_clip_extreme_chi_sample_pts ) then 155 | 156 | do sample = 1, num_samples 157 | do k = 1, nz 158 | 159 | if ( cloud_frac(k,sample) < epsilon( cloud_frac(k,sample) ) ) then 160 | 161 | ! Cloud fraction in the 1st PDF component is 0. 162 | ! All sample point values of chi must be <= 0. 163 | ! Clip the sample point value of chi back to 0. 164 | X_nl_all_levs(k,sample,iiPDF_chi) = min( X_nl_all_levs(k,sample,iiPDF_chi), zero ) 165 | 166 | elseif ( cloud_frac(k,sample) > ( one - epsilon( cloud_frac(k,sample) ) ) ) then 167 | 168 | ! Cloud fraction in the 1st PDF component is 1. 169 | ! All sample point values of chi must be > 0. 170 | ! Clip the sample point value of chi to epsilon. 171 | X_nl_all_levs(k,sample,iiPDF_chi) = max( X_nl_all_levs(k,sample,iiPDF_chi), & 172 | epsilon( zero ) ) 173 | 174 | endif ! cloud_frac_1 175 | 176 | end do 177 | end do 178 | 179 | endif ! l_clip_extreme_chi_sample_pts 180 | 181 | !$acc end kernels 182 | 183 | return 184 | end subroutine transform_uniform_samples_to_pdf 185 | 186 | !----------------------------------------------------------------------- 187 | subroutine cdfnorminv( pdf_dim, nz, num_samples, X_u_all_levs, & 188 | std_normal ) 189 | ! Description: 190 | ! This function computes the inverse of the cumulative normal distribution function. 191 | ! The return value is the lower tail quantile for the standard normal distribution. 192 | ! This is equivalent to SQRT(2) * ERFINV(2*P-1), but is designed for computational 193 | ! efficiency on GPUs, however it also has a signficant performance boost when run 194 | ! on CPUs compared to the previously used ltqnorm. The GPU based performance mainly 195 | ! comes from the reduction of the chance for warp divergence. 196 | ! 197 | ! THIS FUNCTION ONLY HAS SINGLE PRECISION ACCURACY, BUT ACCEPTS DOUBLE PRECISION ARGUMENTS 198 | ! 199 | ! References: 200 | ! This algorithm was designed based on the source code provided in 201 | ! M.B. Giles (2010) "Approximating the erfinv function" 202 | ! https://people.maths.ox.ac.uk/gilesm/files/gems_erfinv.pdf 203 | !----------------------------------------------------------------------- 204 | 205 | use clubb_precision, only: & 206 | core_rknd 207 | 208 | use constants_clubb, only: & 209 | one, & ! Constants 210 | two, & 211 | sqrt_2 212 | 213 | implicit none 214 | 215 | ! ---------------- Input Variable(s) ---------------- 216 | 217 | integer, intent(in) :: & 218 | nz, & ! Number of vertical grid levels 219 | num_samples, & ! Number of subcolumn samples 220 | pdf_dim ! `d' Number of variates (normally 3 + microphysics specific variables) 221 | 222 | real( kind = core_rknd ), intent(in), dimension(nz,num_samples,pdf_dim) :: X_u_all_levs 223 | 224 | ! ---------------- Return Variable ---------------- 225 | 226 | real( kind = core_rknd ), intent(out), dimension(nz,num_samples,pdf_dim) :: std_normal 227 | 228 | ! ---------------- Local Variable(s) ---------------- 229 | 230 | ! Polynomial coefficients 231 | real( kind = core_rknd ), dimension(9), parameter :: & 232 | a = (/ 2.81022636e-8, 3.43273939e-7, -3.5233877e-6, -4.39150654e-6, 0.00021858087, & 233 | -0.00125372503, -0.00417768164, 0.246640727, 1.50140941 /) 234 | 235 | ! Polynomial coefficients 236 | real( kind = core_rknd ), dimension(9), parameter :: & 237 | b = (/ -0.000200214257,0.000100950558,0.00134934322,-0.00367342844,0.00573950773,& 238 | -0.0076224613,0.00943887047,1.00167406,2.83297682 /) 239 | 240 | real( kind = core_rknd ) :: w, x 241 | 242 | integer :: & 243 | i, sample, k ! Loop variables 244 | 245 | ! ---------------- Begin Code ---------------- 246 | 247 | !$acc parallel loop collapse(3) async(1) 248 | do i = 1, pdf_dim 249 | do sample = 1, num_samples 250 | do k = 1, nz 251 | 252 | x = two * X_u_all_levs(k,sample,i) - one 253 | 254 | w = -log( ( one - x ) * ( one + x ) ) 255 | 256 | if ( w < 5.0 ) then 257 | w = w - 2.5_core_rknd 258 | std_normal(k,sample,i) = sqrt_2 * x & 259 | * (((((((( a(1) * w + a(2) ) * w + a(3) ) * w + a(4) ) * w & 260 | + a(5) ) * w + a(6) ) * w + a(7) ) * w + a(8) ) * w + a(9) ) 261 | else 262 | w = sqrt(w) - 3._core_rknd 263 | std_normal(k,sample,i) = sqrt_2 * x & 264 | * (((((((( b(1) * w + b(2) ) * w + b(3) ) * w + b(4) ) * w & 265 | + b(5) ) * w + b(6) ) * w + b(7) ) * w + b(8) ) * w + b(9) ) 266 | end if 267 | 268 | end do 269 | end do 270 | end do 271 | 272 | end subroutine cdfnorminv 273 | 274 | !----------------------------------------------------------------------- 275 | function ltqnorm( p_core_rknd ) 276 | ! Description: 277 | ! This function is ported to Fortran from the same function written in Matlab, 278 | ! see the following description of this function. Hongli Jiang, 2/17/2004 279 | ! Converted to double precision by Vince Larson 2/22/2004; 280 | ! this improves results for input values of p near 1. 281 | 282 | ! LTQNORM Lower tail quantile for standard normal distribution. 283 | ! 284 | ! Z = LTQNORM(P) returns the lower tail quantile for the standard normal 285 | ! distribution function. I.e., it returns the Z satisfying Pr{X < Z} = P, 286 | ! where X has a standard normal distribution. 287 | ! 288 | ! LTQNORM(P) is the same as SQRT(2) * ERFINV(2*P-1), but the former returns a 289 | ! more accurate value when P is close to zero. 290 | 291 | ! The algorithm uses a minimax approximation by rational functions and the 292 | ! result has a relative error less than 1.15e-9. A last refinement by 293 | ! Halley's rational method is applied to achieve full machine precision. 294 | 295 | ! Author: Peter J. Acklam 296 | ! Time-stamp: 2003-04-23 08:26:51 +0200 297 | ! E-mail: pjacklam@online.no 298 | ! URL: http://home.online.no/~pjacklam 299 | !----------------------------------------------------------------------- 300 | 301 | use clubb_precision, only: & 302 | core_rknd, & ! Constant(s) 303 | dp ! double precision 304 | 305 | use constants_clubb, only: & 306 | sqrt_2_dp, & ! Constant(s) 307 | sqrt_2pi_dp, & 308 | two_dp, & 309 | one_dp, & 310 | one_half_dp 311 | 312 | #ifdef CLUBB_CAM 313 | ! Some compilers cannot handle 1.0/0.0, so in CAM we import their 314 | ! +Inf and -Inf constants. We REALLY should find a better way to 315 | ! do this. 316 | ! Eric Raut, 24 Feb 2016 317 | use shr_infnan_mod, only: & 318 | nan => shr_infnan_nan, & 319 | infp => shr_infnan_posinf, & 320 | infn => shr_infnan_neginf, & 321 | assignment(=) 322 | #endif 323 | 324 | implicit none 325 | 326 | ! External 327 | 328 | intrinsic :: log, sqrt, exp 329 | 330 | ! Constant Parameter 331 | 332 | ! Apply Halley's method to answer to achieve more accurate result 333 | logical, parameter :: & 334 | l_apply_halley_method = .true. 335 | 336 | ! Input Variable(s) 337 | 338 | real( kind = core_rknd ), intent(in) :: p_core_rknd 339 | 340 | ! Return Variable 341 | 342 | real( kind = core_rknd ) :: ltqnorm 343 | 344 | ! Local Variable(s) 345 | real( kind = dp ) :: p 346 | 347 | real( kind = dp ) a1, a2, a3, a4, a5, a6, b1, b2, b3, b4, b5, & 348 | c1, c2, c3, c4, c5, c6, d1, d2, d3, d4 349 | 350 | real( kind = dp ) q, r, z, z1, plow, phigh 351 | 352 | real( kind = dp ) :: e, u 353 | 354 | ! Coefficients in rational approximations. 355 | ! equivalent: a(1)=a1, a(2)=a2, and etc, when a(1) is in Matlab. 356 | ! Similarly for b, c, and d's 357 | parameter (a1 = -3.969683028665376E+01_dp, & 358 | a2 = 2.209460984245205E+02_dp, & 359 | a3 = -2.759285104469687E+02_dp, & 360 | a4 = 1.383577518672690E+02_dp, & 361 | a5 = -3.066479806614716E+01_dp, & 362 | a6 = 2.506628277459239E+00_dp) 363 | parameter (b1 = -5.447609879822406E+01_dp, & 364 | b2 = 1.615858368580409E+02_dp, & 365 | b3 = -1.556989798598866E+02_dp, & 366 | b4 = 6.680131188771972E+01_dp, & 367 | b5 = -1.328068155288572E+01_dp) 368 | parameter (c1 = -7.784894002430293E-03_dp, & 369 | c2 = -3.223964580411365E-01_dp, & 370 | c3 = -2.400758277161838E+00_dp, & 371 | c4 = -2.549732539343734E+00_dp, & 372 | c5 = 4.374664141464968E+00_dp, & 373 | c6 = 2.938163982698783E+00_dp) 374 | parameter (d1 = 7.784695709041462E-03_dp, & 375 | d2 = 3.224671290700398E-01_dp, & 376 | d3 = 2.445134137142996E+00_dp, & 377 | d4 = 3.754408661907416E+00_dp) 378 | 379 | p = real( p_core_rknd, kind=dp ) 380 | 381 | ! Default initialization 382 | z = 0.0_dp 383 | 384 | ! Define break-points. 385 | plow = 0.02425_dp 386 | phigh = 1._dp - plow 387 | 388 | ! Initialize output array. Don't need this in Fortran 389 | ! z = zeros(size(p)); 390 | 391 | ! Rational approximation for lower region: 392 | if (p > 0._dp .and. p < plow) then 393 | q = sqrt( -2._dp * log( p ) ) 394 | z = (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6)/ & 395 | ((((d1*q+d2)*q+d3)*q+d4)*q+1._dp) 396 | ! Rational approximation for central region: 397 | else if (p >= plow .and. p <= phigh) then 398 | q = p - 0.5_dp 399 | r = q * q 400 | z = (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q & 401 | /(((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1._dp) 402 | ! Rational approximation for upper region: 403 | else if (p > phigh .and. p < 1._dp) then 404 | q = sqrt( -2._dp * log(1._dp - p) ) 405 | z = -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) & 406 | /((((d1*q+d2)*q+d3)*q+d4)*q+1._dp) 407 | end if 408 | 409 | ! Eric Raut note: In CAM, we use CAM's predefined infinity and nan 410 | ! constants to avoid dividing by zero. We don't have similar constants 411 | ! in CLUBB or SILHS "cores", so we have to divide by zero. We should 412 | ! fix this. --24 Feb 2016 413 | #ifdef CLUBB_CAM 414 | ! Case when P = 1:, z=+inf 415 | if(p == 1._dp)then 416 | z = infp 417 | end if 418 | 419 | ! Case when P = 0: z = -inf 420 | if (p == 0._dp) then 421 | z = infn 422 | end if 423 | 424 | ! Cases when output will be NaN: 425 | ! k = p < 0 | p > 1 | isnan(p); 426 | if (p < 0._dp .or. p > 1._dp) then 427 | z = nan 428 | end if 429 | #else 430 | ! Case when P = 0: z = -inf, to create inf z =-1.0. 431 | ! to create NaN's inf*inf. 432 | z1 = 0._dp 433 | if (p == 0._dp) then 434 | z = (-1._dp)/z1 435 | end if 436 | 437 | ! Case when P = 1:, z=inf 438 | if(p == 1._dp)then 439 | z = 1._dp/z1 440 | end if 441 | 442 | ! Cases when output will be NaN: 443 | ! k = p < 0 | p > 1 | isnan(p); 444 | ! usually inf*inf --> NaN's. 445 | if (p < 0._dp .or. p > 1._dp) then 446 | z = (1._dp/z1)**2 447 | end if 448 | #endif 449 | 450 | ! The relative error of the approximation has absolute value less 451 | ! than 1.15e-9. One iteration of Halley's rational method (third 452 | ! order) gives full machine precision. 453 | ! V. Larson 20Feb04: Don't use the following if-end if loop. 454 | ! The value of e is very different than what MATLAB produces, 455 | ! possibly because of 456 | ! poor values of erf from Numerical Recipes. 457 | ! The value is close to MATLAB's 458 | ! if I omit the following if-end if loop. 459 | ! End V. Larson comment 460 | 461 | ! Halley's rational method is applied to achieve a more accurate result if 462 | ! the flag below is true. In tests, this did increase the runtime of SILHS 463 | ! slightly but did improve results. 464 | ! Eric Raut 23Aug14 465 | if ( l_apply_halley_method ) then 466 | e = one_half_dp * erfc(-z/sqrt_2_dp) - p 467 | u = e * sqrt_2pi_dp * exp( (z**2) / two_dp ) 468 | z = z - u / ( one_dp + z*u/two_dp ) 469 | end if 470 | 471 | ! return z as double precision: 472 | ltqnorm = real( z, kind=core_rknd ) 473 | 474 | return 475 | end function ltqnorm 476 | 477 | !------------------------------------------------------------------------------- 478 | subroutine multiply_Cholesky( nz, num_samples, pdf_dim, std_normal, & 479 | Sigma_Cholesky1, Sigma_Cholesky2, & 480 | mu1, mu2, X_mixt_comp_all_levs, & 481 | X_nl_all_levs ) 482 | ! Description: 483 | ! Computes X_nl_all_levs from the Cholesky factorization of Sigma, 484 | ! std_normal, and mu. 485 | ! X_nl_all_levs = Sigma_Cholesky * std_normal + mu. 486 | 487 | ! References: 488 | ! M. E. Johnson (1987), ``Multivariate Normal and Related Distributions'' p50-55 489 | !------------------------------------------------------------------------------- 490 | 491 | use clubb_precision, only: & 492 | core_rknd 493 | 494 | implicit none 495 | 496 | ! Input Variables 497 | integer, intent(in) :: & 498 | nz, & ! Number of vertical grid levels 499 | num_samples, & ! Number of samples 500 | pdf_dim ! Number of variates (normally=5) 501 | 502 | real( kind = core_rknd ), intent(in), dimension(nz,num_samples,pdf_dim) :: & 503 | std_normal ! vector of d-variate standard normal distribution [-] 504 | 505 | real( kind = core_rknd ), intent(in), dimension(pdf_dim,nz) :: & 506 | mu1, & ! d-dimensional column vector of means of Gaussian, 1st component [units vary] 507 | mu2 ! d-dimensional column vector of means of Gaussian, 2nd component [units vary] 508 | 509 | real( kind = core_rknd ), intent(in), dimension(pdf_dim,pdf_dim,nz) :: & 510 | Sigma_Cholesky1, & ! Cholesky factorization of the Sigma matrix, 1st component [units vary] 511 | Sigma_Cholesky2 ! Cholesky factorization of the Sigma matrix, 2nd component [units vary] 512 | 513 | integer, dimension(nz,num_samples), intent(in) :: & 514 | X_mixt_comp_all_levs ! Whether we're in the first or second mixture component 515 | 516 | ! Output Variables 517 | 518 | ! nxd matrix of n samples from d-variate normal distribution 519 | ! with mean mu and covariance structure Sigma 520 | real( kind = core_rknd ), intent(out), dimension(nz,num_samples,pdf_dim) :: & 521 | X_nl_all_levs 522 | 523 | ! Local Variables 524 | real( kind = core_rknd ) :: X_nl_k_sample_i_tmp 525 | 526 | ! Loop iterators 527 | integer :: i, j, k, sample 528 | 529 | ! --- Begin Code --- 530 | 531 | !$acc data copyin(Sigma_Cholesky1, Sigma_Cholesky2, mu1, mu2) async(2) 532 | 533 | !$acc parallel loop collapse(3) default(present) async(1) wait(2) 534 | do sample = 1, num_samples 535 | do k = 1, nz 536 | do i = 1, pdf_dim 537 | 538 | X_nl_k_sample_i_tmp = 0.0_core_rknd 539 | 540 | do j = 1, i 541 | ! Compute Sigma_Cholesky * std_normal 542 | if ( X_mixt_comp_all_levs(k,sample) == 1 ) then 543 | X_nl_k_sample_i_tmp = X_nl_k_sample_i_tmp & 544 | + Sigma_Cholesky1(i,j,k) * std_normal(k,sample,j) 545 | else 546 | X_nl_k_sample_i_tmp = X_nl_k_sample_i_tmp & 547 | + Sigma_Cholesky2(i,j,k) * std_normal(k,sample,j) 548 | end if 549 | end do 550 | 551 | if ( X_mixt_comp_all_levs(k,sample) == 1 ) then 552 | X_nl_all_levs(k,sample,i) = X_nl_k_sample_i_tmp + mu1(i,k) 553 | else 554 | X_nl_all_levs(k,sample,i) = X_nl_k_sample_i_tmp + mu2(i,k) 555 | end if 556 | 557 | end do 558 | end do 559 | end do 560 | 561 | !$acc end data 562 | 563 | return 564 | end subroutine multiply_Cholesky 565 | !----------------------------------------------------------------------- 566 | subroutine chi_eta_2_rtthl( nz, num_samples, & 567 | rt_1, thl_1, & 568 | rt_2, thl_2, & 569 | crt_1, cthl_1, & 570 | crt_2, cthl_2, & 571 | mu_chi_1, mu_chi_2, & 572 | chi, eta, & 573 | X_mixt_comp_all_levs, & 574 | lh_rt, lh_thl ) 575 | ! Description: 576 | ! Converts from chi(s), eta(t) variables to rt, thl. Also sets a limit on the value 577 | ! of cthl_1 and cthl_2 to prevent extreme values of temperature. 578 | ! 579 | ! References: 580 | ! None 581 | !----------------------------------------------------------------------- 582 | 583 | use clubb_precision, only: & 584 | core_rknd ! double precision 585 | 586 | implicit none 587 | 588 | ! External 589 | 590 | intrinsic :: max, real 591 | 592 | ! Constant Parameters 593 | 594 | real(kind = core_rknd), parameter :: & 595 | thl_dev_lim = 5.0_core_rknd ! Max deviation from mean thetal [K] 596 | 597 | ! ------------------- Input Variables ------------------- 598 | 599 | integer, intent(in) :: & 600 | nz, & ! Vertical grid levels 601 | num_samples ! Number of subcolumn samples 602 | 603 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 604 | rt_1, rt_2, & ! n dimensional column vector of rt [kg/kg] 605 | thl_1, thl_2, & ! n dimensional column vector of thetal [K] 606 | crt_1, crt_2, & ! Constants from plumes 1 & 2 of rt 607 | cthl_1, cthl_2 ! Constants from plumes 1 & 2 of thetal 608 | 609 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 610 | mu_chi_1, mu_chi_2 ! Mean for chi_1 and chi_2 [kg/kg] 611 | 612 | ! n-dimensional column vector of Mellor's chi(s) and eta(t), including mean and perturbation 613 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 614 | chi, & ! [kg/kg] 615 | eta ! [-] 616 | 617 | integer, dimension(nz,num_samples), intent(in) :: & 618 | X_mixt_comp_all_levs ! Whether we're in the first or second mixture component 619 | 620 | ! ------------------- Output variables ------------------- 621 | 622 | real( kind = core_rknd ), dimension(nz,num_samples), intent(out) :: & 623 | lh_rt, lh_thl ! n-dimensional column vectors of rt and thl, including mean and perturbation 624 | 625 | ! ------------------- Local Variables ------------------- 626 | 627 | real( kind= core_rknd ) :: lh_dev_thl_lim ! Limited value of the deviation on thetal [K] 628 | 629 | integer :: k, sample ! Loop indices 630 | 631 | ! ---- Begin Code ---- 632 | 633 | !$acc data copyin( rt_1, rt_2, thl_1, thl_2, crt_1, crt_2, cthl_1, cthl_2, mu_chi_1, & 634 | !$acc& mu_chi_2, chi, eta ) & 635 | !$acc& async(2) 636 | 637 | !$acc parallel loop collapse(2) default(present) async(1) wait(2) 638 | do sample = 1, num_samples 639 | do k = 2, nz 640 | 641 | if ( X_mixt_comp_all_levs(k,sample) == 1 ) then 642 | 643 | lh_rt(k,sample) = rt_1(k) + (0.5_core_rknd/crt_1(k))*(chi(k,sample)-mu_chi_1(k)) + & 644 | (0.5_core_rknd/crt_1(k))*eta(k,sample) 645 | 646 | ! Limit the quantity that temperature can vary by (in K) 647 | lh_dev_thl_lim = (-0.5_core_rknd/cthl_1(k))*(chi(k,sample)-mu_chi_1(k)) & 648 | + (0.5_core_rknd/cthl_1(k))*eta(k,sample) 649 | 650 | lh_dev_thl_lim = max( min( lh_dev_thl_lim, thl_dev_lim ), -thl_dev_lim ) 651 | 652 | lh_thl(k,sample) = thl_1(k) + lh_dev_thl_lim 653 | 654 | else 655 | 656 | ! Mixture fraction 2 657 | lh_rt(k,sample) = rt_2(k) + (0.5_core_rknd/crt_2(k))*(chi(k,sample)-mu_chi_2(k)) + & 658 | (0.5_core_rknd/crt_2(k))*eta(k,sample) 659 | 660 | ! Limit the quantity that temperature can vary by (in K) 661 | lh_dev_thl_lim = (-0.5_core_rknd/cthl_2(k))*(chi(k,sample)-mu_chi_2(k)) & 662 | + (0.5_core_rknd/cthl_2(k))*eta(k,sample) 663 | 664 | lh_dev_thl_lim = max( min( lh_dev_thl_lim, thl_dev_lim ), -thl_dev_lim ) 665 | 666 | lh_thl(k,sample) = thl_2(k) + lh_dev_thl_lim 667 | 668 | end if 669 | 670 | end do 671 | end do 672 | 673 | !$acc end data 674 | 675 | return 676 | 677 | end subroutine chi_eta_2_rtthl 678 | 679 | end module transform_to_pdf_module 680 | -------------------------------------------------------------------------------- /silhs_api_module.F90: -------------------------------------------------------------------------------- 1 | !-------------------------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !================================================================================================== 4 | ! 5 | ! ######## ########### ### ### ### ######## ### ######### ######### 6 | ! ### ### ### ### ### ### ### ### ### ### ### ### ### 7 | ! ### ### ### ### ### ### ### ### ### ### ### 8 | ! ########## ### ### ########## ########## ########### ######### ### 9 | ! ### ### ### ### ### ### ### ### ### ### 10 | ! ### ### ### ### ### ### ### ### ### ### ### ### 11 | ! ######## ########### ########## ### ### ######## ### ### ### ######### 12 | ! 13 | ! The SILHS API serves as the doorway through which external models can interact with SILHS. 14 | ! 15 | ! PLEASE REMEMBER, IF ANY CODE IS CHANGED IN THIS DOCUMENT, 16 | ! THE CHANGES MUST BE PROPOGATED TO ALL HOST MODELS. 17 | ! 18 | ! 19 | ! Cloud Layers Unified By Binormals (CLUBB) user license 20 | ! agreement. 21 | ! 22 | ! Thank you for your interest in CLUBB. We work hard to create a 23 | ! code that implements the best software engineering practices, 24 | ! is supported to the extent allowed by our limited resources, 25 | ! and is available without cost to non-commercial users. You may 26 | ! use CLUBB if, in return, you abide by these conditions: 27 | ! 28 | ! 1. Please cite CLUBB in presentations and publications that 29 | ! contain results obtained using CLUBB. 30 | ! 31 | ! 2. You may not use any part of CLUBB to create or modify 32 | ! another single-column (1D) model that is not called CLUBB. 33 | ! However, you may modify or augment CLUBB or parts of CLUBB if 34 | ! you include "CLUBB" in the name of the resulting single-column 35 | ! model. For example, a user at MIT might modify CLUBB and call 36 | ! the modified version "CLUBB-MIT." Or, for example, a user of 37 | ! the CLM land-surface model might interface CLM to CLUBB and 38 | ! call it "CLM-CLUBB." This naming convention recognizes the 39 | ! contributions of both sets of developers. 40 | ! 41 | ! 3. You may implement CLUBB as a parameterization in a large- 42 | ! scale host model that has 2 or 3 spatial dimensions without 43 | ! including "CLUBB" in the combined model name, but please 44 | ! acknowledge in presentations and publications that CLUBB has 45 | ! been included as a parameterization. 46 | ! 47 | ! 4. You may not provide all or part of CLUBB to anyone without 48 | ! prior permission from Vincent Larson (vlarson@uwm.edu). If 49 | ! you wish to share CLUBB with your collaborators without 50 | ! seeking permission, please ask your collaborators to register 51 | ! as CLUBB users at https://carson.math.uwm.edu/larson-group/clubb_site/ and to 52 | ! download CLUBB from there. 53 | ! 54 | ! 5. You may not use CLUBB for commercial purposes unless you 55 | ! receive permission from Vincent Larson. 56 | ! 57 | ! 6. You may not re-license all or any part of CLUBB. 58 | ! 59 | ! 7. CLUBB is provided "as is" and without warranty. 60 | ! 61 | ! We hope that CLUBB will develop into a community resource. We 62 | ! encourage users to contribute their CLUBB modifications or 63 | ! extensions to the CLUBB development group. We will then 64 | ! consider them for inclusion in CLUBB. Such contributions will 65 | ! benefit all CLUBB users. We would be pleased to acknowledge 66 | ! contributors and list their CLUBB-related papers on our "About 67 | ! CLUBB" webpage (https://carson.math.uwm.edu/larson-group/clubb_site/about.html) for 68 | ! those contributors who so desire. 69 | ! 70 | ! Thanks so much and best wishes for your research! 71 | ! 72 | ! The CLUBB Development Group 73 | ! (Present and past contributors to the source code include 74 | ! Vincent Larson, Chris Golaz, David Schanen, Brian Griffin, 75 | ! Joshua Fasching, Adam Smith, and Michael Falk). 76 | !------------------------------------------------------------------ 77 | 78 | module silhs_api_module 79 | 80 | #ifdef SILHS 81 | 82 | use parameters_silhs, only: & 83 | silhs_config_flags_type ! Type 84 | 85 | #endif 86 | 87 | implicit none 88 | 89 | private 90 | 91 | #ifdef SILHS 92 | 93 | public & 94 | generate_silhs_sample_api, & 95 | stats_accumulate_lh_api, & 96 | est_kessler_microphys_api, & 97 | clip_transform_silhs_output_api, & 98 | lh_microphys_var_covar_driver_api, & 99 | silhs_config_flags_type, & 100 | set_default_silhs_config_flags_api, & 101 | initialize_silhs_config_flags_type_api, & 102 | print_silhs_config_flags_api 103 | 104 | contains 105 | 106 | !================================================================================================ 107 | ! generate_silhs_sample - Generates sample points of moisture, temperature, et cetera. 108 | !================================================================================================ 109 | 110 | subroutine generate_silhs_sample_api( & 111 | iter, pdf_dim, num_samples, sequence_length, nz, & ! In 112 | l_calc_weights_all_levs_itime, & 113 | pdf_params, delta_zm, rcm, Lscale, & ! In 114 | rho_ds_zt, mu1, mu2, sigma1, sigma2, & ! In 115 | corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! In 116 | hydromet_pdf_params, silhs_config_flags, & ! In 117 | l_uv_nudge, & ! In 118 | l_tke_aniso, & ! In 119 | l_standard_term_ta, & ! In 120 | l_single_C2_Skw, & ! In 121 | X_nl_all_levs, X_mixt_comp_all_levs, & ! Out 122 | lh_sample_point_weights ) ! Out 123 | 124 | use latin_hypercube_driver_module, only : generate_silhs_sample 125 | 126 | use pdf_parameter_module, only: & 127 | pdf_parameter ! Type 128 | 129 | use hydromet_pdf_parameter_module, only: & 130 | hydromet_pdf_parameter ! Type 131 | 132 | use parameters_silhs, only: & 133 | silhs_config_flags_type ! Type 134 | 135 | use clubb_precision, only: & 136 | core_rknd 137 | 138 | implicit none 139 | 140 | ! Input Variables 141 | integer, intent(in) :: & 142 | iter, & ! Model iteration number 143 | pdf_dim, & ! Number of variables to sample 144 | num_samples, & ! Number of samples per variable 145 | sequence_length, & ! nt_repeat/num_samples; number of timesteps before sequence repeats. 146 | nz ! Number of vertical model levels 147 | 148 | type(pdf_parameter), intent(in) :: & 149 | pdf_params ! PDF parameters [units vary] 150 | 151 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 152 | delta_zm, & ! Difference in moment. altitudes [m] 153 | rcm ! Liquid water mixing ratio [kg/kg] 154 | 155 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 156 | rho_ds_zt ! Dry, static density on thermo. levels [kg/m^3] 157 | 158 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 159 | Lscale ! Turbulent Mixing Length [m] 160 | 161 | ! Output Variables 162 | real( kind = core_rknd ), intent(out), dimension(nz,num_samples,pdf_dim) :: & 163 | X_nl_all_levs ! Sample that is transformed ultimately to normal-lognormal 164 | 165 | integer, intent(out), dimension(nz,num_samples) :: & 166 | X_mixt_comp_all_levs ! Which mixture component we're in 167 | 168 | real( kind = core_rknd ), intent(out), dimension(nz,num_samples) :: & 169 | lh_sample_point_weights 170 | 171 | ! More Input Variables! 172 | real( kind = core_rknd ), dimension(pdf_dim,pdf_dim,nz), intent(in) :: & 173 | corr_cholesky_mtx_1, & ! Correlations Cholesky matrix (1st comp.) [-] 174 | corr_cholesky_mtx_2 ! Correlations Cholesky matrix (2nd comp.) [-] 175 | 176 | real( kind = core_rknd ), dimension(pdf_dim,nz), intent(in) :: & 177 | mu1, & ! Means of the hydrometeors, 1st comp. (chi, eta, w, ) [units vary] 178 | mu2, & ! Means of the hydrometeors, 2nd comp. (chi, eta, w, ) [units vary] 179 | sigma1, & ! Stdevs of the hydrometeors, 1st comp. (chi, eta, w, ) [units vary] 180 | sigma2 ! Stdevs of the hydrometeors, 2nd comp. (chi, eta, w, ) [units vary] 181 | 182 | logical, intent(in) :: & 183 | l_calc_weights_all_levs_itime ! determines if vertically correlated sample points are needed 184 | 185 | type(hydromet_pdf_parameter), dimension(nz), intent(in) :: & 186 | hydromet_pdf_params 187 | 188 | type(silhs_config_flags_type), intent(in) :: & 189 | silhs_config_flags 190 | 191 | logical, intent(in) :: & 192 | l_uv_nudge, & ! For wind speed nudging. 193 | l_tke_aniso, & ! For anisotropic turbulent kinetic energy, i.e. 194 | ! TKE = 1/2 (u'^2 + v'^2 + w'^2) 195 | l_standard_term_ta, & ! Use the standard discretization for the turbulent advection terms. 196 | ! Setting to .false. means that a_1 and a_3 are pulled outside of the 197 | ! derivative in advance_wp2_wp3_module.F90 and in 198 | ! advance_xp2_xpyp_module.F90. 199 | l_single_C2_Skw ! Use a single Skewness dependent C2 for rtp2, thlp2, and rtpthlp 200 | 201 | call generate_silhs_sample( & 202 | iter, pdf_dim, num_samples, sequence_length, nz, & ! In 203 | l_calc_weights_all_levs_itime, & ! In 204 | pdf_params, delta_zm, rcm, Lscale, & ! In 205 | rho_ds_zt, mu1, mu2, sigma1, sigma2, & ! In 206 | corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! In 207 | hydromet_pdf_params, silhs_config_flags, & ! In 208 | l_uv_nudge, & ! In 209 | l_tke_aniso, & ! In 210 | l_standard_term_ta, & ! In 211 | l_single_C2_Skw, & ! In 212 | X_nl_all_levs, X_mixt_comp_all_levs, & ! Out 213 | lh_sample_point_weights ) ! Out 214 | 215 | end subroutine generate_silhs_sample_api 216 | 217 | !================================================================================================ 218 | ! stats_accumulate_lh - Clips subcolumns from latin hypercube and creates stats. 219 | !================================================================================================ 220 | 221 | subroutine stats_accumulate_lh_api( & 222 | nz, num_samples, pdf_dim, rho_ds_zt, & 223 | lh_sample_point_weights, X_nl_all_levs, & 224 | lh_rt_clipped, lh_thl_clipped, & 225 | lh_rc_clipped, lh_rv_clipped, & 226 | lh_Nc_clipped ) 227 | 228 | use latin_hypercube_driver_module, only : stats_accumulate_lh 229 | 230 | use clubb_precision, only: & 231 | core_rknd ! Constant 232 | 233 | implicit none 234 | 235 | ! Input Variables 236 | integer, intent(in) :: & 237 | pdf_dim, & ! Number of variables to sample 238 | num_samples, & ! Number of calls to microphysics per timestep (normally=2) 239 | nz ! Number of vertical model levels 240 | 241 | real( kind = core_rknd ), intent(in), dimension(nz) :: & 242 | rho_ds_zt ! Dry, static density (thermo. levs.) [kg/m^3] 243 | 244 | real( kind = core_rknd ), intent(in), dimension(nz,num_samples) :: & 245 | lh_sample_point_weights 246 | 247 | real( kind = core_rknd ), intent(in), dimension(nz,num_samples,pdf_dim) :: & 248 | X_nl_all_levs ! Sample that is transformed ultimately to normal-lognormal 249 | 250 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 251 | lh_rt_clipped, & ! rt generated from silhs sample points 252 | lh_thl_clipped, & ! thl generated from silhs sample points 253 | lh_rc_clipped, & ! rc generated from silhs sample points 254 | lh_rv_clipped, & ! rv generated from silhs sample points 255 | lh_Nc_clipped ! Nc generated from silhs sample points 256 | 257 | call stats_accumulate_lh( & 258 | nz, num_samples, pdf_dim, rho_ds_zt, & 259 | lh_sample_point_weights, X_nl_all_levs, & 260 | lh_rt_clipped, lh_thl_clipped, & 261 | lh_rc_clipped, lh_rv_clipped, & 262 | lh_Nc_clipped ) 263 | 264 | end subroutine stats_accumulate_lh_api 265 | 266 | !================================================================================================ 267 | ! est_kessler_microphys - Computes microphysical grid box means of Kessler autoconversion scheme. 268 | !================================================================================================ 269 | 270 | subroutine est_kessler_microphys_api( & 271 | nz, num_samples, pdf_dim, & 272 | X_nl_all_levs, pdf_params, rcm, cloud_frac, & 273 | X_mixt_comp_all_levs, lh_sample_point_weights, & 274 | l_lh_importance_sampling, & 275 | lh_AKm, AKm, AKstd, AKstd_cld, & 276 | AKm_rcm, AKm_rcc, lh_rcm_avg ) 277 | 278 | use est_kessler_microphys_module, only : est_kessler_microphys 279 | 280 | use pdf_parameter_module, only: & 281 | pdf_parameter ! Type 282 | 283 | use clubb_precision, only: & 284 | core_rknd 285 | 286 | implicit none 287 | 288 | ! Input Variables 289 | 290 | integer, intent(in) :: & 291 | nz, & ! Number of vertical levels 292 | num_samples, & ! Number of sample points 293 | pdf_dim ! Number of variates 294 | 295 | real( kind = core_rknd ), dimension(nz,num_samples,pdf_dim), intent(in) :: & 296 | X_nl_all_levs ! Sample that is transformed ultimately to normal-lognormal 297 | 298 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 299 | cloud_frac ! Cloud fraction [-] 300 | 301 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 302 | rcm ! Liquid water mixing ratio [kg/kg] 303 | 304 | type(pdf_parameter), intent(in) :: & 305 | pdf_params ! PDF parameters [units vary] 306 | 307 | integer, dimension(nz,num_samples), intent(in) :: & 308 | X_mixt_comp_all_levs ! Whether we're in mixture component 1 or 2 309 | 310 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 311 | lh_sample_point_weights ! Weight for cloud weighted sampling 312 | 313 | logical, intent(in) :: & 314 | l_lh_importance_sampling ! Do importance sampling (SILHS) [-] 315 | 316 | real( kind = core_rknd ), dimension(nz), intent(out) :: & 317 | lh_AKm, & ! Monte Carlo estimate of Kessler autoconversion [kg/kg/s] 318 | AKm, & ! Exact Kessler autoconversion, AKm, [kg/kg/s] 319 | AKstd, & ! Exact standard deviation of gba Kessler [kg/kg/s] 320 | AKstd_cld, & ! Exact w/in cloud std of gba Kessler [kg/kg/s] 321 | AKm_rcm, & ! Exact local gba Kessler auto based on rcm [kg/kg/s] 322 | AKm_rcc ! Exact local gba Kessler based on w/in cloud rc [kg/kg/s] 323 | 324 | ! For comparison, estimate kth liquid water using Monte Carlo 325 | real( kind = core_rknd ), dimension(nz), intent(out) :: & 326 | lh_rcm_avg ! lh estimate of grid box avg liquid water [kg/kg] 327 | 328 | call est_kessler_microphys( & 329 | nz, num_samples, pdf_dim, & 330 | X_nl_all_levs, pdf_params, rcm, cloud_frac, & 331 | X_mixt_comp_all_levs, lh_sample_point_weights, & 332 | l_lh_importance_sampling, & 333 | lh_AKm, AKm, AKstd, AKstd_cld, & 334 | AKm_rcm, AKm_rcc, lh_rcm_avg ) 335 | 336 | end subroutine est_kessler_microphys_api 337 | 338 | !================================================================================================ 339 | ! clip_transform_silhs_output - Computes extra SILHS sample variables, such as rt and thl. 340 | !================================================================================================ 341 | 342 | subroutine clip_transform_silhs_output_api( nz, num_samples, & ! In 343 | pdf_dim, hydromet_dim, & ! In 344 | X_mixt_comp_all_levs, & ! In 345 | X_nl_all_levs, & ! Inout 346 | pdf_params, l_use_Ncn_to_Nc, & ! In 347 | lh_rt_clipped, lh_thl_clipped, & ! Out 348 | lh_rc_clipped, lh_rv_clipped, & ! Out 349 | lh_Nc_clipped ) ! Out 350 | 351 | use latin_hypercube_driver_module, only : clip_transform_silhs_output 352 | 353 | use clubb_precision, only: & 354 | core_rknd ! Our awesome generalized precision (constant) 355 | 356 | use pdf_parameter_module, only: & 357 | pdf_parameter 358 | 359 | implicit none 360 | 361 | ! Input Variables 362 | logical, intent(in) :: l_use_Ncn_to_Nc 363 | 364 | integer, intent(in) :: & 365 | nz, & ! Number of vertical levels 366 | num_samples, & ! Number of SILHS sample points 367 | pdf_dim, & ! Number of variates in X_nl_one_lev 368 | hydromet_dim ! Number of hydrometeor species 369 | 370 | integer, dimension(nz,num_samples), intent(in) :: & 371 | X_mixt_comp_all_levs ! Which component this sample is in (1 or 2) 372 | 373 | real( kind = core_rknd ), dimension(nz,num_samples,pdf_dim), intent(inout) :: & 374 | X_nl_all_levs ! SILHS sample points [units vary] 375 | 376 | type(pdf_parameter), intent(in) :: & 377 | pdf_params ! **The** PDF parameters! 378 | 379 | ! Output Variables 380 | real( kind = core_rknd ), dimension(nz,num_samples), intent(out) :: & 381 | lh_rt_clipped, & ! rt generated from silhs sample points 382 | lh_thl_clipped, & ! thl generated from silhs sample points 383 | lh_rc_clipped, & ! rc generated from silhs sample points 384 | lh_rv_clipped, & ! rv generated from silhs sample points 385 | lh_Nc_clipped ! Nc generated from silhs sample points 386 | 387 | call clip_transform_silhs_output( nz, num_samples, & ! In 388 | pdf_dim, hydromet_dim, & ! In 389 | X_mixt_comp_all_levs, & ! In 390 | X_nl_all_levs, & ! In 391 | pdf_params, l_use_Ncn_to_Nc, & ! In 392 | lh_rt_clipped, lh_thl_clipped, & ! Out 393 | lh_rc_clipped, lh_rv_clipped, & ! Out 394 | lh_Nc_clipped ) ! Out 395 | 396 | end subroutine clip_transform_silhs_output_api 397 | 398 | !----------------------------------------------------------------- 399 | ! lh_microphys_var_covar_driver: Computes the effect of microphysics on gridbox covariances 400 | !----------------------------------------------------------------- 401 | 402 | subroutine lh_microphys_var_covar_driver_api & ! In 403 | ( nz, num_samples, dt, lh_sample_point_weights, & ! In 404 | pdf_params, lh_rt_all, lh_thl_all, lh_w_all, & ! In 405 | lh_rcm_mc_all, lh_rvm_mc_all, lh_thlm_mc_all, & ! In 406 | l_lh_instant_var_covar_src, & ! In 407 | lh_rtp2_mc_zt, lh_thlp2_mc_zt, lh_wprtp_mc_zt, & ! Out 408 | lh_wpthlp_mc_zt, lh_rtpthlp_mc_zt ) ! Out 409 | 410 | use lh_microphys_var_covar_module, only: & 411 | lh_microphys_var_covar_driver ! Procedure 412 | 413 | use clubb_precision, only: & 414 | core_rknd ! Constant 415 | 416 | use pdf_parameter_module, only: & 417 | pdf_parameter 418 | 419 | implicit none 420 | 421 | ! Input Variables! 422 | integer, intent(in) :: & 423 | nz, & ! Number of vertical levels 424 | num_samples ! Number of SILHS sample points 425 | 426 | real( kind = core_rknd ), intent(in) :: & 427 | dt ! Model time step [s] 428 | 429 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 430 | lh_sample_point_weights ! Weight of SILHS sample points 431 | 432 | real( kind = core_rknd ), dimension(nz,num_samples), intent(in) :: & 433 | lh_rt_all, & ! SILHS samples of total water [kg/kg] 434 | lh_thl_all, & ! SILHS samples of potential temperature [K] 435 | lh_w_all, & ! SILHS samples of vertical velocity [m/s] 436 | lh_rcm_mc_all, & ! SILHS microphys. tendency of rcm [kg/kg/s] 437 | lh_rvm_mc_all, & ! SILHS microphys. tendency of rvm [kg/kg/s] 438 | lh_thlm_mc_all ! SILHS microphys. tendency of thlm [K/s] 439 | 440 | logical, intent(in) :: & 441 | l_lh_instant_var_covar_src ! Produce instantaneous var/covar tendencies [-] 442 | 443 | ! Output Variables 444 | real( kind = core_rknd ), dimension(nz), intent(out) :: & 445 | lh_rtp2_mc_zt, & ! SILHS microphys. est. tendency of [(kg/kg)^2/s] 446 | lh_thlp2_mc_zt, & ! SILHS microphys. est. tendency of [K^2/s] 447 | lh_wprtp_mc_zt, & ! SILHS microphys. est. tendency of [m*(kg/kg)/s^2] 448 | lh_wpthlp_mc_zt, & ! SILHS microphys. est. tendency of [m*K/s^2] 449 | lh_rtpthlp_mc_zt ! SILHS microphys. est. tendency of [K*(kg/kg)/s] 450 | 451 | type(pdf_parameter), intent(in) :: & 452 | pdf_params ! The PDF parameters_silhs 453 | 454 | call lh_microphys_var_covar_driver & 455 | ( nz, num_samples, dt, lh_sample_point_weights, & 456 | pdf_params, lh_rt_all, lh_thl_all, lh_w_all, & 457 | lh_rcm_mc_all, lh_rvm_mc_all, lh_thlm_mc_all, & 458 | l_lh_instant_var_covar_src, & 459 | lh_rtp2_mc_zt, lh_thlp2_mc_zt, lh_wprtp_mc_zt, & 460 | lh_wpthlp_mc_zt, lh_rtpthlp_mc_zt ) 461 | 462 | end subroutine lh_microphys_var_covar_driver_api 463 | 464 | !----------------------------------------------------------------- 465 | ! set_default_silhs_config_flags: Sets all SILHS flags to a default setting 466 | !----------------------------------------------------------------- 467 | 468 | subroutine set_default_silhs_config_flags_api( cluster_allocation_strategy, & ! Out 469 | l_lh_importance_sampling, & ! Out 470 | l_Lscale_vert_avg, & ! Out 471 | l_lh_straight_mc, & ! Out 472 | l_lh_clustered_sampling, & ! Out 473 | l_rcm_in_cloud_k_lh_start, & ! Out 474 | l_random_k_lh_start, & ! Out 475 | l_max_overlap_in_cloud, & ! Out 476 | l_lh_instant_var_covar_src, & ! Out 477 | l_lh_limit_weights, & ! Out 478 | l_lh_var_frac, & ! Out 479 | l_lh_normalize_weights ) ! Out 480 | 481 | use parameters_silhs, only: & 482 | set_default_silhs_config_flags ! Procedure 483 | 484 | implicit none 485 | 486 | ! Output variables 487 | integer, intent(out) :: & 488 | cluster_allocation_strategy ! Two clusters, one containing all categories with either 489 | ! cloud or precip, and the other containing categories with 490 | ! neither 491 | 492 | logical, intent(out) :: & 493 | l_lh_importance_sampling, & ! Limit noise by performing importance sampling 494 | l_Lscale_vert_avg, & ! Calculate Lscale_vert_avg in generate_silhs_sample 495 | l_lh_straight_mc, & ! Use true Monte Carlo sampling with no Latin 496 | ! hypercube sampling and no importance sampling 497 | l_lh_clustered_sampling, & ! Use the "new" SILHS importance sampling 498 | ! scheme with prescribed probabilities 499 | l_rcm_in_cloud_k_lh_start, & ! Determine k_lh_start based on maximum within-cloud rcm 500 | l_random_k_lh_start, & ! Place k_lh_start at a random grid level between 501 | ! maximum rcm and maximum rcm_in_cloud 502 | l_max_overlap_in_cloud, & ! Assume maximum vertical overlap when grid-box rcm 503 | ! exceeds cloud threshold 504 | l_lh_instant_var_covar_src, & ! Produces "instantaneous" variance-covariance 505 | ! microphysical source terms, ignoring 506 | ! discretization effects 507 | l_lh_limit_weights, & ! Limit SILHS sample point weights for stability 508 | l_lh_var_frac, & ! Prescribe variance fractions 509 | l_lh_normalize_weights ! Scale sample point weights to sum to num_samples 510 | ! (the "ratio estimate") 511 | 512 | call set_default_silhs_config_flags( cluster_allocation_strategy, & ! Out 513 | l_lh_importance_sampling, & ! Out 514 | l_Lscale_vert_avg, & ! Out 515 | l_lh_straight_mc, & ! Out 516 | l_lh_clustered_sampling, & ! Out 517 | l_rcm_in_cloud_k_lh_start, & ! Out 518 | l_random_k_lh_start, & ! Out 519 | l_max_overlap_in_cloud, & ! Out 520 | l_lh_instant_var_covar_src, & ! Out 521 | l_lh_limit_weights, & ! Out 522 | l_lh_var_frac, & ! Out 523 | l_lh_normalize_weights ) ! Out 524 | 525 | end subroutine set_default_silhs_config_flags_api 526 | 527 | !----------------------------------------------------------------- 528 | ! initialize_silhs_config_flags_type: Initialize the silhs_config_flags_type 529 | !----------------------------------------------------------------- 530 | 531 | subroutine initialize_silhs_config_flags_type_api( cluster_allocation_strategy, & ! In 532 | l_lh_importance_sampling, & ! In 533 | l_Lscale_vert_avg, & ! In 534 | l_lh_straight_mc, & ! In 535 | l_lh_clustered_sampling, & ! In 536 | l_rcm_in_cloud_k_lh_start, & ! In 537 | l_random_k_lh_start, & ! In 538 | l_max_overlap_in_cloud, & ! In 539 | l_lh_instant_var_covar_src, & ! In 540 | l_lh_limit_weights, & ! In 541 | l_lh_var_frac, & ! In 542 | l_lh_normalize_weights, & ! In 543 | silhs_config_flags ) ! Out 544 | 545 | use parameters_silhs, only: & 546 | silhs_config_flags_type, & ! Type 547 | initialize_silhs_config_flags_type ! Procedure 548 | 549 | implicit none 550 | 551 | ! Input variables 552 | integer, intent(in) :: & 553 | cluster_allocation_strategy ! Two clusters, one containing all categories with either 554 | ! cloud or precip, and the other containing categories with 555 | ! neither 556 | 557 | logical, intent(in) :: & 558 | l_lh_importance_sampling, & ! Limit noise by performing importance sampling 559 | l_Lscale_vert_avg, & ! Calculate Lscale_vert_avg in generate_silhs_sample 560 | l_lh_straight_mc, & ! Use true Monte Carlo sampling with no Latin 561 | ! hypercube sampling and no importance sampling 562 | l_lh_clustered_sampling, & ! Use the "new" SILHS importance sampling 563 | ! scheme with prescribed probabilities 564 | l_rcm_in_cloud_k_lh_start, & ! Determine k_lh_start based on maximum within-cloud rcm 565 | l_random_k_lh_start, & ! Place k_lh_start at a random grid level between 566 | ! maximum rcm and maximum rcm_in_cloud 567 | l_max_overlap_in_cloud, & ! Assume maximum vertical overlap when grid-box rcm 568 | ! exceeds cloud threshold 569 | l_lh_instant_var_covar_src, & ! Produces "instantaneous" variance-covariance 570 | ! microphysical source terms, ignoring 571 | ! discretization effects 572 | l_lh_limit_weights, & ! Limit SILHS sample point weights for stability 573 | l_lh_var_frac, & ! Prescribe variance fractions 574 | l_lh_normalize_weights ! Scale sample point weights to sum to num_samples 575 | ! (the "ratio estimate") 576 | 577 | ! Output variables 578 | type(silhs_config_flags_type), intent(out) :: & 579 | silhs_config_flags ! Derived type holding all configurable SILHS flags 580 | 581 | call initialize_silhs_config_flags_type( cluster_allocation_strategy, & ! In 582 | l_lh_importance_sampling, & ! In 583 | l_Lscale_vert_avg, & ! In 584 | l_lh_straight_mc, & ! In 585 | l_lh_clustered_sampling, & ! In 586 | l_rcm_in_cloud_k_lh_start, & ! In 587 | l_random_k_lh_start, & ! In 588 | l_max_overlap_in_cloud, & ! In 589 | l_lh_instant_var_covar_src, & ! In 590 | l_lh_limit_weights, & ! In 591 | l_lh_var_frac, & ! In 592 | l_lh_normalize_weights, & ! In 593 | silhs_config_flags ) ! Out 594 | 595 | end subroutine initialize_silhs_config_flags_type_api 596 | 597 | !----------------------------------------------------------------- 598 | ! print_silhs_config_flags: Prints the silhs_config_flags 599 | !----------------------------------------------------------------- 600 | 601 | subroutine print_silhs_config_flags_api( iunit, silhs_config_flags ) ! In 602 | 603 | use parameters_silhs, only: & 604 | silhs_config_flags_type, & ! Type 605 | print_silhs_config_flags ! Procedure 606 | 607 | implicit none 608 | 609 | ! Input variables 610 | integer, intent(in) :: & 611 | iunit ! The file to write to 612 | 613 | type(silhs_config_flags_type), intent(in) :: & 614 | silhs_config_flags ! Derived type holding all configurable SILHS flags 615 | 616 | call print_silhs_config_flags( iunit, silhs_config_flags ) ! In 617 | 618 | end subroutine print_silhs_config_flags_api 619 | 620 | #endif 621 | 622 | end module silhs_api_module 623 | --------------------------------------------------------------------------------