├── recl.inc ├── clubb_precision.F90 ├── code_timer_module.F90 ├── stats_type.F90 ├── input_names.F90 ├── T_in_K_module.F90 ├── array_index.F90 ├── version_clubb_core.txt ├── error_code.F90 ├── stat_file_module.F90 ├── stats_lh_sfc_module.F90 ├── hydromet_pdf_parameter_module.F90 ├── parameters_model.F90 ├── parameter_indices.F90 ├── sigma_sqd_w_module.F90 ├── stats_rad_zm_module.F90 ├── stats_rad_zt_module.F90 ├── file_functions.F90 ├── pos_definite_module.F90 ├── Skx_module.F90 ├── endian.F90 ├── calendar.F90 ├── LY93_pdf.F90 ├── ChangeLog ├── calc_roots.F90 ├── index_mapping.F90 ├── lapack_interfaces.F90 ├── stats_sfc_module.F90 ├── matrix_operations.F90 └── sponge_layer_damping.F90 /recl.inc: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | ! Description: 4 | ! Preprocessing rules for determining how large an unformatted 5 | ! data record is when using Fortran write. This does not affect 6 | ! netCDF output at all. 7 | 8 | ! Notes: 9 | ! New directives will need to be added to port CLUBB GrADS output 10 | ! to new compilers that do not use byte size record lengths. 11 | 12 | ! Early Alpha processors lacked the ability to work with anything 13 | ! smaller than a 32 bit word, so DEC Fortran and its successors 14 | ! (Compaq Visual Fortran, newer Intel Fortran, etc.) all use 4 15 | ! byte records. Note that specifying byterecl on Alpha still 16 | ! results in a performance hit, even on newer chips. 17 | !------------------------------------------------------------------------------- 18 | #if defined GFDL /* F_RECL should be 4 for the GFDL SCM-CLUBB */ 19 | # define F_RECL 4 20 | #elif defined __INTEL_COMPILER && __INTEL_COMPILER >= 800 /* Versions of Intel fortran > 8.0 */ 21 | # define F_RECL 1 22 | #elif defined(__alpha) /* Assume 4 byte word on Alpha processors */ 23 | # define F_RECL 1 24 | #else 25 | # define F_RECL 4 /* Most compilers and computers */ 26 | #endif 27 | -------------------------------------------------------------------------------- /clubb_precision.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module clubb_precision 5 | 6 | implicit none 7 | 8 | public :: stat_nknd, stat_rknd, time_precision, dp, core_rknd 9 | 10 | private ! Default scope 11 | 12 | ! This definition of double precision must use a real type that is 64 bits 13 | ! wide, because (at least) the LAPACK routines depend on this definition being 14 | ! accurate. Otherwise, LAPACK must be recompiled, or some other trickery must 15 | ! be done. 16 | integer, parameter :: & 17 | dp = selected_real_kind( p=12 ) ! double precision 18 | 19 | ! The precisions below are arbitrary, and could be adjusted as 20 | ! needed for long simulations or time averaging. Note that on 21 | ! most machines 12 digits of precision will use a data type 22 | ! which is 8 bytes long. 23 | integer, parameter :: & 24 | stat_nknd = selected_int_kind( 8 ), & 25 | stat_rknd = selected_real_kind( p=12 ), & 26 | time_precision = selected_real_kind( p=12 ), & 27 | core_rknd = CLUBB_REAL_TYPE ! Value from the preprocessor directive 28 | 29 | end module clubb_precision 30 | !------------------------------------------------------------------------------- 31 | -------------------------------------------------------------------------------- /code_timer_module.F90: -------------------------------------------------------------------------------- 1 | ! $Id$ 2 | module code_timer_module 3 | 4 | ! Description: 5 | ! This module contains a diagnostic timer utility that can be used 6 | ! to time a piece of code. 7 | 8 | implicit none 9 | 10 | private ! Set default scope 11 | 12 | ! A timer!! 13 | type timer_t 14 | real :: time_elapsed ! Time elapsed [sec] 15 | real :: secstart ! Timer starting time 16 | end type timer_t 17 | 18 | public :: timer_t, timer_start, timer_stop 19 | 20 | contains 21 | 22 | !----------------------------------------------------------------------- 23 | subroutine timer_start( timer ) 24 | 25 | ! Description: 26 | ! Starts the timer 27 | 28 | ! References: 29 | ! None 30 | !----------------------------------------------------------------------- 31 | 32 | implicit none 33 | 34 | ! Input/Output Variables 35 | type(timer_t), intent(inout) :: timer 36 | 37 | !----------------------------------------------------------------------- 38 | !----- Begin Code ----- 39 | call cpu_time( timer%secstart ) 40 | return 41 | end subroutine timer_start 42 | !----------------------------------------------------------------------- 43 | 44 | !----------------------------------------------------------------------- 45 | subroutine timer_stop( timer ) 46 | 47 | ! Description: 48 | ! Stops the timer 49 | 50 | ! References: 51 | ! None 52 | !----------------------------------------------------------------------- 53 | implicit none 54 | 55 | ! Input/Output Variables 56 | type(timer_t), intent(inout) :: timer 57 | 58 | ! Local Variables 59 | real :: secend 60 | 61 | !----------------------------------------------------------------------- 62 | !----- Begin Code ----- 63 | call cpu_time( secend ) 64 | 65 | 66 | timer%time_elapsed = timer%time_elapsed + (secend - timer%secstart) 67 | timer%secstart = 0.0 68 | 69 | return 70 | end subroutine timer_stop 71 | !----------------------------------------------------------------------- 72 | 73 | end module code_timer_module 74 | -------------------------------------------------------------------------------- /stats_type.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module stats_type 5 | 6 | ! Description: 7 | ! Contains derived data type 'stats'. 8 | ! Used for storing output statistics to disk. 9 | !----------------------------------------------------------------------- 10 | 11 | use stat_file_module, only: & 12 | stat_file ! Type 13 | 14 | use clubb_precision, only: & 15 | stat_rknd, & ! Variable(s) 16 | stat_nknd, & 17 | core_rknd 18 | 19 | implicit none 20 | 21 | private ! Set Default Scope 22 | 23 | public :: stats 24 | 25 | ! Derived data types to store GrADS/netCDF statistics 26 | type stats 27 | 28 | ! Number of fields to sample 29 | integer :: num_output_fields ! Number of variables being output to disk (e.g. 30 | ! cloud_frac, rain rate, etc.) 31 | 32 | integer :: & 33 | ii, & ! Horizontal extent of the variables (Usually 1 for the single-column model) 34 | jj, & ! Horizontal extent of the variables (Usually 1 for the single-column model) 35 | kk ! Vertical extent of the variables (Usually gr%nz from grid_class) 36 | 37 | ! Vertical levels 38 | real( kind = core_rknd ), allocatable, dimension(:) :: z ! altitude [m] 39 | 40 | ! Array to store sampled fields 41 | 42 | real(kind=stat_rknd), allocatable, dimension(:,:,:,:) :: accum_field_values 43 | ! The variable accum_field_values contains the cumulative sums 44 | ! of accum_num_samples sample values of each 45 | ! of the num_output_fields (e.g. the sum of the sampled rain rate values) 46 | 47 | integer(kind=stat_nknd), allocatable, dimension(:,:,:,:) :: accum_num_samples 48 | ! accum_num_samples is the number of samples for each of the num_output_fields fields 49 | ! and each of the kk vertical levels 50 | 51 | ! Tracks if a field is in the process of an update 52 | logical, allocatable, dimension(:,:,:,:) :: l_in_update 53 | 54 | ! Data for GrADS / netCDF output 55 | 56 | type (stat_file) :: file 57 | 58 | end type stats 59 | 60 | end module stats_type 61 | 62 | 63 | -------------------------------------------------------------------------------- /input_names.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | module input_names 5 | ! 6 | ! Description: This module contains all of the strings used to define the 7 | ! headers for input_reader.F90 compatable files. 8 | ! 9 | !--------------------------------------------------------------------------------------------------- 10 | implicit none 11 | ! Column identifiers 12 | character(len=*), public, parameter :: & 13 | z_name = 'z[m]' 14 | 15 | character(len=*), public, parameter :: & 16 | pressure_name = 'Press[Pa]', & 17 | press_mb_name = "Press[mb]" 18 | 19 | character(len=*), public, parameter :: & 20 | temperature_name = 'T[K]', & 21 | theta_name = 'thm[K]', & 22 | thetal_name = 'thlm[K]' 23 | 24 | character(len=*), public, parameter :: & 25 | temperature_f_name = 'T_f[K\s]', & 26 | thetal_f_name = 'thlm_f[K\s]', & 27 | theta_f_name = 'thm_f[K\s]' 28 | 29 | character(len=*), public, parameter :: & 30 | rt_name = 'rt[kg\kg]', & 31 | sp_humidity_name = "sp_hmdty[kg\kg]" 32 | 33 | character(len=*), public, parameter :: & 34 | rt_f_name = 'rtm_f[kg\kg\s]', & 35 | sp_humidity_f_name = 'sp_hmdty_f[kg\kg\s]' 36 | 37 | character(len=*), public, parameter :: & 38 | um_name = 'u[m\s]', & 39 | vm_name = 'v[m\s]' 40 | 41 | character(len=*), public, parameter :: & 42 | ug_name = 'ug[m\s]', & 43 | vg_name = 'vg[m\s]' 44 | 45 | character(len=*), public, parameter :: & 46 | um_ref_name = 'um_ref[m\s]', & 47 | vm_ref_name = 'vm_ref[m\s]' 48 | 49 | character(len=*), public, parameter :: & 50 | um_f_name = 'um_f[m\s^2]', & 51 | vm_f_name = 'vm_f[m\s^2]' 52 | 53 | character(len=*), public, parameter :: & 54 | wm_name = 'w[m\s]', & 55 | omega_name = 'omega[Pa\s]', & 56 | omega_mb_hr_name = 'omega[mb\hr]' 57 | 58 | character(len=*), public, parameter :: & 59 | CO2_name = 'CO2[ppmv]', & 60 | CO2_umol_name = 'CO2[umol\m^2\s]', & 61 | ozone_name = "o3[kg\kg]" 62 | 63 | character(len=*), public, parameter :: & 64 | time_name = 'Time[s]' 65 | 66 | character(len=*), public, parameter :: & 67 | latent_ht_name = 'latent_ht[W\m^2]', & 68 | sens_ht_name = 'sens_ht[W\m^2]' 69 | 70 | character(len=*), public, parameter :: & 71 | upwp_sfc_name = 'upwp_sfc[(m\s)^2]', & 72 | vpwp_sfc_name = 'vpwp_sfc[(m\s)^2]' 73 | 74 | character(len=*), public, parameter :: & 75 | T_sfc_name = 'T_sfc[K]' 76 | 77 | character(len=*), public, parameter :: & 78 | wpthlp_sfc_name = 'wpthlp_sfc[mK\s]', & 79 | wpqtp_sfc_name = 'wpqtp_sfc[(kg\kg)m\s]' 80 | 81 | private ! Default Scope 82 | 83 | end module input_names 84 | -------------------------------------------------------------------------------- /T_in_K_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module T_in_K_module 5 | 6 | implicit none 7 | 8 | private ! Default scope 9 | 10 | public :: thlm2T_in_K, T_in_K2thlm 11 | 12 | contains 13 | 14 | !------------------------------------------------------------------------------- 15 | elemental function thlm2T_in_K( thlm, exner, rcm ) & 16 | result( T_in_K ) 17 | 18 | ! Description: 19 | ! Calculates absolute temperature from liquid water potential 20 | ! temperature. (Does not include ice.) 21 | 22 | ! References: 23 | ! Cotton and Anthes (1989), "Storm and Cloud Dynamics", Eqn. (2.51). 24 | !------------------------------------------------------------------------------- 25 | use constants_clubb, only: & 26 | ! Variable(s) 27 | Cp, & ! Dry air specific heat at constant p [J/kg/K] 28 | Lv ! Latent heat of vaporization [J/kg] 29 | 30 | use clubb_precision, only: & 31 | core_rknd ! Variable(s) 32 | 33 | implicit none 34 | 35 | ! Input 36 | real( kind = core_rknd ), intent(in) :: & 37 | thlm, & ! Liquid potential temperature [K] 38 | exner, & ! Exner function [-] 39 | rcm ! Liquid water mixing ratio [kg/kg] 40 | 41 | real( kind = core_rknd ) :: & 42 | T_in_K ! Result temperature [K] 43 | 44 | ! ---- Begin Code ---- 45 | 46 | T_in_K = thlm * exner + Lv * rcm / Cp 47 | 48 | return 49 | end function thlm2T_in_K 50 | !------------------------------------------------------------------------------- 51 | elemental function T_in_K2thlm( T_in_K, exner, rcm ) & 52 | result( thlm ) 53 | 54 | ! Description: 55 | ! Calculates liquid water potential temperature from absolute temperature 56 | 57 | ! References: 58 | ! None 59 | !------------------------------------------------------------------------------- 60 | use constants_clubb, only: & 61 | ! Variable(s) 62 | Cp, & ! Dry air specific heat at constant p [J/kg/K] 63 | Lv ! Latent heat of vaporization [J/kg] 64 | 65 | use clubb_precision, only: & 66 | core_rknd ! Variable(s) 67 | 68 | implicit none 69 | 70 | ! Input 71 | real( kind = core_rknd ), intent(in) :: & 72 | T_in_K, &! Result temperature [K] 73 | exner, & ! Exner function [-] 74 | rcm ! Liquid water mixing ratio [kg/kg] 75 | 76 | real( kind = core_rknd ) :: & 77 | thlm ! Liquid potential temperature [K] 78 | 79 | ! ---- Begin Code ---- 80 | 81 | thlm = ( T_in_K - Lv/Cp * rcm ) / exner 82 | 83 | return 84 | end function T_in_K2thlm 85 | !------------------------------------------------------------------------------- 86 | 87 | end module T_in_K_module 88 | -------------------------------------------------------------------------------- /array_index.F90: -------------------------------------------------------------------------------- 1 | !--------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module array_index 5 | 6 | ! Description: 7 | ! Contains indices to variables in larger arrays. 8 | ! Note that the 'ii' is necessary because 'i' is used in 9 | ! statistics to track locations in the zt/zm/sfc derived types. 10 | 11 | ! References: 12 | ! None 13 | !------------------------------------------------------------------------- 14 | 15 | use clubb_precision, only: & 16 | core_rknd ! Precision 17 | 18 | implicit none 19 | 20 | ! Variables 21 | ! Microphysics mixing ratios 22 | integer, public :: & 23 | iirr, & ! Hydrometeor array index for rain water mixing ratio, rr 24 | iirs, & ! Hydrometeor array index for snow mixing ratio, rs 25 | iiri, & ! Hydrometeor array index for ice mixing ratio, ri 26 | iirg ! Hydrometeor array index for graupel mixing ratio, rg 27 | !$omp threadprivate(iirr, iirs, iiri, iirg) 28 | 29 | ! Microphysics concentrations 30 | integer, public :: & 31 | iiNr, & ! Hydrometeor array index for rain drop concentration, Nr 32 | iiNs, & ! Hydrometeor array index for snow concentration, Ns 33 | iiNi, & ! Hydrometeor array index for ice concentration, Ni 34 | iiNg ! Hydrometeor array index for graupel concentration, Ng 35 | !$omp threadprivate(iiNr, iiNs, iiNi, iiNg) 36 | 37 | ! Scalar quantities 38 | integer, public :: & 39 | iisclr_rt, iisclr_thl, iisclr_CO2, & ! [kg/kg]/[K]/[1e6 mol/mol] 40 | iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2 ! " " 41 | !$omp threadprivate(iisclr_rt, iisclr_thl, iisclr_CO2, & 42 | !$omp iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2) 43 | 44 | ! Logical fields 45 | logical, dimension(:), allocatable, public :: & 46 | l_frozen_hm, & ! if true, then the hydrometeor is frozen; otherwise liquid 47 | l_mix_rat_hm ! if true, then the quantity is a hydrometeor mixing ratio 48 | !$omp threadprivate(l_frozen_hm, l_mix_rat_hm) 49 | 50 | character(len=10), dimension(:), allocatable, public :: & 51 | hydromet_list 52 | 53 | !$omp threadprivate( hydromet_list ) 54 | 55 | real( kind = core_rknd ), dimension(:), allocatable, public :: & 56 | hydromet_tol ! Tolerance values for all hydrometeors [units vary] 57 | 58 | !$omp threadprivate( hydromet_tol ) 59 | 60 | ! Latin hypercube indices / Correlation array indices 61 | integer, public :: & 62 | iiPDF_chi = -1, & 63 | iiPDF_eta = -1, & 64 | iiPDF_w = -1 65 | !$omp threadprivate(iiPDF_chi, iiPDF_eta, iiPDF_w) 66 | 67 | integer, public :: & 68 | iiPDF_rr = -1, & 69 | iiPDF_rs = -1, & 70 | iiPDF_ri = -1, & 71 | iiPDF_rg = -1 72 | !$omp threadprivate(iiPDF_rr, iiPDF_rs, iiPDF_ri, iiPDF_rg) 73 | 74 | integer, public :: & 75 | iiPDF_Nr = -1, & 76 | iiPDF_Ns = -1, & 77 | iiPDF_Ni = -1, & 78 | iiPDF_Ng = -1, & 79 | iiPDF_Ncn = -1 80 | !$omp threadprivate(iiPDF_Nr, iiPDF_Ns, iiPDF_Ni, iiPDF_Ng, iiPDF_Ncn) 81 | 82 | private ! Default Scope 83 | 84 | !=============================================================================== 85 | 86 | end module array_index 87 | -------------------------------------------------------------------------------- /version_clubb_core.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 | -------------------------------------------------------------------------------- /error_code.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !------------------------------------------------------------------------------- 4 | 5 | module error_code 6 | 7 | ! Description: 8 | ! Since f90/95 lacks enumeration, we're stuck numbering each 9 | ! error code by hand like this. 10 | 11 | ! We are "enumerating" error codes to be used with CLUBB. Adding 12 | ! additional codes is as simple adding an additional integer 13 | ! parameter. The error codes are ranked by severity, the higher 14 | ! number being more servere. When two errors occur, assign the 15 | ! most servere to the output. 16 | 17 | ! This code also handles subroutines related to debug_level. See 18 | ! the 'set_clubb_debug_level' description for more detail. 19 | 20 | ! References: 21 | ! None 22 | !------------------------------------------------------------------------------- 23 | 24 | implicit none 25 | 26 | private ! Default Scope 27 | 28 | public :: & 29 | clubb_at_least_debug_level, & 30 | set_clubb_debug_level, & 31 | initialize_error_headers 32 | 33 | private :: clubb_debug_level 34 | 35 | ! Model-Wide Debug Level 36 | integer, save :: clubb_debug_level = 0 37 | 38 | integer, public :: err_code = 0; 39 | 40 | character(len=35), public :: err_header 41 | 42 | !$omp threadprivate(clubb_debug_level,err_code,err_header) 43 | 44 | ! Error Code Values 45 | integer, parameter, public :: & 46 | clubb_no_error = 0, & 47 | clubb_fatal_error = 99 48 | 49 | contains 50 | !------------------------------------------------------------------------------- 51 | ! Description: 52 | ! Checks to see if clubb has been set to a specified debug level 53 | !------------------------------------------------------------------------------- 54 | logical function clubb_at_least_debug_level( level ) 55 | 56 | implicit none 57 | 58 | ! Input variable 59 | integer, intent(in) :: level ! The debug level being checked against the current setting 60 | 61 | ! ---- Begin Code ---- 62 | 63 | clubb_at_least_debug_level = ( level <= clubb_debug_level ) 64 | 65 | return 66 | 67 | end function clubb_at_least_debug_level 68 | 69 | 70 | subroutine initialize_error_headers 71 | 72 | implicit none 73 | 74 | #ifdef _OPENMP 75 | integer :: omp_get_thread_num 76 | write(err_header,'(A7,I7,A20)') "Thread ", omp_get_thread_num(), " -- CLUBB -- ERROR: " 77 | #else 78 | integer :: getpid 79 | write(err_header,'(A20)') " -- CLUBB -- ERROR: " 80 | #endif 81 | 82 | 83 | end subroutine initialize_error_headers 84 | 85 | 86 | !------------------------------------------------------------------------------- 87 | ! Description: 88 | ! Accessor for clubb_debug_level 89 | ! 90 | ! 0 => Print no debug messages to the screen 91 | ! 1 => Print lightweight debug messages, e.g. print statements 92 | ! 2 => Print debug messages that require extra testing, 93 | ! e.g. checks for NaNs and spurious negative values. 94 | ! References: 95 | ! None 96 | !------------------------------------------------------------------------------- 97 | subroutine set_clubb_debug_level( level ) 98 | 99 | implicit none 100 | 101 | ! Input variable 102 | integer, intent(in) :: level ! The debug level being checked against the current setting 103 | 104 | ! ---- Begin Code ---- 105 | 106 | clubb_debug_level = max(level,0) 107 | 108 | return 109 | end subroutine set_clubb_debug_level 110 | 111 | end module error_code 112 | -------------------------------------------------------------------------------- /stat_file_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module stat_file_module 5 | 6 | 7 | ! Description: 8 | ! Contains two derived types for describing the contents and location of 9 | ! either NetCDF or GrADS files. 10 | !------------------------------------------------------------------------------- 11 | use clubb_precision, only: & 12 | stat_rknd, & ! Variable 13 | time_precision, & 14 | core_rknd 15 | 16 | implicit none 17 | 18 | public :: variable, stat_file 19 | 20 | ! These are used in a 2D or 3D host model to output multiple columns 21 | ! Set clubb_i and clubb_j according to the column within the host model; 22 | ! The indices must not exceed nlon (for i) or nlat (for j). 23 | integer, save, public :: clubb_i = 1, clubb_j = 1 24 | !$omp threadprivate(clubb_i, clubb_j) 25 | 26 | private ! Default scope 27 | 28 | ! Structure to hold the description of a variable 29 | 30 | type variable 31 | ! Pointer to the array 32 | real(kind=stat_rknd), dimension(:,:,:), pointer :: ptr 33 | 34 | character(len = 30) :: name ! Variable name 35 | character(len = 100) :: description ! Variable description 36 | character(len = 20) :: units ! Variable units 37 | 38 | integer :: indx ! NetCDF module Id for var / GrADS index 39 | 40 | logical :: l_silhs ! If true, we sample this variable once for each SILHS 41 | ! sample point per timestep, rather than just once per 42 | ! timestep. 43 | end type variable 44 | 45 | ! Structure to hold the description of a NetCDF output file 46 | ! This makes the new code as compatible as possible with the 47 | ! GrADS output code 48 | 49 | type stat_file 50 | 51 | ! File information 52 | 53 | character(len = 200) :: & 54 | fname, & ! File name without suffix 55 | fdir ! Path where fname resides 56 | 57 | integer :: iounit ! This number is used internally by the 58 | ! NetCDF module to track the data set, or by 59 | ! GrADS to track the actual file unit. 60 | integer :: & 61 | nrecord, & ! Number of records written 62 | ntimes ! Number of times written 63 | 64 | logical :: & 65 | l_defined, & ! Whether nf90_enddef() has been called 66 | l_byte_swapped ! Is this a file in the opposite byte ordering? 67 | 68 | ! NetCDF datafile dimensions indices 69 | integer :: & 70 | LatDimId, LongDimId, AltDimId, TimeDimId, & 71 | LatVarId, LongVarId, AltVarId, TimeVarId 72 | 73 | ! Grid information 74 | 75 | integer :: ia, iz ! Vertical extent 76 | 77 | integer :: nlat, nlon ! The number of points in the X and Y 78 | 79 | real( kind = core_rknd ), dimension(:), allocatable :: & 80 | z ! Height of vertical levels [m] 81 | 82 | ! Time information 83 | 84 | integer :: day, month, year ! Date of starting time 85 | 86 | real( kind = core_rknd ), dimension(:), allocatable :: & 87 | rlat, & ! Latitude [Degrees N] 88 | rlon ! Longitude [Degrees E] 89 | 90 | real( kind = core_rknd ) :: & 91 | dtwrite ! Interval between output [Seconds] 92 | 93 | real( kind = time_precision ) :: & 94 | time ! Start time [Seconds] 95 | 96 | ! Statistical Variables 97 | 98 | integer :: nvar ! Number of variables for this file 99 | 100 | type (variable), dimension(:), allocatable :: & 101 | var ! List and variable description 102 | 103 | end type stat_file 104 | 105 | end module stat_file_module 106 | -------------------------------------------------------------------------------- /stats_lh_sfc_module.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | 5 | module stats_lh_sfc_module 6 | 7 | 8 | implicit none 9 | 10 | private ! Set Default Scope 11 | 12 | public :: stats_init_lh_sfc 13 | 14 | ! Constant parameters 15 | integer, parameter, public :: nvarmax_lh_sfc = 10 ! Maximum variables allowed 16 | 17 | contains 18 | 19 | !----------------------------------------------------------------------- 20 | subroutine stats_init_lh_sfc( vars_lh_sfc, l_error ) 21 | 22 | ! Description: 23 | ! Initializes array indices for stats_lh_sfc 24 | ! References: 25 | ! None 26 | !----------------------------------------------------------------------- 27 | 28 | use constants_clubb, only: & 29 | fstderr ! Constant(s) 30 | 31 | use stats_variables, only: & 32 | stats_lh_sfc ! Variable(s) 33 | 34 | use stats_variables, only: & 35 | ilh_morr_snow_rate, & ! Variable(s) 36 | ilh_vwp, & 37 | ilh_lwp, & 38 | ilh_sample_weights_sum, & 39 | ilh_sample_weights_avg, & 40 | ik_lh_start 41 | 42 | use stats_type_utilities, only: & 43 | stat_assign ! Procedure 44 | 45 | implicit none 46 | 47 | ! External 48 | intrinsic :: trim 49 | 50 | ! Input Variable 51 | character(len= * ), dimension(nvarmax_lh_sfc), intent(in) :: vars_lh_sfc 52 | 53 | ! Input / Output Variable 54 | logical, intent(inout) :: l_error 55 | 56 | ! Local Varables 57 | integer :: i, k 58 | 59 | ! ---- Begin Code ---- 60 | 61 | ! Default initialization for array indices for stats_sfc is zero (see module 62 | ! stats_variables) 63 | 64 | ! Assign pointers for statistics variables stats_sfc 65 | 66 | k = 1 67 | do i = 1, stats_lh_sfc%num_output_fields 68 | 69 | select case ( trim( vars_lh_sfc(i) ) ) 70 | 71 | case ( 'lh_morr_snow_rate' ) 72 | ilh_morr_snow_rate = k 73 | call stat_assign( var_index=ilh_morr_snow_rate, var_name="lh_morr_snow_rate", & 74 | var_description="Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]", & 75 | var_units="mm/day", l_silhs=.true., grid_kind=stats_lh_sfc ) 76 | k = k + 1 77 | 78 | case ( 'lh_vwp' ) 79 | ilh_vwp = k 80 | call stat_assign( var_index=ilh_vwp, var_name="lh_vwp", & 81 | var_description="Vapor water path [kg/m^2]", var_units="kg/m^2", l_silhs=.true., & 82 | grid_kind=stats_lh_sfc ) 83 | k = k + 1 84 | 85 | case ( 'lh_lwp' ) 86 | ilh_lwp = k 87 | call stat_assign( var_index=ilh_lwp, var_name="lh_lwp", & 88 | var_description="Liquid water path [kg/m^2]", var_units="kg/m^2", l_silhs=.true., & 89 | grid_kind=stats_lh_sfc ) 90 | k = k + 1 91 | 92 | case ( 'k_lh_start' ) 93 | ik_lh_start = k 94 | call stat_assign( var_index=ik_lh_start, var_name="k_lh_start", & 95 | var_description="Index of height level for SILHS sampling preferentially within & 96 | &cloud [integer]", var_units="integer", l_silhs=.true., & 97 | grid_kind=stats_lh_sfc ) 98 | k = k + 1 99 | 100 | case ( 'lh_sample_weights_sum' ) 101 | ilh_sample_weights_sum = k 102 | call stat_assign( var_index=ilh_sample_weights_sum, var_name="lh_sample_weights_sum", & 103 | var_description="Sum of the sample point weights [-]", var_units="-", l_silhs=.true., & 104 | grid_kind=stats_lh_sfc ) 105 | k = k + 1 106 | 107 | case ( 'lh_sample_weights_avg' ) 108 | ilh_sample_weights_avg = k 109 | call stat_assign( var_index=ilh_sample_weights_avg, var_name="lh_sample_weights_avg", & 110 | var_description="Average of the sample point weights [-]", & 111 | var_units="-", l_silhs=.true., & 112 | grid_kind=stats_lh_sfc ) 113 | k = k + 1 114 | 115 | case default 116 | write(fstderr,*) 'Error: unrecognized variable in vars_lh_sfc: ', & 117 | trim( vars_lh_sfc(i) ) 118 | l_error = .true. ! This will stop the run. 119 | 120 | end select 121 | 122 | end do ! i = 1, stats_lh_sfc%num_output_fields 123 | 124 | return 125 | end subroutine stats_init_lh_sfc 126 | 127 | end module stats_lh_sfc_module 128 | 129 | -------------------------------------------------------------------------------- /hydromet_pdf_parameter_module.F90: -------------------------------------------------------------------------------- 1 | !--------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module hydromet_pdf_parameter_module 5 | 6 | ! Description: 7 | ! This module defines the derived type hydromet_pdf_parameter. 8 | 9 | ! References: 10 | ! None 11 | !------------------------------------------------------------------------- 12 | 13 | use clubb_precision, only: & 14 | core_rknd ! Variable(s) 15 | 16 | implicit none 17 | 18 | private ! Default scope 19 | 20 | public :: hydromet_pdf_parameter, & ! Variable type 21 | init_hydromet_pdf_params ! Procedure 22 | 23 | integer, parameter, private :: & 24 | max_hydromet_dim = 8 25 | 26 | type hydromet_pdf_parameter 27 | 28 | real( kind = core_rknd ), dimension(max_hydromet_dim) :: & 29 | hm_1, & ! Mean of hydrometeor, hm (1st PDF component) [un vary] 30 | hm_2, & ! Mean of hydrometeor, hm (2nd PDF component) [un vary] 31 | mu_hm_1, & ! Mean of hm (1st PDF component) in-precip (ip) [un vary] 32 | mu_hm_2, & ! Mean of hm (2nd PDF component) ip [un vary] 33 | sigma_hm_1, & ! Standard deviation of hm (1st PDF comp.) ip [un vary] 34 | sigma_hm_2, & ! Standard deviation of hm (2nd PDF comp.) ip [un vary] 35 | corr_w_hm_1, & ! Correlation of w and hm (1st PDF component) ip [-] 36 | corr_w_hm_2, & ! Correlation of w and hm (2nd PDF component) ip [-] 37 | corr_chi_hm_1, & ! Correlation of chi and hm (1st PDF component) ip [-] 38 | corr_chi_hm_2, & ! Correlation of chi and hm (2nd PDF component) ip [-] 39 | corr_eta_hm_1, & ! Correlation of eta and hm (1st PDF component) ip [-] 40 | corr_eta_hm_2 ! Correlation of eta and hm (2nd PDF component) ip [-] 41 | 42 | real( kind = core_rknd ), dimension(max_hydromet_dim,max_hydromet_dim) :: & 43 | corr_hmx_hmy_1, & ! Correlation of hmx and hmy (1st PDF component) ip [-] 44 | corr_hmx_hmy_2 ! Correlation of hmx and hmy (2nd PDF component) ip [-] 45 | 46 | real( kind = core_rknd ) :: & 47 | mu_Ncn_1, & ! Mean of Ncn (1st PDF component) [num/kg] 48 | mu_Ncn_2, & ! Mean of Ncn (2nd PDF component) [num/kg] 49 | sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF component) [num/kg] 50 | sigma_Ncn_2 ! Standard deviation of Ncn (2nd PDF component) [num/kg] 51 | 52 | real( kind = core_rknd ) :: & 53 | precip_frac, & ! Precipitation fraction (overall) [-] 54 | precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] 55 | precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] 56 | 57 | end type hydromet_pdf_parameter 58 | 59 | contains 60 | 61 | !============================================================================= 62 | subroutine init_hydromet_pdf_params( hydromet_pdf_params ) 63 | 64 | ! Description: 65 | ! Initialize the elements of hydromet_pdf_params. 66 | 67 | ! References: 68 | !----------------------------------------------------------------------- 69 | 70 | use constants_clubb, only: & 71 | zero ! Constant(s) 72 | 73 | implicit none 74 | 75 | ! Output Variable 76 | type(hydromet_pdf_parameter), intent(out) :: & 77 | hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] 78 | 79 | ! Initialize hydromet_pdf_params. 80 | hydromet_pdf_params%hm_1 = zero 81 | hydromet_pdf_params%hm_2 = zero 82 | hydromet_pdf_params%mu_hm_1 = zero 83 | hydromet_pdf_params%mu_hm_2 = zero 84 | hydromet_pdf_params%sigma_hm_1 = zero 85 | hydromet_pdf_params%sigma_hm_2 = zero 86 | hydromet_pdf_params%corr_w_hm_1 = zero 87 | hydromet_pdf_params%corr_w_hm_2 = zero 88 | hydromet_pdf_params%corr_chi_hm_1 = zero 89 | hydromet_pdf_params%corr_chi_hm_2 = zero 90 | hydromet_pdf_params%corr_eta_hm_1 = zero 91 | hydromet_pdf_params%corr_eta_hm_2 = zero 92 | 93 | hydromet_pdf_params%corr_hmx_hmy_1 = zero 94 | hydromet_pdf_params%corr_hmx_hmy_2 = zero 95 | 96 | hydromet_pdf_params%mu_Ncn_1 = zero 97 | hydromet_pdf_params%mu_Ncn_2 = zero 98 | hydromet_pdf_params%sigma_Ncn_1 = zero 99 | hydromet_pdf_params%sigma_Ncn_2 = zero 100 | 101 | hydromet_pdf_params%precip_frac = zero 102 | hydromet_pdf_params%precip_frac_1 = zero 103 | hydromet_pdf_params%precip_frac_2 = zero 104 | 105 | 106 | return 107 | 108 | end subroutine init_hydromet_pdf_params 109 | 110 | !=============================================================================== 111 | 112 | end module hydromet_pdf_parameter_module 113 | -------------------------------------------------------------------------------- /parameters_model.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module parameters_model 5 | 6 | ! Description: 7 | ! Contains model parameters that are determined at run time rather than 8 | ! compile time. 9 | ! 10 | ! References: 11 | ! None 12 | !------------------------------------------------------------------------------- 13 | 14 | use clubb_precision, only: & 15 | core_rknd 16 | 17 | implicit none 18 | 19 | private ! Default scope 20 | 21 | integer, parameter :: & 22 | sp = selected_real_kind(6) ! 32-bit floating point number 23 | 24 | ! Maximum magnitude of PDF parameter 'mixt_frac'. 25 | real( kind = core_rknd ), public :: mixt_frac_max_mag 26 | 27 | !$omp threadprivate(mixt_frac_max_mag) 28 | 29 | ! Model parameters and constraints setup in the namelists 30 | real( kind = core_rknd ), public :: & 31 | T0 = 300._core_rknd, & ! Reference temperature (usually 300) [K] 32 | ts_nudge = 0._core_rknd ! Timescale of u/v nudging [s] 33 | 34 | #ifdef GFDL 35 | real( kind = core_rknd ), public :: & ! h1g, 2010-06-15 36 | cloud_frac_min ! minimum cloud fraction for droplet # 37 | !$omp threadprivate( cloud_frac_min ) 38 | #endif 39 | 40 | 41 | !$omp threadprivate(T0, ts_nudge) 42 | 43 | real( kind = core_rknd), public :: & 44 | rtm_min = epsilon( rtm_min ), & ! Value below which rtm will be nudged [kg/kg] 45 | rtm_nudge_max_altitude = 10000._core_rknd ! Highest altitude at which to nudge rtm [m] 46 | !$omp threadprivate( rtm_min, rtm_nudge_max_altitude ) 47 | 48 | integer, public :: & 49 | sclr_dim = 0, & ! Number of passive scalars 50 | edsclr_dim = 0, & ! Number of eddy-diff. passive scalars 51 | hydromet_dim = 0 ! Number of hydrometeor species 52 | 53 | !$omp threadprivate(sclr_dim, edsclr_dim, hydromet_dim) 54 | 55 | real( kind = core_rknd ), dimension(:), allocatable, public :: & 56 | sclr_tol ! Threshold(s) on the passive scalars [units vary] 57 | 58 | !$omp threadprivate(sclr_tol) 59 | 60 | real( kind = sp ), public :: PosInf 61 | 62 | !$omp threadprivate(PosInf) 63 | 64 | public :: setup_parameters_model 65 | 66 | contains 67 | 68 | !------------------------------------------------------------------------------- 69 | subroutine setup_parameters_model & 70 | ( T0_in, ts_nudge_in, & 71 | hydromet_dim_in, & 72 | sclr_dim_in, sclr_tol_in, edsclr_dim_in & 73 | #ifdef GFDL 74 | , cloud_frac_min_in & ! hlg, 2010-6-15 75 | #endif 76 | 77 | ) 78 | 79 | ! Description: 80 | ! Sets parameters to their initial values 81 | ! 82 | ! References: 83 | ! None 84 | !------------------------------------------------------------------------------- 85 | use parameters_tunable, only: & 86 | Skw_max_mag 87 | 88 | use clubb_precision, only: & 89 | core_rknd ! Variable(s) 90 | 91 | implicit none 92 | 93 | ! External 94 | intrinsic :: sqrt, allocated, transfer 95 | 96 | ! Constants 97 | integer(kind=4), parameter :: nanbits = 2139095040 98 | 99 | ! Input Variables 100 | real( kind = core_rknd ), intent(in) :: & 101 | T0_in, & ! Ref. temperature [K] 102 | ts_nudge_in ! Timescale for u/v nudging [s] 103 | 104 | #ifdef GFDL 105 | real( kind = core_rknd ), intent(in) :: cloud_frac_min_in ! h1g, 2010-06-15 106 | #endif 107 | 108 | 109 | integer, intent(in) :: & 110 | hydromet_dim_in, & ! Number of hydrometeor species 111 | sclr_dim_in, & ! Number of passive scalars 112 | edsclr_dim_in ! Number of eddy-diff. passive scalars 113 | 114 | real( kind = core_rknd ), intent(in), dimension(sclr_dim_in) :: & 115 | sclr_tol_in ! Threshold on passive scalars 116 | 117 | ! --- Begin Code --- 118 | 119 | ! Formula from subroutine pdf_closure, where sigma_sqd_w = 0.4 and Skw = 120 | ! Skw_max_mag in this formula. Note that this is constant, but can't appear 121 | ! with a Fortran parameter attribute, so we define it here. 122 | mixt_frac_max_mag = 1.0_core_rknd & 123 | - ( 0.5_core_rknd * ( 1.0_core_rknd - Skw_max_mag / & 124 | sqrt( 4.0_core_rknd * ( 1.0_core_rknd - 0.4_core_rknd )**3 & 125 | + Skw_max_mag**2 ) ) ) ! Known magic number 126 | 127 | T0 = T0_in 128 | ts_nudge = ts_nudge_in 129 | 130 | hydromet_dim = hydromet_dim_in 131 | sclr_dim = sclr_dim_in 132 | edsclr_dim = edsclr_dim_in 133 | 134 | ! In a tuning run, this array has the potential to be allocated already 135 | if ( .not. allocated( sclr_tol ) ) then 136 | allocate( sclr_tol(1:sclr_dim) ) 137 | else 138 | deallocate( sclr_tol ) 139 | allocate( sclr_tol(1:sclr_dim) ) 140 | end if 141 | 142 | sclr_tol(1:sclr_dim) = sclr_tol_in(1:sclr_dim) 143 | 144 | PosInf = transfer( nanbits, PosInf ) 145 | 146 | #ifdef GFDL 147 | cloud_frac_min = cloud_frac_min_in ! h1g, 2010-06-15 148 | #endif 149 | 150 | return 151 | end subroutine setup_parameters_model 152 | !------------------------------------------------------------------------------- 153 | 154 | end module parameters_model 155 | -------------------------------------------------------------------------------- /parameter_indices.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module parameter_indices 5 | 6 | ! Description: 7 | ! Since f90/95 lacks enumeration, we're stuck numbering each 8 | ! parameter by hand like this. 9 | 10 | ! Adding new parameters is relatively simple. First, the 11 | ! parameter should be added in the common block of the parameters 12 | ! module so it can be used in other parts of the code. Each 13 | ! variable needs a unique number in this module, and nparams must 14 | ! be incremented for the new variable. Next, the params_list 15 | ! variable in module parameters should have new variable added to 16 | ! it. The subroutines pack_parameters and uppack_parameters will 17 | ! need to have the variable added to their list, but the order 18 | ! doesn't actually matter, since the i variables in here determine 19 | ! where in the params vector the number is placed. 20 | ! Finally, the namelists clubb_params_nl and initspread will need to 21 | ! have the parameter added to them. 22 | !------------------------------------------------------------------------------- 23 | 24 | implicit none 25 | 26 | private ! Default Scope 27 | 28 | integer, parameter, public :: & 29 | nparams = 86 ! Total tunable parameters 30 | 31 | !*************************************************************** 32 | ! ***** IMPORTANT ***** 33 | ! If you change the order of these parameters, you will need to 34 | ! change the order of params_list as well or the tuner will 35 | ! break! 36 | ! ***** IMPORTANT ***** 37 | !*************************************************************** 38 | 39 | integer, parameter, public :: & 40 | iC1 = 1, & 41 | iC1b = 2, & 42 | iC1c = 3, & 43 | iC2 = 4, & 44 | iC2b = 5, & 45 | iC2c = 6, & 46 | iC2rt = 7, & 47 | iC2thl = 8, & 48 | iC2rtthl = 9, & 49 | iC4 = 10, & 50 | iC5 = 11, & 51 | iC6rt = 12, & 52 | iC6rtb = 13, & 53 | iC6rtc = 14, & 54 | iC6thl = 15, & 55 | iC6thlb = 16, & 56 | iC6thlc = 17, & 57 | iC7 = 18, & 58 | iC7b = 19, & 59 | iC7c = 20, & 60 | iC8 = 21, & 61 | iC8b = 22, & 62 | iC10 = 23, & 63 | iC11 = 24, & 64 | iC11b = 25, & 65 | iC11c = 26, & 66 | iC12 = 27, & 67 | iC13 = 28, & 68 | iC14 = 29, & 69 | iC15 = 30, & 70 | iC_wp2_splat = 31 71 | 72 | integer, parameter, public :: & 73 | iC6rt_Lscale0 = 32, & 74 | iC6thl_Lscale0 = 33, & 75 | iC7_Lscale0 = 34, & 76 | iwpxp_L_thresh = 35 77 | 78 | integer, parameter, public :: & 79 | ic_K = 36, & 80 | ic_K1 = 37, & 81 | inu1 = 38, & 82 | ic_K2 = 39, & 83 | inu2 = 40, & 84 | ic_K6 = 41, & 85 | inu6 = 42, & 86 | ic_K8 = 43, & 87 | inu8 = 44, & 88 | ic_K9 = 45, & 89 | inu9 = 46, & 90 | inu10 = 47, & 91 | ic_K_hm = 48, & 92 | ic_K_hmb = 49, & 93 | iK_hm_min_coef = 50, & 94 | inu_hm = 51 95 | 96 | integer, parameter, public :: & 97 | islope_coef_spread_DG_means_w = 52, & 98 | ipdf_component_stdev_factor_w = 53, & 99 | icoef_spread_DG_means_rt = 54, & 100 | icoef_spread_DG_means_thl = 55, & 101 | igamma_coef = 56, & 102 | igamma_coefb = 57, & 103 | igamma_coefc = 58, & 104 | imu = 59, & 105 | ibeta = 60, & 106 | ilmin_coef = 61, & 107 | iomicron = 62, & 108 | izeta_vrnce_rat = 63, & 109 | iupsilon_precip_frac_rat = 64, & 110 | ilambda0_stability_coef = 65, & 111 | imult_coef = 66, & 112 | itaumin = 67, & 113 | itaumax = 68, & 114 | iLscale_mu_coef = 69, & 115 | iLscale_pert_coef = 70, & 116 | ialpha_corr = 71, & 117 | iSkw_denom_coef = 72, & 118 | ic_K10 = 73, & 119 | ic_K10h = 74, & 120 | ithlp2_rad_coef = 75, & 121 | ithlp2_rad_cloud_frac_thresh = 76, & 122 | iup2_vp2_factor = 77, & 123 | iSkw_max_mag = 78, & 124 | iC_invrs_tau_bkgnd = 79, & 125 | iC_invrs_tau_sfc = 80, & 126 | iC_invrs_tau_shear = 81, & 127 | iC_invrs_tau_N2 = 82, & 128 | iC_invrs_tau_N2_wp2 = 83, & 129 | iC_invrs_tau_N2_xp2 = 84, & 130 | iC_invrs_tau_N2_wpxp = 85, & 131 | iC_invrs_tau_N2_clear_wp3 = 86 132 | 133 | 134 | end module parameter_indices 135 | !----------------------------------------------------------------------- 136 | -------------------------------------------------------------------------------- /sigma_sqd_w_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module sigma_sqd_w_module 5 | 6 | implicit none 7 | 8 | public :: compute_sigma_sqd_w 9 | 10 | private ! Default scope 11 | 12 | contains 13 | 14 | !============================================================================= 15 | elemental function compute_sigma_sqd_w( gamma_Skw_fnc, wp2, thlp2, rtp2, & 16 | up2, vp2, wpthlp, wprtp, upwp, vpwp, & 17 | l_predict_upwp_vpwp ) & 18 | result( sigma_sqd_w ) 19 | 20 | ! Description: 21 | ! Compute the variable sigma_sqd_w (PDF width parameter). 22 | ! 23 | ! The value of sigma_sqd_w is restricted in the ADG1 PDF in order to keep 24 | ! the marginal PDFs of all responder variables (variables that do not set 25 | ! the mixture fraction) valid. The limits on sigma_sqd_w in order to keep 26 | ! the PDF of a responder variable, x, valid are: 27 | ! 28 | ! 0 <= sigma_sqd_w <= 1 - ^2 / ( * ). 29 | ! 30 | ! The overall limits on sigma_sqd_w must be applied based on the most 31 | ! restrictive case so that all Double Gaussian PDF responder variables, x, 32 | ! have realizable PDFs. The overall limits on sigma_sqd_w are: 33 | ! 34 | ! 0 <= sigma_sqd_w <= 1 - max( ^2 / ( * ), for all x). 35 | ! 36 | ! The equation used for sigma_sqd_w is: 37 | ! 38 | ! sigma_sqd_w = gamma_Skw_fnc 39 | ! * ( 1 - max( ^2 / ( * ), for all x) ); 40 | ! 41 | ! where 0 <= gamma_Skw_fnc <= 1. 42 | 43 | ! References: 44 | ! Eqn 22 in ``Equations for CLUBB'' 45 | !----------------------------------------------------------------------- 46 | 47 | use constants_clubb, only: & 48 | one, & ! Constant(s) 49 | w_tol, & 50 | rt_tol, & 51 | thl_tol, & 52 | w_tol_sqd 53 | 54 | use clubb_precision, only: & 55 | core_rknd ! Variable(s) 56 | 57 | implicit none 58 | 59 | ! External 60 | intrinsic :: min, max, sqrt 61 | 62 | ! Input Variables 63 | real( kind = core_rknd ), intent(in) :: & 64 | gamma_Skw_fnc, & ! Gamma as a function of skewness [-] 65 | wp2, & ! Variance of vertical velocity [m^2/s^2] 66 | thlp2, & ! Variance of liquid water potential temp. [K^2] 67 | rtp2, & ! Variance of total water mixing ratio [kg^2/kg^2] 68 | up2, & ! Variance of west-east horizontal velocity [m^2/s^2] 69 | vp2, & ! Variance of south-north horizontal velocity [m^2/s^2] 70 | wpthlp, & ! Flux of liquid water potential temp. [m/s K] 71 | wprtp, & ! Flux of total water mixing ratio [m/s kg/kg] 72 | upwp, & ! Flux of west-east horizontal velocity [m^2/s^2] 73 | vpwp ! Flux of south-north horizontal velocity [m^2/s^2] 74 | 75 | logical, intent(in) :: & 76 | l_predict_upwp_vpwp ! Flag to predict and along with and alongside the 77 | ! advancement of , , , , , and in 78 | ! subroutine advance_xm_wpxp. Otherwise, and are still 79 | ! approximated by eddy diffusivity when and are advanced in 80 | ! subroutine advance_windm_edsclrm. 81 | 82 | ! Output Variable 83 | real( kind = core_rknd ) :: sigma_sqd_w ! PDF width parameter [-] 84 | 85 | ! Local Variable 86 | real( kind = core_rknd ) :: & 87 | max_corr_w_x_sqd ! Max. val. of wpxp^2/(wp2*xp2) for all vars. x [-] 88 | 89 | ! ---- Begin Code ---- 90 | 91 | !---------------------------------------------------------------- 92 | ! Compute sigma_sqd_w with new formula from Vince 93 | !---------------------------------------------------------------- 94 | 95 | ! Find the maximum value of ^2 / ( * ) for all 96 | ! variables x that are Double Gaussian PDF responder variables. This 97 | ! includes rt and theta-l. When l_predict_upwp_vpwp is enabled, u and v are 98 | ! also calculated as part of the PDF, and they are included as well. 99 | ! Additionally, when sclr_dim > 0, passive scalars (sclr) are also included. 100 | max_corr_w_x_sqd = max( ( wpthlp / ( sqrt( wp2 * thlp2 ) & 101 | + 0.01_core_rknd * w_tol * thl_tol ) )**2, & 102 | ( wprtp / ( sqrt( wp2 * rtp2 ) & 103 | + 0.01_core_rknd * w_tol * rt_tol ) )**2 ) 104 | 105 | if ( l_predict_upwp_vpwp ) then 106 | max_corr_w_x_sqd = max( max_corr_w_x_sqd, & 107 | ( upwp / ( sqrt( up2 * wp2 ) & 108 | + 0.01_core_rknd * w_tol_sqd ) )**2, & 109 | ( vpwp / ( sqrt( vp2 * wp2 ) & 110 | + 0.01_core_rknd * w_tol_sqd ) )**2 ) 111 | endif ! l_predict_upwp_vpwp 112 | 113 | ! Calculate the value of sigma_sqd_w . 114 | sigma_sqd_w = gamma_Skw_fnc * ( one - min( max_corr_w_x_sqd, one ) ) 115 | 116 | 117 | return 118 | 119 | end function compute_sigma_sqd_w 120 | 121 | !============================================================================= 122 | 123 | end module sigma_sqd_w_module 124 | -------------------------------------------------------------------------------- /stats_rad_zm_module.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | 5 | module stats_rad_zm_module 6 | 7 | implicit none 8 | 9 | private ! Default Scope 10 | 11 | public :: stats_init_rad_zm 12 | 13 | ! Constant parameters 14 | integer, parameter, public :: nvarmax_rad_zm = 250 ! Maximum variables allowed 15 | 16 | contains 17 | 18 | !----------------------------------------------------------------------- 19 | subroutine stats_init_rad_zm( vars_rad_zm, l_error ) 20 | 21 | ! Description: 22 | ! Initializes array indices for stats_rad_zm variables 23 | !----------------------------------------------------------------------- 24 | 25 | use constants_clubb, only: & 26 | fstderr ! Constant(s) 27 | 28 | use stats_variables, only: & 29 | stats_rad_zm, & 30 | iFrad_LW_rad, & ! Variable(s) 31 | iFrad_SW_rad, & 32 | iFrad_SW_up_rad, & 33 | iFrad_LW_up_rad, & 34 | iFrad_SW_down_rad, & 35 | iFrad_LW_down_rad 36 | 37 | use stats_variables, only: & 38 | ifulwcl, ifdlwcl, ifdswcl, ifuswcl ! Variable(s) 39 | 40 | use stats_type_utilities, only: & 41 | stat_assign ! Procedure 42 | 43 | 44 | implicit none 45 | 46 | ! Input Variable 47 | character(len= * ), dimension(nvarmax_rad_zm), intent(in) :: vars_rad_zm 48 | 49 | ! Input/Output Variable 50 | logical, intent(inout) :: l_error 51 | 52 | ! Local Varables 53 | integer :: i, k 54 | 55 | ! ---- Begin Code ---- 56 | 57 | ! Default initialization for array indices for stats_rad_zm 58 | 59 | iFrad_LW_rad = 0 60 | iFrad_SW_rad = 0 61 | iFrad_SW_up_rad = 0 62 | iFrad_LW_up_rad = 0 63 | iFrad_SW_down_rad = 0 64 | iFrad_LW_down_rad = 0 65 | 66 | ifulwcl = 0 67 | ifdlwcl = 0 68 | ifdswcl = 0 69 | ifuswcl = 0 70 | 71 | ! Assign pointers for statistics variables stats_rad_zm 72 | 73 | k = 1 74 | do i=1,stats_rad_zm%num_output_fields 75 | 76 | select case ( trim(vars_rad_zm(i)) ) 77 | 78 | case('fulwcl') 79 | ifulwcl = k 80 | call stat_assign( var_index=ifulwcl, var_name="fulwcl", & 81 | var_description="Upward clear-sky LW flux [W/m^2]", var_units="W/m^2", & 82 | l_silhs=.false., grid_kind=stats_rad_zm ) 83 | k = k + 1 84 | 85 | case( 'fdlwcl' ) 86 | ifdlwcl = k 87 | call stat_assign( var_index=ifdlwcl, var_name="fdlwcl", & 88 | var_description="Downward clear-sky LW flux [W/m^2]", var_units="W/m^2", & 89 | l_silhs=.false., grid_kind=stats_rad_zm ) 90 | k = k + 1 91 | 92 | case( 'fdswcl' ) 93 | ifdswcl = k 94 | call stat_assign( var_index=ifdswcl, var_name="fdswcl", & 95 | var_description="Downward clear-sky SW flux [W/m^2]", var_units="W/m^2", & 96 | l_silhs=.false., grid_kind=stats_rad_zm ) 97 | k = k + 1 98 | 99 | case( 'fuswcl' ) 100 | ifuswcl = k 101 | call stat_assign( var_index=ifuswcl, var_name="fuswcl", & 102 | var_description="Upward clear-sky SW flux [W/m^2]", var_units="W/m^2", & 103 | l_silhs=.false., grid_kind=stats_rad_zm ) 104 | k = k + 1 105 | 106 | case ('Frad_LW_rad') 107 | iFrad_LW_rad = k 108 | 109 | call stat_assign( var_index=iFrad_LW_rad, var_name="Frad_LW_rad", & 110 | var_description="Net long-wave radiative flux [W/m^2]", var_units="W/m^2", & 111 | l_silhs=.false., grid_kind=stats_rad_zm ) 112 | k = k + 1 113 | 114 | case ('Frad_SW_rad') 115 | iFrad_SW_rad = k 116 | 117 | call stat_assign( var_index=iFrad_SW_rad, var_name="Frad_SW_rad", & 118 | var_description="Net short-wave radiative flux [W/m^2]", var_units="W/m^2", & 119 | l_silhs=.false., grid_kind=stats_rad_zm ) 120 | k = k + 1 121 | 122 | case ('Frad_SW_up_rad') 123 | iFrad_SW_up_rad = k 124 | 125 | call stat_assign( var_index=iFrad_SW_up_rad, var_name="Frad_SW_up_rad", & 126 | var_description="Short-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & 127 | l_silhs=.false., grid_kind=stats_rad_zm ) 128 | k = k + 1 129 | 130 | case ('Frad_LW_up_rad') 131 | iFrad_LW_up_rad = k 132 | 133 | call stat_assign( var_index=iFrad_LW_up_rad, var_name="Frad_LW_up_rad", & 134 | var_description="Long-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & 135 | l_silhs=.false., grid_kind=stats_rad_zm ) 136 | k = k + 1 137 | 138 | case ('Frad_SW_down_rad') 139 | iFrad_SW_down_rad = k 140 | 141 | call stat_assign( var_index=iFrad_SW_down_rad, var_name="Frad_SW_down_rad", & 142 | var_description="Short-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & 143 | l_silhs=.false., grid_kind=stats_rad_zm ) 144 | k = k + 1 145 | 146 | case ('Frad_LW_down_rad') 147 | iFrad_LW_down_rad = k 148 | 149 | call stat_assign( var_index=iFrad_LW_down_rad, var_name="Frad_LW_down_rad", & 150 | var_description="Long-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & 151 | l_silhs=.false., grid_kind=stats_rad_zm ) 152 | k = k + 1 153 | 154 | case default 155 | 156 | write(fstderr,*) 'Error: unrecognized variable in vars_rad_zm: ', trim( vars_rad_zm(i) ) 157 | 158 | l_error = .true. ! This will stop the run. 159 | 160 | 161 | end select 162 | 163 | end do 164 | 165 | return 166 | end subroutine stats_init_rad_zm 167 | 168 | end module stats_rad_zm_module 169 | -------------------------------------------------------------------------------- /stats_rad_zt_module.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | 5 | module stats_rad_zt_module 6 | 7 | implicit none 8 | 9 | private ! Default Scope 10 | 11 | public :: stats_init_rad_zt 12 | 13 | ! Constant parameters 14 | integer, parameter, public :: nvarmax_rad_zt = 250 ! Maximum variables allowed 15 | 16 | contains 17 | 18 | !----------------------------------------------------------------------- 19 | subroutine stats_init_rad_zt( vars_rad_zt, l_error ) 20 | 21 | ! Description: 22 | ! Initializes array indices for stats_zt 23 | ! 24 | ! References: 25 | ! None 26 | !----------------------------------------------------------------------- 27 | 28 | use constants_clubb, only: & 29 | fstderr ! Constant(s) 30 | 31 | use stats_variables, only: & 32 | stats_rad_zt, & 33 | iT_in_K_rad, & ! Variable(s) 34 | ircil_rad, & 35 | io3l_rad, & 36 | irsm_rad, & 37 | ircm_in_cloud_rad, & 38 | icloud_frac_rad, & 39 | iice_supersat_frac_rad, & 40 | iradht_rad, & 41 | iradht_LW_rad, & 42 | iradht_SW_rad, & 43 | ip_in_mb_rad, & 44 | isp_humidity_rad 45 | 46 | use stats_type_utilities, only: & 47 | stat_assign ! Procedure 48 | 49 | implicit none 50 | 51 | ! Input Variable 52 | character(len= * ), dimension(nvarmax_rad_zt), intent(in) :: vars_rad_zt 53 | 54 | ! Input/Output Variable 55 | logical, intent(inout) :: l_error 56 | 57 | ! Local Varables 58 | integer :: i, k 59 | 60 | ! ---- Begin Code ---- 61 | 62 | ! Default initialization for array indices for stats_rad_zt 63 | 64 | iT_in_K_rad = 0 65 | ircil_rad = 0 66 | io3l_rad = 0 67 | irsm_rad = 0 68 | ircm_in_cloud_rad = 0 69 | icloud_frac_rad = 0 70 | iice_supersat_frac_rad = 0 71 | iradht_rad = 0 72 | iradht_LW_rad = 0 73 | iradht_SW_rad = 0 74 | ip_in_mb_rad = 0 75 | isp_humidity_rad = 0 76 | 77 | 78 | ! Assign pointers for statistics variables stats_rad_zt 79 | 80 | k = 1 81 | do i=1,stats_rad_zt%num_output_fields 82 | 83 | select case ( trim(vars_rad_zt(i)) ) 84 | 85 | case ('T_in_K_rad') 86 | iT_in_K_rad = k 87 | 88 | call stat_assign( var_index=iT_in_K_rad, var_name="T_in_K_rad", & 89 | var_description="Temperature [K]", var_units="K", l_silhs=.false., & 90 | grid_kind=stats_rad_zt ) 91 | k = k + 1 92 | 93 | case ('rcil_rad') 94 | ircil_rad = k 95 | 96 | call stat_assign( var_index=ircil_rad, var_name="rcil_rad", & 97 | var_description="Ice mixing ratio [kg/kg]", var_units="kg/kg", l_silhs=.false., & 98 | grid_kind=stats_rad_zt ) 99 | k = k + 1 100 | 101 | case ('o3l_rad') 102 | io3l_rad = k 103 | 104 | call stat_assign( var_index=io3l_rad, var_name="o3l_rad", & 105 | var_description="Ozone mixing ratio [kg/kg]", var_units="kg/kg", l_silhs=.false., & 106 | grid_kind=stats_rad_zt ) 107 | k = k + 1 108 | 109 | case ('rsm_rad') 110 | irsm_rad = k 111 | 112 | call stat_assign( var_index=irsm_rad, var_name="rsm_rad", & 113 | var_description="Snow water mixing ratio [kg/kg]", var_units="kg/kg", & 114 | l_silhs=.false., grid_kind=stats_rad_zt ) 115 | k = k + 1 116 | 117 | case ('rcm_in_cloud_rad') 118 | ircm_in_cloud_rad = k 119 | 120 | call stat_assign( var_index=ircm_in_cloud_rad, var_name="rcm_in_cloud_rad", & 121 | var_description="rcm in cloud layer [kg/kg]", var_units="kg/kg", l_silhs=.false., & 122 | grid_kind=stats_rad_zt ) 123 | k = k + 1 124 | 125 | case ('cloud_frac_rad') 126 | icloud_frac_rad = k 127 | 128 | call stat_assign( var_index=icloud_frac_rad, var_name="cloud_frac_rad", & 129 | var_description="Cloud fraction (between 0 and 1) [-]", var_units="count", & 130 | l_silhs=.false., grid_kind=stats_rad_zt ) 131 | k = k + 1 132 | 133 | case ('ice_supersat_frac_rad') 134 | iice_supersat_frac_rad = k 135 | 136 | call stat_assign( var_index=iice_supersat_frac_rad, var_name="ice_supersat_frac_rad", & 137 | var_description="Ice cloud fraction (between 0 and 1) [-]", var_units="count", & 138 | l_silhs=.false., grid_kind=stats_rad_zt ) 139 | k = k + 1 140 | 141 | case ('radht_rad') 142 | iradht_rad = k 143 | 144 | call stat_assign( var_index=iradht_rad, var_name="radht_rad", & 145 | var_description="Total radiative heating rate [K/s]", var_units="K/s", & 146 | l_silhs=.false., grid_kind=stats_rad_zt ) 147 | k = k + 1 148 | 149 | case ('radht_LW_rad') 150 | iradht_LW_rad = k 151 | 152 | call stat_assign( var_index=iradht_LW_rad, var_name="radht_LW_rad", & 153 | var_description="Long-wave radiative heating rate [K/s]", var_units="K/s", & 154 | l_silhs=.false., grid_kind=stats_rad_zt ) 155 | k = k + 1 156 | 157 | case ('radht_SW_rad') 158 | iradht_SW_rad = k 159 | 160 | call stat_assign( var_index=iradht_SW_rad, var_name="radht_SW_rad", & 161 | var_description="Short-wave radiative heating rate [K/s]", var_units="K/s", & 162 | l_silhs=.false., grid_kind=stats_rad_zt ) 163 | k = k + 1 164 | 165 | case ('p_in_mb_rad') 166 | ip_in_mb_rad = k 167 | 168 | call stat_assign( var_index=ip_in_mb_rad, var_name="p_in_mb_rad", & 169 | var_description="Pressure [hPa]", var_units="hPa", & 170 | l_silhs=.false., grid_kind=stats_rad_zt ) 171 | k = k + 1 172 | 173 | case ('sp_humidity_rad') 174 | isp_humidity_rad = k 175 | 176 | call stat_assign( var_index=isp_humidity_rad, var_name="sp_humidity_rad", & 177 | var_description="Specific humidity [kg/kg]", var_units="kg/kg", & 178 | l_silhs=.false., grid_kind=stats_rad_zt ) 179 | k = k + 1 180 | 181 | case default 182 | 183 | write(fstderr,*) 'Error: unrecognized variable in vars_rad_zt: ', trim( vars_rad_zt(i) ) 184 | 185 | l_error = .true. ! This will stop the run. 186 | 187 | 188 | end select 189 | 190 | end do 191 | 192 | return 193 | end subroutine stats_init_rad_zt 194 | 195 | end module stats_rad_zt_module 196 | -------------------------------------------------------------------------------- /file_functions.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module file_functions 5 | 6 | implicit none 7 | 8 | public :: file_read_1d, file_read_2d 9 | 10 | private ! Default Scope 11 | 12 | contains 13 | 14 | !=============================================================================== 15 | subroutine file_read_1d( file_unit, path_and_filename, & 16 | num_datapts, entries_per_line, variable ) 17 | 18 | ! Description: 19 | ! This subroutine reads in values from a data file with a number of 20 | ! rows and a declared number of columns (entries_per_line) of data. 21 | ! It reads in the data in the form of: 22 | ! 1 ==> (row 1, column 1); 2 ==> (row 1, column 2); etc. 23 | ! 24 | ! Example: a diagram of a data file with 18 total data points 25 | ! (DP1 to DP18), with 4 data points per row. 26 | ! 27 | ! i = 1 i = 2 i = 3 i = 4 28 | ! --------------------------------------- 29 | ! k = 1 | DP1 DP2 DP3 DP4 30 | ! | 31 | ! k = 2 | DP5 DP6 DP7 DP8 32 | ! | 33 | ! k = 3 | DP9 DP10 DP11 DP12 34 | ! | 35 | ! k = 4 | DP13 DP14 DP15 DP16 36 | ! | 37 | ! k = 5 | DP17 DP18 38 | ! 39 | ! See Michael Falk's comments below for more information. 40 | !----------------------------------------------------------------------- 41 | 42 | use clubb_precision, only: & 43 | core_rknd ! Variable(s) 44 | 45 | use constants_clubb, only: fstderr ! Constant(s) 46 | 47 | implicit none 48 | 49 | integer, intent(in) :: & 50 | file_unit, & ! Unit number of file being read. 51 | num_datapts, & ! Total number of data points being read in. 52 | entries_per_line ! Number of data points 53 | ! on one line of the file being read. 54 | 55 | character(*), intent(in) :: & 56 | path_and_filename ! Path to file and filename of file being read. 57 | 58 | real( kind = core_rknd ), dimension(num_datapts), intent(out) :: & 59 | variable ! Data values output into variable 60 | 61 | integer :: k ! Data file row number. 62 | integer :: i ! Data file column number. 63 | integer :: ierr 64 | 65 | ! ---- Begin Code ---- 66 | ! A ThreadLock is necessary here because FORTRAN can only have each file open on 67 | ! one file_unit at a time. For example, suppose we are running CLUBB in parallel 68 | ! with OpenMP using two threads. Suppose the first thread opens the file with file_unit = 0 69 | ! (file_unit is assigned a value based on thread number). 70 | ! Then suppose, that before thread 1 exits, thread 2 opens the same file with file_unit = 1. 71 | ! This would cause FORTRAN to crash. 72 | !$omp critical 73 | 74 | ! Open data file. 75 | open( unit=file_unit, file=path_and_filename, action='read', status='old', & 76 | iostat=ierr ) 77 | if ( ierr /= 0 ) then 78 | write(fstderr,*) "CLUBB encountered an error trying to open "//path_and_filename 79 | stop "Error opening forcings file" 80 | end if 81 | 82 | ! Michael Falk wrote this routine to read data files in a particular format for mpace_a. 83 | ! Each line has a specific number of values, until the last line in the file, which 84 | ! has the last few values and then ends. This reads the correct number of values on 85 | ! each line. 24 September 2007 86 | 87 | ! Loop over each full line of the input file. 88 | do k = 1, (num_datapts/entries_per_line), 1 89 | read(file_unit,*) ( variable( ((k-1)*entries_per_line) + i ), & 90 | i=1,entries_per_line ) 91 | enddo 92 | ! Read any partial line remaining. 93 | if ( mod(num_datapts,entries_per_line) /= 0 ) then 94 | k = (num_datapts/entries_per_line) 95 | read(file_unit,*) ( variable( (k*entries_per_line) + i ), & 96 | i=1,(mod(num_datapts,entries_per_line)) ) 97 | endif 98 | 99 | ! Close data file. 100 | close( file_unit ) 101 | 102 | !$omp end critical 103 | 104 | return 105 | 106 | end subroutine file_read_1d 107 | 108 | !=============================================================================== 109 | subroutine file_read_2d( device, file_path, file_dimension1, & 110 | file_dimension2, file_per_line, variable ) 111 | 112 | ! Description: 113 | ! Michael Falk wrote this routine to read data files in a particular format for mpace_a. 114 | ! The 2d mpace_a files list the (file_dimension2) values on a given vertical level, then 115 | ! moves to the next level to list its values. 116 | ! Each line has a specific number of values, until the last line on a level, which 117 | ! is short-- it has the last few values and then a line break. The next line, beginning 118 | ! the next level, is full-sized again. 24 September 2007 119 | ! 120 | ! References: 121 | ! None 122 | !------------------------------------------------------------------------------- 123 | 124 | use clubb_precision, only: & 125 | core_rknd ! Variable(s) 126 | 127 | implicit none 128 | 129 | integer, intent(in) :: & 130 | device, & 131 | file_dimension1, & 132 | file_dimension2, & 133 | file_per_line 134 | 135 | character(*), intent(in) :: & 136 | file_path 137 | 138 | real( kind = core_rknd ), dimension(file_dimension1,file_dimension2), intent(out) :: & 139 | variable 140 | 141 | integer i, j, k 142 | 143 | ! ---- Begin Code ---- 144 | 145 | variable = -999._core_rknd ! Initialize to nonsense values 146 | 147 | open(device,file=file_path,action='read') 148 | 149 | do k=1,(file_dimension1) ! For each level in the data file, 150 | do j=0,((file_dimension2/file_per_line)-1) 151 | read(device,*) (variable(k,(j*file_per_line)+i), & ! read file_per_line values in, 152 | i=1,file_per_line) 153 | end do 154 | read (device,*) (variable(k,(j*file_per_line)+i), & ! then read the partial line 155 | i=1,(mod(file_dimension2,file_per_line))) 156 | end do ! and then start over at the next level. 157 | 158 | close(device) 159 | 160 | return 161 | end subroutine file_read_2d 162 | 163 | !=============================================================================== 164 | 165 | end module file_functions 166 | -------------------------------------------------------------------------------- /pos_definite_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | module pos_definite_module 5 | 6 | implicit none 7 | 8 | public :: pos_definite_adj 9 | 10 | private ! Default Scope 11 | 12 | contains 13 | !----------------------------------------------------------------------- 14 | subroutine pos_definite_adj & 15 | ( dt, field_grid, field_np1, & 16 | flux_np1, field_n, field_pd, flux_pd ) 17 | ! Description: 18 | ! Applies a flux conservative positive definite scheme to a variable 19 | 20 | ! There are two possible grids: 21 | ! (1) flux on zm field on zt 22 | ! then 23 | ! flux_zt(k) = ( flux_zm(k) + flux_zm(k-1) ) / 2 24 | 25 | ! CLUBB grid Smolarkiewicz grid 26 | ! m +-- flux zm(k) --+ flux k + 1/2 27 | ! t +-- field zt(k) --+ field, fout k 28 | ! m +-- flux zm(k-1) --+ flux k - 1/2 29 | ! t +-- field zt(k-1) --+ 30 | 31 | ! (1) flux on zt field on zm 32 | ! then 33 | ! flux_zm(k) = ( flux_zt(k) + flux_zt(k+1) ) / 2 34 | 35 | ! CLUBB grid Smolarkiewicz grid 36 | ! m +-- field (k+1) --+ 37 | ! t +-- flux (k+1) --+ flux k + 1/2 38 | ! m +-- field (k) --+ field, fout k 39 | ! t +-- flux (k) --+ flux k - 1/2 40 | 41 | 42 | ! References: 43 | ! ``A Positive Definite Advection Scheme Obtained by 44 | ! Nonlinear Renormalization of the Advective Fluxes'' Smolarkiewicz (1989) 45 | ! Monthly Weather Review, Vol. 117, pp. 2626--2632 46 | !----------------------------------------------------------------------- 47 | 48 | use grid_class, only: & 49 | gr, & ! Variable(s) 50 | ddzt, & ! Function 51 | ddzm ! Function 52 | 53 | use constants_clubb, only : & 54 | eps, & ! Variable(s) 55 | zero_threshold 56 | 57 | use clubb_precision, only: & 58 | core_rknd ! Variable(s) 59 | 60 | use error_code, only: & 61 | clubb_at_least_debug_level ! Procedure 62 | 63 | implicit none 64 | 65 | ! External 66 | intrinsic :: eoshift, kind, any, min, max 67 | 68 | ! Input variables 69 | real( kind = core_rknd ), intent(in) :: & 70 | dt ! Timestep [s] 71 | 72 | character(len=2), intent(in) :: & 73 | field_grid ! The grid of the field, either zt or zm 74 | 75 | real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & 76 | field_n ! The field (e.g. rtm) at n, prior to n+1 77 | 78 | real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & 79 | flux_pd, & ! Budget of the change in the flux term due to the scheme 80 | field_pd ! Budget of the change in the mean term due to the scheme 81 | 82 | ! Output Variables 83 | 84 | real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & 85 | field_np1, & ! Field at n+1 (e.g. rtm in [kg/kg]) 86 | flux_np1 ! Flux applied to field 87 | 88 | ! Local Variables 89 | integer :: & 90 | kabove, & ! # of vertical levels the flux higher point resides 91 | kbelow ! # of vertical levels the flux lower point resides 92 | 93 | integer :: & 94 | k, kmhalf, kp1, kphalf ! Loop indices 95 | 96 | real( kind = core_rknd ), dimension(gr%nz) :: & 97 | flux_plus, flux_minus, & ! [F_i+1/2]^+ [F_i+1/2]^- in Smolarkiewicz 98 | fout, & ! (A4) F_i{}^OUT, or the sum flux_plus+flux_minus 99 | flux_lim, & ! Correction applied to flux at n+1 100 | field_nonlim ! Temporary variable for calculation 101 | 102 | real( kind = core_rknd ), dimension(gr%nz) :: & 103 | dz_over_dt ! Conversion factor [m/s] 104 | 105 | 106 | !----------------------------------------------------------------------- 107 | 108 | ! If all the values are positive or the values at the previous 109 | ! timestep were negative, then just return 110 | if ( .not. any( field_np1 < 0._core_rknd ) .or. any( field_n < 0._core_rknd ) ) then 111 | flux_pd = 0._core_rknd 112 | field_pd = 0._core_rknd 113 | return 114 | end if 115 | 116 | if ( field_grid == "zm" ) then 117 | kabove = 0 118 | kbelow = 1 119 | else if ( field_grid == "zt" ) then 120 | kabove = 1 121 | kbelow = 0 122 | else 123 | ! This is only necessary to avoid a compiler warning in g95 124 | kabove = -1 125 | kbelow = -1 126 | ! Joshua Fasching June 2008 127 | 128 | stop "Error in pos_def_adj" 129 | end if 130 | 131 | if ( clubb_at_least_debug_level( 1 ) ) then 132 | print *, "Correcting flux" 133 | end if 134 | 135 | do k = 1, gr%nz, 1 136 | 137 | ! Def. of F+ and F- from eqn 2 Smolarkowicz 138 | flux_plus(k) = max( zero_threshold, flux_np1(k) ) ! defined on flux levels 139 | flux_minus(k) = -min( zero_threshold, flux_np1(k) ) ! defined on flux levels 140 | 141 | if ( field_grid == "zm" ) then 142 | dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzm(k) ) / dt 143 | 144 | else if ( field_grid == "zt" ) then 145 | dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzt(k) ) / dt 146 | 147 | end if 148 | 149 | end do 150 | 151 | do k = 1, gr%nz, 1 152 | ! If the scalar variable is on the kth t-level, then 153 | ! Smolarkowicz's k+1/2 flux level is the kth m-level in CLUBB. 154 | 155 | ! If the scalar variable is on the kth m-level, then 156 | ! Smolarkowicz's k+1/2 flux level is the k+1 t-level in CLUBB. 157 | 158 | kphalf = min( k+kabove, gr%nz ) ! k+1/2 flux level 159 | kmhalf = max( k-kbelow, 1 ) ! k-1/2 flux level 160 | 161 | ! Eqn A4 from Smolarkowicz 162 | ! We place a limiter of eps to prevent a divide by zero, and 163 | ! after this calculation fout is on the scalar level, and 164 | ! fout is the total outward flux for the scalar level k. 165 | 166 | fout(k) = max( flux_plus(kphalf) + flux_minus(kmhalf), eps ) 167 | 168 | end do 169 | 170 | 171 | do k = 1, gr%nz, 1 172 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 173 | ! FIXME: 174 | ! We haven't tested this for negative values at the gr%nz level 175 | ! -dschanen 13 June 2008 176 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 177 | kphalf = min( k+kabove, gr%nz ) ! k+1/2 flux level 178 | kp1 = min( k+1, gr%nz ) ! k+1 scalar level 179 | 180 | ! Eqn 10 from Smolarkowicz (1989) 181 | 182 | flux_lim(kphalf) & 183 | = max( min( flux_np1(kphalf), & 184 | ( flux_plus(kphalf)/fout(k) ) * field_n(k) & 185 | * dz_over_dt(k) & 186 | ), & 187 | -( ( flux_minus(kphalf)/fout(kp1) ) * field_n(kp1) & 188 | * dz_over_dt(k) ) & 189 | ) 190 | end do 191 | 192 | ! Boundary conditions 193 | flux_lim(1) = flux_np1(1) 194 | flux_lim(gr%nz) = flux_np1(gr%nz) 195 | 196 | flux_pd = ( flux_lim - flux_np1 ) / dt 197 | 198 | field_nonlim = field_np1 199 | 200 | ! Apply change to field at n+1 201 | if ( field_grid == "zt" ) then 202 | 203 | field_np1 = -dt * ddzm( flux_lim - flux_np1 ) + field_np1 204 | 205 | else if ( field_grid == "zm" ) then 206 | 207 | field_np1 = -dt * ddzt( flux_lim - flux_np1 ) + field_np1 208 | 209 | end if 210 | 211 | ! Determine the total time tendency in field due to this calculation 212 | ! (for diagnostic purposes) 213 | field_pd = ( field_np1 - field_nonlim ) / dt 214 | 215 | ! Replace the non-limited flux with the limited flux 216 | flux_np1 = flux_lim 217 | 218 | return 219 | end subroutine pos_definite_adj 220 | 221 | end module pos_definite_module 222 | -------------------------------------------------------------------------------- /Skx_module.F90: -------------------------------------------------------------------------------- 1 | !------------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | module Skx_module 5 | 6 | implicit none 7 | 8 | private ! Default Scope 9 | 10 | public :: Skx_func, & 11 | LG_2005_ansatz, & 12 | xp3_LG_2005_ansatz 13 | 14 | contains 15 | 16 | !----------------------------------------------------------------------------- 17 | function Skx_func( xp2, xp3, x_tol ) & 18 | result( Skx ) 19 | 20 | ! Description: 21 | ! Calculate the skewness of x 22 | 23 | ! References: 24 | ! None 25 | !----------------------------------------------------------------------- 26 | 27 | use constants_clubb, only: & 28 | three_halves ! 3/2 29 | 30 | use parameters_tunable, only: & 31 | Skw_denom_coef, & ! Variable(s) 32 | Skw_max_mag ! Max magnitude of skewness 33 | 34 | use clubb_precision, only: & 35 | core_rknd ! Variable(s) 36 | 37 | use grid_class, only: & 38 | gr ! Variable Type 39 | 40 | implicit none 41 | 42 | ! External 43 | intrinsic :: min, max 44 | 45 | ! Parameter Constants 46 | ! Whether to apply clipping to the final result 47 | logical, parameter :: & 48 | l_clipping_kluge = .false. 49 | 50 | ! Input Variables 51 | real( kind = core_rknd ), intent(in) :: & 52 | x_tol ! x tolerance value [(x units)] 53 | 54 | real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & 55 | xp2, & ! [(x units)^2] 56 | xp3 ! [(x units)^3] 57 | 58 | ! Output Variable 59 | real( kind = core_rknd ), dimension(gr%nz) :: & 60 | Skx ! Skewness of x [-] 61 | 62 | ! Local Variable 63 | real( kind = core_rknd ) :: & 64 | Skx_denom_tol 65 | 66 | ! ---- Begin Code ---- 67 | 68 | Skx_denom_tol = Skw_denom_coef * x_tol**2 69 | 70 | !Skx = xp3 / ( max( xp2, x_tol**two ) )**three_halves 71 | ! Calculation of skewness to help reduce the sensitivity of this value to 72 | ! small values of xp2. 73 | Skx = xp3 / ( ( xp2 + Skx_denom_tol ) * sqrt( xp2 + Skx_denom_tol ) ) 74 | 75 | ! This is no longer needed since clipping is already 76 | ! imposed on wp2 and wp3 elsewhere in the code 77 | 78 | ! I turned clipping on in this local copy since thlp3 and rtp3 are not clipped 79 | if ( l_clipping_kluge ) then 80 | Skx = min( max( Skx, -Skw_max_mag ), Skw_max_mag ) 81 | end if 82 | 83 | return 84 | 85 | end function Skx_func 86 | 87 | !----------------------------------------------------------------------------- 88 | elemental function LG_2005_ansatz( Skw, wpxp, wp2, & 89 | xp2, beta, sigma_sqd_w, x_tol ) & 90 | result( Skx ) 91 | 92 | ! Description: 93 | ! Calculate the skewness of x using the diagnostic ansatz of Larson and 94 | ! Golaz (2005). 95 | 96 | ! References: 97 | ! Vincent E. Larson and Jean-Christophe Golaz, 2005: Using Probability 98 | ! Density Functions to Derive Consistent Closure Relationships among 99 | ! Higher-Order Moments. Mon. Wea. Rev., 133, 1023–1042. 100 | !----------------------------------------------------------------------- 101 | 102 | use constants_clubb, only: & 103 | three_halves, & ! Variable(s) 104 | one, & 105 | w_tol_sqd 106 | 107 | use clubb_precision, only: & 108 | core_rknd ! Variable(s) 109 | 110 | implicit none 111 | 112 | ! External 113 | intrinsic :: sqrt 114 | 115 | ! Input Variables 116 | real( kind = core_rknd ), intent(in) :: & 117 | Skw, & ! Skewness of w [-] 118 | wpxp, & ! Turbulent flux of x [m/s (x units)] 119 | wp2, & ! Variance of w [m^2/s^2] 120 | xp2, & ! Variance of x [(x units)^2] 121 | beta, & ! Tunable parameter [-] 122 | sigma_sqd_w, & ! Normalized variance of w [-] 123 | x_tol ! Minimum tolerance of x [(x units)] 124 | 125 | ! Output Variable 126 | real( kind = core_rknd ) :: & 127 | Skx ! Skewness of x [-] 128 | 129 | ! Local Variables 130 | real( kind = core_rknd ) :: & 131 | nrmlzd_corr_wx, & ! Normalized correlation of w and x [-] 132 | nrmlzd_Skw ! Normalized skewness of w [-] 133 | 134 | ! ---- Begin Code ---- 135 | ! weberjk, 8-July 2015. Commented this out for now. cgils was failing during some tests. 136 | 137 | ! Larson and Golaz (2005) eq. 16 138 | nrmlzd_corr_wx & 139 | = wpxp / sqrt( max( wp2, w_tol_sqd ) * max( xp2, x_tol**2 ) * ( one - sigma_sqd_w ) ) 140 | 141 | ! Larson and Golaz (2005) eq. 11 142 | nrmlzd_Skw = Skw / ( ( one - sigma_sqd_w) * sqrt( one - sigma_sqd_w ) ) 143 | 144 | ! Larson and Golaz (2005) eq. 33 145 | Skx = nrmlzd_Skw * nrmlzd_corr_wx & 146 | * ( beta + ( one - beta ) * nrmlzd_corr_wx**2 ) 147 | 148 | 149 | return 150 | 151 | end function LG_2005_ansatz 152 | 153 | !----------------------------------------------------------------------------- 154 | function xp3_LG_2005_ansatz( Skw_zt, wpxp_zt, wp2_zt, & 155 | xp2_zt, sigma_sqd_w_zt, x_tol ) & 156 | result( xp3 ) 157 | 158 | ! Description: 159 | ! Calculate after calculating the skewness of x using the ansatz of 160 | ! Larson and Golaz (2005). 161 | 162 | ! References: 163 | !----------------------------------------------------------------------- 164 | 165 | use grid_class, only: & 166 | gr ! Variable Type 167 | 168 | use constants_clubb, only: & 169 | three_halves ! Variable(s) 170 | 171 | use parameters_tunable, only: & 172 | beta, & ! Variable(s) 173 | Skw_denom_coef 174 | 175 | use clubb_precision, only: & 176 | core_rknd ! Variable(s) 177 | 178 | implicit none 179 | 180 | ! External 181 | intrinsic :: sqrt 182 | 183 | ! Input Variables 184 | real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & 185 | Skw_zt, & ! Skewness of w on thermodynamic levels [-] 186 | wpxp_zt, & ! Flux of x (interp. to t-levs.) [m/s(x units)] 187 | wp2_zt, & ! Variance of w (interp. to t-levs.) [m^2/s^2] 188 | xp2_zt, & ! Variance of x (interp. to t-levs.) [(x units)^2] 189 | sigma_sqd_w_zt ! Normalized variance of w (interp. to t-levs.) [-] 190 | 191 | real( kind = core_rknd ), intent(in) :: & 192 | x_tol ! Minimum tolerance of x [(x units)] 193 | 194 | ! Return Variable 195 | real( kind = core_rknd ), dimension(gr%nz) :: & 196 | xp3 ! (thermodynamic levels) [(x units)^3] 197 | 198 | ! Local Variable 199 | real( kind = core_rknd ), dimension(gr%nz) :: & 200 | Skx_zt, & ! Skewness of x on thermodynamic levels [-] 201 | Skx_denom_tol 202 | 203 | ! ---- Begin Code ---- 204 | 205 | Skx_denom_tol = Skw_denom_coef * x_tol**2 206 | 207 | ! Calculate skewness of x using the ansatz of LG05. 208 | Skx_zt(1:gr%nz) & 209 | = LG_2005_ansatz( Skw_zt(1:gr%nz), wpxp_zt(1:gr%nz), wp2_zt(1:gr%nz), & 210 | xp2_zt(1:gr%nz), beta, sigma_sqd_w_zt(1:gr%nz), x_tol ) 211 | 212 | ! Calculate using the reverse of the special sensitivity reduction 213 | ! formula in function Skx_func above. 214 | xp3 = Skx_zt * ( xp2_zt + Skx_denom_tol ) * sqrt( xp2_zt + Skx_denom_tol ) 215 | 216 | 217 | return 218 | 219 | end function xp3_LG_2005_ansatz 220 | 221 | !----------------------------------------------------------------------------- 222 | 223 | end module Skx_module 224 | -------------------------------------------------------------------------------- /endian.F90: -------------------------------------------------------------------------------- 1 | !---------------------------------------------------------------------- 2 | ! $Id$ 3 | !---------------------------------------------------------------------- 4 | module endian 5 | 6 | ! Description: 7 | ! big_endian and little_endian are parameters set at compile time 8 | ! based on whether the architecture is big or little endian. 9 | 10 | ! native_4byte_real is a portable byte re-ordering subroutine 11 | ! native_8byte_real is a knock off of the other routine for 8 bytes 12 | ! References: 13 | ! big_endian, little_endian from: 14 | ! 15 | !---------------------------------------------------------------------- 16 | 17 | implicit none 18 | 19 | interface byte_order_swap 20 | module procedure native_4byte_real, native_8byte_real 21 | end interface 22 | 23 | public :: big_endian, little_endian, byte_order_swap 24 | private :: native_4byte_real, native_8byte_real 25 | 26 | private ! Default scope 27 | ! External 28 | intrinsic :: selected_int_kind, ichar, transfer 29 | 30 | ! Parameters 31 | integer, parameter :: & 32 | i4 = 4, & ! 4 byte long integer 33 | ich = ichar( transfer( 1_i4, "a" ) ) 34 | 35 | logical, parameter :: & 36 | big_endian = ich == 0, & 37 | little_endian = .not. big_endian 38 | 39 | contains 40 | 41 | !------------------------------------------------------------------------------- 42 | ! SUBPROGRAM: native_4byte_real 43 | ! 44 | ! AUTHOR: David Stepaniak, NCAR/CGD/CAS 45 | ! DATE INITIATED: 29 April 2003 46 | ! LAST MODIFIED: 19 April 2005 47 | ! 48 | ! SYNOPSIS: Converts a 32 bit, 4 byte, REAL from big Endian to 49 | ! little Endian, or conversely from little Endian to big 50 | ! Endian. 51 | ! 52 | ! DESCRIPTION: This subprogram allows one to convert a 32 bit, 4 byte, 53 | ! REAL data element that was generated with, say, a big 54 | ! Endian processor (e.g. Sun/sparc, SGI/R10000, etc.) to its 55 | ! equivalent little Endian representation for use on little 56 | ! Endian processors (e.g. PC/Pentium running Linux). The 57 | ! converse, little Endian to big Endian, also holds. 58 | ! This conversion is accomplished by writing the 32 bits of 59 | ! the REAL data element into a generic 32 bit INTEGER space 60 | ! with the TRANSFER intrinsic, reordering the 4 bytes with 61 | ! the MVBITS intrinsic, and writing the reordered bytes into 62 | ! a new 32 bit REAL data element, again with the TRANSFER 63 | ! intrinsic. The following schematic illustrates the 64 | ! reordering process 65 | ! 66 | ! 67 | ! -------- -------- -------- -------- 68 | ! | D | | C | | B | | A | 4 Bytes 69 | ! -------- -------- -------- -------- 70 | ! | 71 | ! -> 1 bit 72 | ! || 73 | ! MVBITS 74 | ! || 75 | ! \/ 76 | ! 77 | ! -------- -------- -------- -------- 78 | ! | A | | B | | C | | D | 4 Bytes 79 | ! -------- -------- -------- -------- 80 | ! | | | | 81 | ! 24 16 8 0 <- bit 82 | ! position 83 | ! 84 | ! INPUT: realIn, a single 32 bit, 4 byte REAL data element. 85 | ! OUTPUT: realOut, a single 32 bit, 4 byte REAL data element, with 86 | ! reverse byte order to that of realIn. 87 | ! RESTRICTION: It is assumed that the default REAL data element is 88 | ! 32 bits / 4 bytes. 89 | ! 90 | !----------------------------------------------------------------------- 91 | SUBROUTINE native_4byte_real( realInOut ) 92 | 93 | IMPLICIT NONE 94 | 95 | ! Added by Eric Raut, Nov 2015 96 | integer, parameter :: & 97 | sp = selected_real_kind( 6 ), & ! 32-bit floating point kind 98 | int32 = selected_int_kind( 9 ) ! 32-bit integer kind 99 | 100 | REAL(KIND=sp), INTENT(INOUT):: realInOut ! a single 32 bit, 4 byte 101 | ! REAL data element 102 | ! Modified 8/1/05 103 | ! I found transfer does not work on pgf90 when -r8 is used and the mold 104 | ! is a literal constant real; Changed the mold "0.0" to "readInOut" 105 | ! -dschanen 106 | ! 107 | ! REAL, INTENT(IN):: realInOut 108 | ! REAL, INTENT(OUT) :: realOut 109 | ! ! a single 32 bit, 4 byte 110 | ! ! REAL data element, with 111 | ! ! reverse byte order to 112 | ! ! that of realIn 113 | !---------------------------------------------------------------------- 114 | ! Local variables (generic 32 bit INTEGER spaces): 115 | 116 | INTEGER(KIND=int32) :: i_element 117 | INTEGER(KIND=int32) :: i_element_br 118 | !---------------------------------------------------------------------- 119 | ! Transfer 32 bits of realIn to generic 32 bit INTEGER space: 120 | i_element = TRANSFER( realInOut, i_element ) 121 | !---------------------------------------------------------------------- 122 | ! Reverse order of 4 bytes in 32 bit INTEGER space: 123 | CALL MVBITS( i_element, 24, 8, i_element_br, 0 ) 124 | CALL MVBITS( i_element, 16, 8, i_element_br, 8 ) 125 | CALL MVBITS( i_element, 8, 8, i_element_br, 16 ) 126 | CALL MVBITS( i_element, 0, 8, i_element_br, 24 ) 127 | !---------------------------------------------------------------------- 128 | ! Transfer reversed order bytes to 32 bit REAL space (realOut): 129 | realInOut = TRANSFER( i_element_br, realInOut ) 130 | 131 | RETURN 132 | END SUBROUTINE native_4byte_real 133 | 134 | !------------------------------------------------------------------------------- 135 | subroutine native_8byte_real( realInOut ) 136 | 137 | ! Description: 138 | ! This is just a modification of the above routine for 64 bit data 139 | !------------------------------------------------------------------------------- 140 | 141 | ! Added by Eric Raut, Nov 2015 142 | use clubb_precision, only: & 143 | dp ! Constant (64-bit floating point kind) 144 | 145 | implicit none 146 | 147 | ! Added by Eric Raut, Nov 2015 148 | integer, parameter :: & 149 | int64 = selected_int_kind( 18 ) ! 64-bit integer kind 150 | 151 | ! External 152 | intrinsic :: mvbits, transfer 153 | 154 | real(kind=dp), intent(inout) :: realInOut ! a single 64 bit, 8 byte 155 | ! REAL data element 156 | ! Local variables (generic 64 bit INTEGER spaces): 157 | 158 | integer(kind=int64) :: i_element 159 | integer(kind=int64) :: i_element_br 160 | 161 | !------------------------------------------------------------------------------- 162 | 163 | ! Transfer 64 bits of realIn to generic 64 bit INTEGER space: 164 | i_element = transfer( realInOut, i_element ) 165 | 166 | ! Reverse order of 8 bytes in 64 bit INTEGER space: 167 | call mvbits( i_element, 56, 8, i_element_br, 0 ) 168 | call mvbits( i_element, 48, 8, i_element_br, 8 ) 169 | call mvbits( i_element, 40, 8, i_element_br, 16 ) 170 | call mvbits( i_element, 32, 8, i_element_br, 24 ) 171 | call mvbits( i_element, 24, 8, i_element_br, 32 ) 172 | call mvbits( i_element, 16, 8, i_element_br, 40 ) 173 | call mvbits( i_element, 8, 8, i_element_br, 48 ) 174 | call mvbits( i_element, 0, 8, i_element_br, 56 ) 175 | 176 | ! Transfer reversed order bytes to 64 bit REAL space (realOut): 177 | realInOut = transfer( i_element_br, realInOut ) 178 | 179 | return 180 | end subroutine native_8byte_real 181 | !------------------------------------------------------------------------------- 182 | 183 | end module endian 184 | 185 | !------------------------------------------------------------------------------- 186 | -------------------------------------------------------------------------------- /calendar.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | !$Id$ 3 | !=============================================================================== 4 | module calendar 5 | 6 | implicit none 7 | 8 | public :: gregorian2julian_date, julian2gregorian_date, & 9 | leap_year, compute_current_date, & 10 | gregorian2julian_day 11 | 12 | private ! Default Scope 13 | 14 | ! Constant Parameters 15 | 16 | ! 3 Letter Month Abbreviations 17 | character(len=3), dimension(12), public, parameter :: & 18 | month_names = (/'JAN','FEB','MAR','APR','MAY','JUN', & 19 | 'JUL','AUG','SEP','OCT','NOV','DEC'/) 20 | 21 | ! Number of days per month (Jan..Dec) for a non leap year 22 | integer, public, dimension(12), parameter :: & 23 | days_per_month = (/31, 28, 31, 30, 31, 30, & 24 | 31, 31, 30, 31, 30, 31/) 25 | 26 | contains 27 | !----------------------------------------------------------------------- 28 | integer function gregorian2julian_date( day, month, year ) 29 | ! 30 | ! Description: 31 | ! Computes the Julian Date (gregorian2julian), or the number of days since 32 | ! 1 January 4713 BC, given a Gregorian Calender date (day, month, year). 33 | ! 34 | ! Reference: 35 | ! Fliegel, H. F. and van Flandern, T. C., 36 | ! Communications of the ACM, Vol. 11, No. 10 (October, 1968) 37 | !---------------------------------------------------------------------- 38 | 39 | implicit none 40 | 41 | ! Input Variables 42 | integer, intent(in) :: & 43 | day, & ! Gregorian Calendar Day for given Month [dd] 44 | month, & ! Gregorian Calendar Month for given Year [mm] 45 | year ! Gregorian Calendar Year [yyyy] 46 | 47 | ! Local Variables 48 | integer :: I,J,K 49 | 50 | I = year 51 | J = month 52 | K = day 53 | 54 | gregorian2julian_date = K-32075+1461*(I+4800+(J-14)/12)/4+367* & 55 | (J-2-(J-14)/12*12)/12-3*((I+4900+(J-14)/12)/100)/4 56 | 57 | return 58 | end function gregorian2julian_date 59 | 60 | !------------------------------------------------------------------ 61 | subroutine julian2gregorian_date & 62 | ( julian_date, day, month, year ) 63 | ! 64 | ! Description: 65 | ! Computes the Gregorina Calendar date (day, month, year) 66 | ! given the Julian date (julian_date). 67 | ! 68 | ! Reference: 69 | ! Fliegel, H. F. and van Flandern, T. C., 70 | ! Communications of the ACM, Vol. 11, No. 10 (October, 1968) 71 | ! http://portal.acm.org/citation.cfm?id=364097 72 | !------------------------------------------------------------------ 73 | implicit none 74 | 75 | ! Input Variable(s) 76 | integer, intent(in) :: julian_date ! Julian date being converted from 77 | 78 | ! Output Variable(s) 79 | integer, intent(out):: & 80 | day, & ! Gregorian calender day for given Month [dd] 81 | month, & ! Gregorian calender month for given Year [mm] 82 | year ! Gregorian calender year [yyyy] 83 | 84 | ! Local Variables 85 | integer :: i, j, k, n, l 86 | 87 | ! ---- Begin Code ---- 88 | 89 | L = julian_date+68569 ! Known magic number 90 | N = 4*L/146097 ! Known magic number 91 | L = L-(146097*N+3)/4 ! Known magic number 92 | I = 4000*(L+1)/1461001 ! Known magic number 93 | L = L-1461*I/4+31 ! Known magic number 94 | J = 80*L/2447 ! Known magic number 95 | K = L-2447*J/80 ! Known magic number 96 | L = J/11 ! Known magic number 97 | J = J+2-12*L ! Known magic number 98 | I = 100*(N-49)+I+L ! Known magic number 99 | 100 | year = I 101 | month = J 102 | day = K 103 | 104 | return 105 | 106 | end subroutine julian2gregorian_date 107 | 108 | !----------------------------------------------------------------------------- 109 | logical function leap_year( year ) 110 | ! 111 | ! Description: 112 | ! Determines if the given year is a leap year. 113 | ! 114 | ! References: 115 | ! None 116 | !----------------------------------------------------------------------------- 117 | implicit none 118 | 119 | ! External 120 | intrinsic :: mod 121 | 122 | ! Input Variable(s) 123 | integer, intent(in) :: year ! Gregorian Calendar Year [yyyy] 124 | 125 | ! ---- Begin Code ---- 126 | 127 | leap_year = ( (mod( year, 4 ) == 0) .and. & 128 | (.not.( mod( year, 100 ) == 0 .and. mod( year, 400 ) /= 0 ) ) ) 129 | 130 | return 131 | end function leap_year 132 | 133 | !---------------------------------------------------------------------------- 134 | subroutine compute_current_date( previous_day, previous_month, & 135 | previous_year, & 136 | seconds_since_previous_date, & 137 | current_day, current_month, & 138 | current_year, & 139 | seconds_since_current_date ) 140 | ! 141 | ! Description: 142 | ! Computes the current Gregorian date from a previous date and 143 | ! the seconds that have transpired since that date. 144 | ! 145 | ! References: 146 | ! None 147 | !---------------------------------------------------------------------------- 148 | use clubb_precision, only: & 149 | time_precision ! Variable(s) 150 | 151 | use constants_clubb, only: & 152 | sec_per_day ! Variable(s) 153 | 154 | implicit none 155 | 156 | ! Input Variable(s) 157 | 158 | ! Previous date 159 | integer, intent(in) :: & 160 | previous_day, & ! Day of the month [dd] 161 | previous_month, & ! Month of the year [mm] 162 | previous_year ! Year [yyyy] 163 | 164 | real(kind=time_precision), intent(in) :: & 165 | seconds_since_previous_date ! [s] 166 | 167 | ! Output Variable(s) 168 | 169 | ! Current date 170 | integer, intent(out) :: & 171 | current_day, & ! Day of the month [dd] 172 | current_month, & ! Month of the year [mm] 173 | current_year ! Year [yyyy] 174 | 175 | real(kind=time_precision), intent(out) :: & 176 | seconds_since_current_date 177 | 178 | integer :: & 179 | days_since_1jan4713bc, & 180 | days_since_start 181 | 182 | ! ---- Begin Code ---- 183 | 184 | ! Using Julian dates we are able to add the days that the model 185 | ! has been running 186 | 187 | ! Determine the Julian Date of the starting date, 188 | ! written in Gregorian (day, month, year) form 189 | days_since_1jan4713bc = gregorian2julian_date( previous_day, & 190 | previous_month, previous_year ) 191 | 192 | ! Determine the amount of days that have passed since start date 193 | days_since_start = & 194 | floor( seconds_since_previous_date / real(sec_per_day,kind=time_precision) ) 195 | 196 | ! Set days_since_1jan4713 to the present Julian date 197 | days_since_1jan4713bc = days_since_1jan4713bc + days_since_start 198 | 199 | ! Set Present time to be seconds since the Julian date 200 | seconds_since_current_date = seconds_since_previous_date & 201 | - ( real( days_since_start, kind=time_precision ) * real(sec_per_day,kind=time_precision) ) 202 | 203 | call julian2gregorian_date & 204 | ( days_since_1jan4713bc, & 205 | current_day, current_month, current_year ) 206 | 207 | return 208 | end subroutine compute_current_date 209 | 210 | !------------------------------------------------------------------------------------- 211 | integer function gregorian2julian_day( day, month, year ) 212 | ! 213 | ! Description: 214 | ! This subroutine determines the Julian day (1-366) 215 | ! for a given Gregorian calendar date(e.g. July 1, 2008). 216 | ! 217 | ! References: 218 | ! None 219 | !------------------------------------------------------------------------------------- 220 | 221 | implicit none 222 | 223 | ! External 224 | intrinsic :: sum 225 | 226 | ! Input Variable(s) 227 | integer, intent(in) :: & 228 | day, & ! Day of the Month [dd] 229 | month, & ! Month of the Year [mm] 230 | year ! Year [yyyy] 231 | 232 | ! ---- Begin Code ---- 233 | 234 | ! Add the days from the previous months 235 | gregorian2julian_day = day + sum( days_per_month(1:month-1) ) 236 | 237 | ! Kluge for a leap year 238 | ! If the date were 29 Feb 2000 this would not increment julian_day 239 | ! However 01 March 2000 would need the 1 day bump 240 | if ( leap_year( year ) .and. month > 2 ) then 241 | gregorian2julian_day = gregorian2julian_day + 1 242 | end if 243 | 244 | if ( ( leap_year( year ) .and. gregorian2julian_day > 366 ) .or. & 245 | ( .not. leap_year( year ) .and. gregorian2julian_day > 365 ) ) then 246 | stop "Problem with Julian day conversion in gregorian2julian_day." 247 | end if 248 | 249 | return 250 | end function gregorian2julian_day 251 | 252 | end module calendar 253 | -------------------------------------------------------------------------------- /LY93_pdf.F90: -------------------------------------------------------------------------------- 1 | ! $Id$ 2 | !=============================================================================== 3 | module LY93_pdf 4 | 5 | ! Description: 6 | ! The multivariate, two-component PDF of Lewellen and Yoh (1993). 7 | 8 | ! References: 9 | ! Lewellen, W. S. and Yoh, S., 1993. Binormal Model of Ensemble Partial 10 | ! Cloudiness. J. Atmos. Sci., 50, 9, 1228--1237. 11 | !------------------------------------------------------------------------- 12 | 13 | implicit none 14 | 15 | public :: LY93_driver, & ! Procedure(s) 16 | calc_mixt_frac_LY93, & 17 | calc_params_LY93 18 | 19 | private ! default scope 20 | 21 | contains 22 | 23 | !============================================================================= 24 | subroutine LY93_driver( wm, rtm, thlm, wp2, rtp2, & ! In 25 | thlp2, Skw, Skrt, Skthl, & ! In 26 | mu_w_1, mu_w_2, & ! Out 27 | mu_rt_1, mu_rt_2, & ! Out 28 | mu_thl_1, mu_thl_2, & ! Out 29 | sigma_w_1_sqd, sigma_w_2_sqd, & ! Out 30 | sigma_rt_1_sqd, sigma_rt_2_sqd, & ! Out 31 | sigma_thl_1_sqd, sigma_thl_2_sqd, & ! Out 32 | mixt_frac ) ! Out 33 | 34 | ! Description: 35 | ! Calculates the mixture fraction and the PDF component means and PDF 36 | ! component variances of w, rt, and theta-l following Lewellen and Yoh. 37 | 38 | ! References: 39 | ! Lewellen, W. S. and Yoh, S., 1993. Binormal Model of Ensemble Partial 40 | ! Cloudiness. J. Atmos. Sci., 50, 9, 1228--1237. 41 | !----------------------------------------------------------------------- 42 | 43 | use grid_class, only: & 44 | gr ! Type(s) 45 | 46 | use clubb_precision, only: & 47 | core_rknd ! Variable(s) 48 | 49 | implicit none 50 | 51 | ! Input Variables 52 | real( kind = core_rknd), dimension(gr%nz), intent(in) :: & 53 | wm, & ! Mean of w (overall) [m/s] 54 | wp2, & ! Variance of w (overall) [m^2/s^2] 55 | Skw, & ! Skewness of w (overall) [-] 56 | rtm, & ! Mean of rt (overall) [kg/kg] 57 | rtp2, & ! Variance of rt (overall) [kg^2/kg^2] 58 | Skrt, & ! Skewness of rt (overall) [-] 59 | thlm, & ! Mean of thl (overall) [K] 60 | thlp2, & ! Variance of thl (overall) [K^2] 61 | Skthl ! Skewness of thl (overall) [-] 62 | 63 | ! Output Variables 64 | real( kind = core_rknd), dimension(gr%nz), intent(out) :: & 65 | mu_w_1, & ! Mean of w (1st PDF component) [m/s] 66 | mu_w_2, & ! Mean of w (2nd PDF component) [m/s] 67 | mu_rt_1, & ! Mean of rt (1st PDF component) [kg/kg] 68 | mu_rt_2, & ! Mean of rt (2nd PDF component) [kg/kg] 69 | mu_thl_1, & ! Mean of thl (1st PDF component) [K] 70 | mu_thl_2, & ! Mean of thl (2nd PDF component) [K] 71 | sigma_w_1_sqd, & ! Variance of w (1st PDF component) [m^2/s^2] 72 | sigma_w_2_sqd, & ! Variance of w (2nd PDF component) [m^2/s^2] 73 | sigma_rt_1_sqd, & ! Variance of rt (1st PDF component) [m^2/s^2] 74 | sigma_rt_2_sqd, & ! Variance of rt (2nd PDF component) [m^2/s^2] 75 | sigma_thl_1_sqd, & ! Variance of thl (1st PDF component) [m^2/s^2] 76 | sigma_thl_2_sqd, & ! Variance of thl (2nd PDF component) [m^2/s^2] 77 | mixt_frac ! Mixture fraction [-] 78 | 79 | ! Local Variables 80 | real( kind = core_rknd), dimension(gr%nz) :: & 81 | Sk_max ! Maximum of magnitudes of skewness [-] 82 | 83 | 84 | ! Find the maximum of the magnitudes of skewness. 85 | Sk_max = max( abs( Skw ), abs( Skrt ), abs( Skthl ) ) 86 | 87 | ! Calculate mixture fraction. 88 | mixt_frac = calc_mixt_frac_LY93( Sk_max ) 89 | 90 | ! Calculate the PDF parameters for w. 91 | call calc_params_LY93( wm, wp2, Skw, mixt_frac, & ! In 92 | mu_w_1, mu_w_2, & ! Out 93 | sigma_w_1_sqd, sigma_w_2_sqd ) ! Out 94 | 95 | ! Calculate the PDF parameters for rt. 96 | call calc_params_LY93( rtm, rtp2, Skrt, mixt_frac, & ! In 97 | mu_rt_1, mu_rt_2, & ! Out 98 | sigma_rt_1_sqd, sigma_rt_2_sqd ) ! Out 99 | 100 | ! Calculate the PDF parameters for thl. 101 | call calc_params_LY93( thlm, thlp2, Skthl, mixt_frac, & ! In 102 | mu_thl_1, mu_thl_2, & ! Out 103 | sigma_thl_1_sqd, sigma_thl_2_sqd ) ! Out 104 | 105 | 106 | return 107 | 108 | end subroutine LY93_driver 109 | 110 | !============================================================================= 111 | function calc_mixt_frac_LY93( Sk_max ) & 112 | result( mixt_frac ) 113 | 114 | ! Description: 115 | ! Calculates mixture fraction iteratively according to Lewellen and Yoh. 116 | 117 | ! References: 118 | ! Eq. (21) of Lewellen, W. S. and Yoh, S., 1993. Binormal Model of Ensemble 119 | ! Partial Cloudiness. J. Atmos. Sci., 50, 9, 1228--1237. 120 | !----------------------------------------------------------------------- 121 | 122 | use grid_class, only: & 123 | gr ! Type(s) 124 | 125 | use constants_clubb, only: & 126 | one, & ! Constant(s) 127 | three_fourths, & 128 | one_half, & 129 | zero 130 | 131 | use clubb_precision, only: & 132 | core_rknd ! Variable(s) 133 | 134 | implicit none 135 | 136 | ! Input Variable 137 | real( kind = core_rknd), dimension(gr%nz), intent(in) :: & 138 | Sk_max ! Maximum of magnitudes of skewness [-] 139 | 140 | ! Return Variable 141 | real( kind = core_rknd), dimension(gr%nz) :: & 142 | mixt_frac ! Mixture fraction [-] 143 | 144 | ! Local Variables 145 | real( kind = core_rknd) :: & 146 | mixt_frac_low, & ! Low value of mixture frac. in iterative solver [-] 147 | mixt_frac_high, & ! High value of mixture frac.in iterative solver [-] 148 | expr_equal_zero ! Expr. mixt_frac^6 - Sk_max * ( 1 - mixt_frac ) [-] 149 | 150 | ! Tolerance for mixture fraction in solver [-] 151 | real( kind = core_rknd) :: & 152 | LY_mixt_frac_tol = 1.0e-4_core_rknd 153 | 154 | integer :: k ! Vertical level index 155 | 156 | 157 | do k = 1, gr%nz, 1 158 | 159 | if ( Sk_max(k) > 0.84_core_rknd ) then 160 | 161 | mixt_frac_low = one_half 162 | mixt_frac_high = one 163 | 164 | do ! solve iteratively for mixture fraction 165 | 166 | mixt_frac(k) = one_half * ( mixt_frac_low + mixt_frac_high ) 167 | 168 | expr_equal_zero & 169 | = mixt_frac(k)**6 - Sk_max(k)**2 * ( one - mixt_frac(k) ) 170 | 171 | if ( abs( expr_equal_zero ) < LY_mixt_frac_tol ) then 172 | ! Mixture fraction has been solved for within the specificed 173 | ! tolerance. 174 | exit 175 | else 176 | if ( expr_equal_zero > zero ) then 177 | mixt_frac_high = mixt_frac(k) 178 | else ! expr_equal_zero < 0 179 | mixt_frac_low = mixt_frac(k) 180 | endif 181 | endif 182 | 183 | enddo ! solve iteratively for mixture fraction 184 | 185 | else ! Sk_max <= 0.84 186 | 187 | mixt_frac(k) = three_fourths 188 | 189 | endif 190 | 191 | enddo ! k = 1, gr%nz, 1 192 | 193 | 194 | return 195 | 196 | end function calc_mixt_frac_LY93 197 | 198 | !============================================================================= 199 | subroutine calc_params_LY93( xm, xp2, Skx, mixt_frac, & ! In 200 | mu_x_1, mu_x_2, & ! Out 201 | sigma_x_1_sqd, sigma_x_2_sqd ) ! Out 202 | 203 | ! Description: 204 | ! Calculates the PDF component means and PDF component variances for 205 | ! variable x according to Lewellen and Yoh. 206 | 207 | ! References: 208 | ! Eq. (14), Eq. (15), Eq. (16), Eq. (17), and Eq. (18) of 209 | ! Lewellen, W. S. and Yoh, S., 1993. Binormal Model of Ensemble Partial 210 | ! Cloudiness. J. Atmos. Sci., 50, 9, 1228--1237. 211 | !----------------------------------------------------------------------- 212 | 213 | use grid_class, only: & 214 | gr ! Type(s) 215 | 216 | use constants_clubb, only: & 217 | three, & ! Constant(s) 218 | one, & 219 | one_third, & 220 | zero 221 | 222 | use clubb_precision, only: & 223 | core_rknd ! Variable(s) 224 | 225 | implicit none 226 | 227 | ! Input Variables 228 | real( kind = core_rknd), dimension(gr%nz), intent(in) :: & 229 | xm, & ! Mean of x (overall) [units vary] 230 | xp2, & ! Variance of x (overall) [(units vary)^2] 231 | Skx, & ! Skewness of x (overall) [-] 232 | mixt_frac ! Mixture fraction [-] 233 | 234 | ! Output Variables 235 | real( kind = core_rknd), dimension(gr%nz), intent(out) :: & 236 | mu_x_1, & ! Mean of x (1st PDF component) [units vary] 237 | mu_x_2, & ! Mean of x (2nd PDF component) [units vary] 238 | sigma_x_1_sqd, & ! Variance of x (1st PDF component) [(units vary)^2] 239 | sigma_x_2_sqd ! Variance of x (2nd PDF component) [(units vary)^2] 240 | 241 | ! Local Variables 242 | real( kind = core_rknd), dimension(gr%nz) :: & 243 | sgn_Skx, & ! Sign of Skx [-] 244 | B_x ! Spread of the PDF component means function [units vary] 245 | 246 | 247 | ! Find the sign of Skx 248 | where ( Skx >= zero ) 249 | sgn_Skx = one 250 | elsewhere ! Skx < 0 251 | sgn_Skx = -one 252 | endwhere 253 | 254 | ! Calculate B_x, the LY function for the spread of the PDF component means. 255 | B_x = sgn_Skx * sqrt( xp2 ) & 256 | * ( abs( Skx ) / ( one - mixt_frac ) )**one_third 257 | 258 | ! Calculate the mean of x in the 1st PDF component. 259 | mu_x_1 = xm - B_x * ( one - mixt_frac ) 260 | 261 | ! Calculate the mean of x in the 2nd PDF component. 262 | mu_x_2 = xm + B_x * mixt_frac 263 | 264 | ! Calculate the variance of x in the 1st PDF component. 265 | sigma_x_1_sqd = xp2 - B_x**2 * ( one - mixt_frac ) & 266 | * ( one + mixt_frac + mixt_frac**2 ) & 267 | / ( three * mixt_frac ) 268 | 269 | ! Calculate the variance of x in the 2nd PDF component. 270 | sigma_x_2_sqd = xp2 + B_x**2 * ( one - mixt_frac )**2 / three 271 | 272 | 273 | return 274 | 275 | end subroutine calc_params_LY93 276 | 277 | !============================================================================= 278 | 279 | end module LY93_pdf 280 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | ====================================================================== 2 | Tag: clubb_release_b76a124_20200220_c20200320 3 | Tag creator: cacraig, Brian Griffin 4 | Date created: March 20, 2020 5 | 6 | Commands issued: 7 | git clone https://github.com/larson-group/clubb_release 8 | cd clubb_release 9 | git checkout b76a124 10 | 11 | CAM's mods applied to checked out code: 12 | --------------------------------- 13 | 14 | diff -r /home/cacraig/clubb_release/src/CLUBB_core/variables_prognostic_module.F90 /home/cacraig/cam6_2_017_clubb/src/physics/clubb_old/variables_prognostic_module.F90 15 | 178c178 16 | < type(pdf_parameter), allocatable, public, save :: & 17 | --- 18 | > type(pdf_parameter), public, save :: & 19 | 317,318d316 20 | < allocate( pdf_params ) 21 | < allocate( pdf_params_frz ) 22 | 492,495d489 23 | < 24 | < ! Variable for pdf closure scheme 25 | < deallocate( pdf_params ) 26 | < deallocate( pdf_params_frz ) 27 | 28 | NOTE - the following change was reapplied (no difference from the last CESM tag) 29 | **** error_code.F90 30 | 79c79 31 | < write(err_header,'(A7,I7,A20)') "Process ", getpid(), " -- CLUBB -- ERROR: " 32 | --- 33 | > write(err_header,'(A20)') " -- CLUBB -- ERROR: " 34 | 35 | ====================================================================== 36 | Tag: clubb_ncar_backwards_compat_20181205_c20191001 37 | Tag creator: cacraig, nusbaume 38 | Date created: Oct 1, 2019 39 | 40 | Commands issued: 41 | git clone https://github.com/larson-group/clubb_release 42 | cd clubb_release 43 | git checkout ncar_backwards_compat_20181205 44 | cd ~/clubb_release/src/CLUBB_core 45 | 46 | commit everything in this directory, adding in the ChangeLog from CAM's vendor tags repo 47 | 48 | CAM's mods applied to checked out code: 49 | --------------------------------- 50 | 51 | diff -r ./clubb_api_module.F90 /glade/u/home/cacraig/subcol_SILHS_UWM_cleanup-TRUNK/components/cam/src/physics/clubb/clubb_api_module.F90 52 | 144c144,153 53 | < l_rcm_supersat_adj 54 | --- 55 | > l_rcm_supersat_adj, & 56 | > l_damp_wp3_Skw_squared, & 57 | > l_predict_upwp_vpwp, & 58 | > l_min_wp2_from_corr_wx, & 59 | > l_min_xp2_from_corr_wx, & 60 | > l_upwind_xpyp_ta, & 61 | > l_vert_avg_closure, & 62 | > l_trapezoidal_rule_zt, & 63 | > l_trapezoidal_rule_zm, & 64 | > l_call_pdf_closure_twice 65 | 282c291,295 66 | < iup2_vp2_factor, iSkw_max_mag 67 | --- 68 | > iup2_vp2_factor, iSkw_max_mag, l_damp_wp3_Skw_squared, & 69 | > l_predict_upwp_vpwp, l_min_wp2_from_corr_wx, l_min_xp2_from_corr_wx, & 70 | > l_upwind_xpyp_ta, l_vert_avg_closure, l_trapezoidal_rule_zt, & 71 | > l_trapezoidal_rule_zm, l_call_pdf_closure_twice 72 | > 73 | diff -r ./model_flags.F90 /glade/u/home/cacraig/subcol_SILHS_UWM_cleanup-TRUNK/components/cam/src/physics/clubb/model_flags.F90 74 | 172c172 75 | < logical, private :: & 76 | --- 77 | > logical, public :: & 78 | 79 | 80 | **** error_code.F90 81 | 79c79 82 | < write(err_header,'(A7,I7,A20)') "Process ", getpid(), " -- CLUBB -- ERROR: " 83 | --- 84 | > write(err_header,'(A20)') " -- CLUBB -- ERROR: " 85 | 86 | ====================================================================== 87 | Tag: clubb_ncar_backwards_compat_20181205_c20190528 88 | Tag creator: cacraig 89 | Date created: May 28, 2019 90 | 91 | Summary of Change: 92 | Removed getpid() from error_code.F90 as not all systems have this available 93 | 94 | Reason for Change: 95 | hobart testing had a link error tryiing to getpid(). Removed this from the diagnostice write 96 | 97 | Mods applied to checked out code: 98 | --------------------------------- 99 | **** error_code.F90 100 | 79c79 101 | < write(err_header,'(A7,I7,A20)') "Process ", getpid(), " -- CLUBB -- ERROR: " 102 | --- 103 | > write(err_header,'(A20)') " -- CLUBB -- ERROR: " 104 | 105 | 106 | Status: 107 | M error_code.F90 108 | 109 | ====================================================================== 110 | ====================================================================== 111 | Tag: clubb_ncar_backwards_compat_20181205 112 | Tag creator: cacraig 113 | Date created: April 29, 2019 114 | Command(s) issued: 115 | git clone https://github.com/larson-group/clubb_release 116 | cd clubb_release 117 | git checkout ncar_backwards_compat_20181205 118 | 119 | svn co https://svn-ccsm-models.cgd.ucar.edu/clubb_core/vendor_trunk vendor_trunk-CLUBB 120 | cd vendor_trunk 121 | cp ~/clubb_release/src/CLUBB_core/* . 122 | 123 | 124 | Mods applied to checked out code: 125 | --------------------------------- 126 | 127 | diff -r ./clubb_api_module.F90 /glade/u/home/cacraig/subcol_SILHS_UWM_cleanup-TRUNK/components/cam/src/physics/clubb/clubb_api_module.F90 128 | 144c144,153 129 | < l_rcm_supersat_adj 130 | --- 131 | > l_rcm_supersat_adj, & 132 | > l_damp_wp3_Skw_squared, & 133 | > l_predict_upwp_vpwp, & 134 | > l_min_wp2_from_corr_wx, & 135 | > l_min_xp2_from_corr_wx, & 136 | > l_upwind_xpyp_ta, & 137 | > l_vert_avg_closure, & 138 | > l_trapezoidal_rule_zt, & 139 | > l_trapezoidal_rule_zm, & 140 | > l_call_pdf_closure_twice 141 | 282c291,295 142 | < iup2_vp2_factor, iSkw_max_mag 143 | --- 144 | > iup2_vp2_factor, iSkw_max_mag, l_damp_wp3_Skw_squared, & 145 | > l_predict_upwp_vpwp, l_min_wp2_from_corr_wx, l_min_xp2_from_corr_wx, & 146 | > l_upwind_xpyp_ta, l_vert_avg_closure, l_trapezoidal_rule_zt, & 147 | > l_trapezoidal_rule_zm, l_call_pdf_closure_twice 148 | > 149 | diff -r ./model_flags.F90 /glade/u/home/cacraig/subcol_SILHS_UWM_cleanup-TRUNK/components/cam/src/physics/clubb/model_flags.F90 150 | 172c172 151 | < logical, private :: & 152 | --- 153 | > logical, public :: & 154 | 155 | 156 | Status: 157 | A LY93_pdf.F90 158 | M Nc_Ncn_eqns.F90 159 | M Skx_module.F90 160 | M T_in_K_module.F90 161 | A adg1_adg2_3d_luhar_pdf.F90 162 | M advance_clubb_core_module.F90 163 | M advance_helper_module.F90 164 | M advance_windm_edsclrm_module.F90 165 | M advance_wp2_wp3_module.F90 166 | M advance_xm_wpxp_module.F90 167 | M advance_xp2_xpyp_module.F90 168 | A advance_xp3_module.F90 169 | D anl_erf.F90 170 | M array_index.F90 171 | M calc_roots.F90 172 | M calendar.F90 173 | M clip_explicit.F90 174 | M clip_semi_implicit.F90 175 | M clubb_api_module.F90 176 | M clubb_precision.F90 177 | M constants_clubb.F90 178 | M corr_varnce_module.F90 179 | M csr_matrix_module.F90 180 | M diagnose_correlations_module.F90 181 | M diffusion.F90 182 | M endian.F90 183 | M error_code.F90 184 | M file_functions.F90 185 | M fill_holes.F90 186 | M gmres_cache.F90 187 | M gmres_wrap.F90 188 | M grid_class.F90 189 | M hydromet_pdf_parameter_module.F90 190 | M index_mapping.F90 191 | M input_names.F90 192 | M input_reader.F90 193 | M interpolation.F90 194 | M lapack_wrap.F90 195 | M matrix_operations.F90 196 | M mean_adv.F90 197 | M mixing_length.F90 198 | M model_flags.F90 199 | M mono_flux_limiter.F90 200 | A new_pdf.F90 201 | A new_pdf_main.F90 202 | A new_tsdadg_pdf.F90 203 | M numerical_check.F90 204 | M output_grads.F90 205 | M output_netcdf.F90 206 | M parameter_indices.F90 207 | M parameters_model.F90 208 | M parameters_tunable.F90 209 | M pdf_closure_module.F90 210 | M pdf_parameter_module.F90 211 | M pdf_utilities.F90 212 | M pos_definite_module.F90 213 | M precipitation_fraction.F90 214 | M recl.inc 215 | M saturation.F90 216 | M setup_clubb_pdf_params.F90 217 | M sigma_sqd_w_module.F90 218 | M sponge_layer_damping.F90 219 | M stat_file_module.F90 220 | M stats_clubb_utilities.F90 221 | M stats_lh_sfc_module.F90 222 | M stats_lh_zt_module.F90 223 | M stats_rad_zm_module.F90 224 | M stats_rad_zt_module.F90 225 | M stats_sfc_module.F90 226 | M stats_type.F90 227 | M stats_type_utilities.F90 228 | M stats_variables.F90 229 | M stats_zm_module.F90 230 | M stats_zt_module.F90 231 | M surface_varnce_module.F90 232 | A turbulent_adv_pdf.F90 233 | M variables_diagnostic_module.F90 234 | M variables_prognostic_module.F90 235 | 236 | 237 | ====================================================================== 238 | Tag: clubb_r8099 239 | Tag creator: bogensch 240 | Date created: May 17, 2016 241 | Command(s) issued: 242 | svn co https://svn-ccsm-models.cgd.ucar.edu/clubb_core/vendor_trunk 243 | cd vendor_trunk 244 | svn merge -r8029:8099 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/CLUBB_core 245 | 246 | Status: 247 | M ChangeLog 248 | M advance_clubb_core_module.F90 249 | M advance_helper_module.F90 250 | M advance_windm_edsclrm_module.F90 251 | M advance_wp2_wp3_module.F90 252 | M advance_xm_wpxp_module.F90 253 | M clubb_api_module.F90 254 | M model_flags.F90 255 | M parameter_indices.F90 256 | M parameters_tunable.F90 257 | M stats_variables.F90 258 | M stats_zm_module.F90 259 | M stats_zt_module.F90 260 | 261 | ====================================================================== 262 | Tag: clubb_r8029 263 | Tag creator: cacraig 264 | Date created: April 7, 2016 265 | Command(s) issued: 266 | svn co https://svn-ccsm-models.cgd.ucar.edu/clubb_core/vendor_trunk clubb_r8029-TRUNK 267 | cd clubb_r8029-TRUNK 268 | svn merge -r7416:8029 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/CLUBB_core 269 | svn resolve --accept=working Skw_module.F90 270 | svn delete Skw_module.F90 271 | 272 | Status: 273 | M ChangeLog 274 | A Skx_module.F90 275 | D Skw_module.F90 276 | M advance_clubb_core_module.F90 277 | M advance_helper_module.F90 278 | M advance_xm_wpxp_module.F90 279 | A calc_roots.F90 280 | M clubb_api_module.F90 281 | A code_timer_module.F90 282 | M constants_clubb.F90 283 | M corr_varnce_module.F90 284 | M csr_matrix_module.F90 285 | M endian.F90 286 | M file_functions.F90 287 | M gmres_cache.F90 288 | M grid_class.F90 289 | M hydromet_pdf_parameter_module.F90 290 | M input_reader.F90 291 | M interpolation.F90 292 | M matrix_operations.F90 293 | M model_flags.F90 294 | M mt95.f90 295 | M output_grads.F90 296 | M output_netcdf.F90 297 | M parameter_indices.F90 298 | M parameters_model.F90 299 | M parameters_tunable.F90 300 | M pdf_closure_module.F90 301 | M pdf_parameter_module.F90 302 | M pdf_utilities.F90 303 | A precipitation_fraction.F90 304 | M saturation.F90 305 | M setup_clubb_pdf_params.F90 306 | M sponge_layer_damping.F90 307 | M stat_file_module.F90 308 | M stats_clubb_utilities.F90 309 | M stats_lh_zt_module.F90 310 | M stats_sfc_module.F90 311 | M stats_type.F90 312 | M stats_type_utilities.F90 313 | M stats_variables.F90 314 | M stats_zm_module.F90 315 | M stats_zt_module.F90 316 | M variables_diagnostic_module.F90 317 | M variables_prognostic_module.F90 318 | 319 | ====================================================================== 320 | Tag: clubb_r7416 321 | Tag creator: cacraig 322 | Date created: April 7, 2016 323 | Command(s) issued: 324 | svn co -r7416 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/CLUBB_core clubb_r7416 325 | svn import clubb_r7416 http://svn-ccsm-models.cgd.ucar.edu/clubb_core_vendor_trunk -m"Initial checkout of revision 7416 326 | 327 | ====================================================================== 328 | -------------------------------------------------------------------------------- /calc_roots.F90: -------------------------------------------------------------------------------- 1 | !--------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module calc_roots 5 | 6 | implicit none 7 | 8 | public :: cubic_solve, & 9 | quadratic_solve, & 10 | cube_root 11 | 12 | private ! Set Default Scope 13 | 14 | contains 15 | 16 | !============================================================================= 17 | pure function cubic_solve( nz, a_coef, b_coef, c_coef, d_coef ) & 18 | result( roots ) 19 | 20 | ! Description: 21 | ! Solve for the roots of x in a cubic equation. 22 | ! 23 | ! The cubic equation has the form: 24 | ! 25 | ! f(x) = a*x^3 + b*x^2 + c*x + d; 26 | ! 27 | ! where a /= 0. When f(x) = 0, the cubic formula is used to solve: 28 | ! 29 | ! a*x^3 + b*x^2 + c*x + d = 0. 30 | ! 31 | ! The cubic formula is also called Cardano's Formula. 32 | ! 33 | ! The three solutions for x are: 34 | ! 35 | ! x(1) = -(1/3)*(b/a) + ( S + T ); 36 | ! x(2) = -(1/3)*(b/a) - (1/2) * ( S + T ) + (1/2)i * sqrt(3) * ( S - T ); 37 | ! x(3) = -(1/3)*(b/a) - (1/2) * ( S + T ) - (1/2)i * sqrt(3) * ( S - T ); 38 | ! 39 | ! where: 40 | ! 41 | ! S = ( R + sqrt( D ) )^(1/3); and 42 | ! T = ( R - sqrt( D ) )^(1/3). 43 | ! 44 | ! The determinant, D, is given by: 45 | ! 46 | ! D = R^2 + Q^3. 47 | ! 48 | ! The values of R and Q relate back to the a, b, c, and d coefficients: 49 | ! 50 | ! Q = ( 3*(c/a) - (b/a)^2 ) / 9; and 51 | ! R = ( 9*(b/a)*(c/a) - 27*(d/a) - 2*(b/a)^3 ) / 54. 52 | ! 53 | ! When D < 0, there are three unique, real-valued roots. When D = 0, there 54 | ! are three real-valued roots, but one root is a double root or a triple 55 | ! root. When D > 0, there is one real-valued root and there are two roots 56 | ! that are complex conjugates. 57 | 58 | ! References: 59 | ! http://mathworld.wolfram.com/CubicFormula.html 60 | !----------------------------------------------------------------------- 61 | 62 | use constants_clubb, only: & 63 | three, & ! Constant(s) 64 | two, & 65 | one_half, & 66 | one_third, & 67 | zero 68 | 69 | use clubb_precision, only: & 70 | core_rknd ! Variable(s) 71 | 72 | implicit none 73 | 74 | ! Input Variables 75 | integer, intent(in) :: & 76 | nz ! Number of vertical levels 77 | 78 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 79 | a_coef, & ! Coefficient a (of x^3) in a*x^3 + b*x^2 + c^x + d = 0 [-] 80 | b_coef, & ! Coefficient b (of x^2) in a*x^3 + b*x^2 + c^x + d = 0 [-] 81 | c_coef, & ! Coefficient c (of x) in a*x^3 + b*x^2 + c^x + d = 0 [-] 82 | d_coef ! Coefficient d in a*x^3 + b*x^2 + c^x + d = 0 [-] 83 | 84 | ! Return Variables 85 | complex( kind = core_rknd ), dimension(nz,3) :: & 86 | roots ! Roots of x that satisfy a*x^3 + b*x^2 + c*x + d = 0 [-] 87 | 88 | ! Local Variables 89 | real( kind = core_rknd ), dimension(nz) :: & 90 | cap_Q_coef, & ! Coefficient Q in cubic formula [-] 91 | cap_R_coef, & ! Coefficient R in cubic formula [-] 92 | determinant ! Determinant D in cubic formula [-] 93 | 94 | complex( kind = core_rknd ), dimension(nz) :: & 95 | sqrt_det, & ! Square root of determinant D in cubic formula [-] 96 | cap_S_coef, & ! Coefficient S in cubic formula [-] 97 | cap_T_coef ! Coefficient T in cubic formula [-] 98 | 99 | complex( kind = core_rknd ), parameter :: & 100 | i_cmplx = ( 0.0_core_rknd, 1.0_core_rknd ) ! i = sqrt(-1) 101 | 102 | complex( kind = core_rknd ) :: & 103 | sqrt_3, & ! Sqrt 3 (complex data type) 104 | one_half_cmplx, & ! 1/2 (complex data type) 105 | one_third_cmplx ! 1/3 (complex data type) 106 | 107 | 108 | ! Declare some constants as complex data types in order to prevent 109 | ! data-type conversion warning messages. 110 | sqrt_3 = cmplx( sqrt( three ), kind = core_rknd ) 111 | one_half_cmplx = cmplx( one_half, kind = core_rknd ) 112 | one_third_cmplx = cmplx( one_third, kind = core_rknd ) 113 | 114 | ! Find the value of the coefficient Q; where 115 | ! Q = ( 3*(c/a) - (b/a)^2 ) / 9. 116 | cap_Q_coef = ( three * (c_coef/a_coef) - (b_coef/a_coef)**2 ) & 117 | / 9.0_core_rknd 118 | 119 | ! Find the value of the coefficient R; where 120 | ! R = ( 9*(b/a)*(c/a) - 27*(d/a) - 2*(b/a)^3 ) / 54. 121 | cap_R_coef = ( 9.0_core_rknd * (b_coef/a_coef) * (c_coef/a_coef) & 122 | - 27.0_core_rknd * (d_coef/a_coef) & 123 | - two * (b_coef/a_coef)**3 ) / 54.0_core_rknd 124 | 125 | ! Find the value of the determinant D; where 126 | ! D = R^2 + Q^3. 127 | determinant = cap_Q_coef**3 + cap_R_coef**2 128 | 129 | ! Calculate the square root of the determinant. This will be a complex 130 | ! number. 131 | sqrt_det = sqrt( cmplx( determinant, kind = core_rknd ) ) 132 | 133 | ! Find the value of the coefficient S; where 134 | ! S = ( R + sqrt( D ) )^(1/3). 135 | cap_S_coef & 136 | = ( cmplx( cap_R_coef, kind = core_rknd ) + sqrt_det )**one_third_cmplx 137 | 138 | ! Find the value of the coefficient T; where 139 | ! T = ( R - sqrt( D ) )^(1/3). 140 | cap_T_coef & 141 | = ( cmplx( cap_R_coef, kind = core_rknd ) - sqrt_det )**one_third_cmplx 142 | 143 | ! Find the values of the roots. 144 | ! This root is always real-valued. 145 | ! x(1) = -(1/3)*(b/a) + ( S + T ). 146 | roots(:,1) & 147 | = - one_third_cmplx * cmplx( b_coef/a_coef, kind = core_rknd ) & 148 | + ( cap_S_coef + cap_T_coef ) 149 | 150 | ! This root is real-valued when D < 0 (even though the square root of the 151 | ! determinant is a complex number), as well as when D = 0 (when it is part 152 | ! of a double or triple root). When D > 0, this root is a complex number. 153 | ! It is the complex conjugate of roots(3). 154 | ! x(2) = -(1/3)*(b/a) - (1/2) * ( S + T ) + (1/2)i * sqrt(3) * ( S - T ). 155 | roots(:,2) & 156 | = - one_third_cmplx * cmplx( b_coef/a_coef, kind = core_rknd ) & 157 | - one_half_cmplx * ( cap_S_coef + cap_T_coef ) & 158 | + one_half_cmplx * i_cmplx * sqrt_3 * ( cap_S_coef - cap_T_coef ) 159 | 160 | ! This root is real-valued when D < 0 (even though the square root of the 161 | ! determinant is a complex number), as well as when D = 0 (when it is part 162 | ! of a double or triple root). When D > 0, this root is a complex number. 163 | ! It is the complex conjugate of roots(2). 164 | ! x(3) = -(1/3)*(b/a) - (1/2) * ( S + T ) - (1/2)i * sqrt(3) * ( S - T ). 165 | roots(:,3) & 166 | = - one_third_cmplx * cmplx( b_coef/a_coef, kind = core_rknd ) & 167 | - one_half_cmplx * ( cap_S_coef + cap_T_coef ) & 168 | - one_half_cmplx * i_cmplx * sqrt_3 * ( cap_S_coef - cap_T_coef ) 169 | 170 | 171 | return 172 | 173 | end function cubic_solve 174 | 175 | !============================================================================= 176 | pure function quadratic_solve( nz, a_coef, b_coef, c_coef ) & 177 | result( roots ) 178 | 179 | ! Description: 180 | ! Solve for the roots of x in a quadratic equation. 181 | ! 182 | ! The equation has the form: 183 | ! 184 | ! f(x) = a*x^2 + b*x + c; 185 | ! 186 | ! where a /= 0. When f(x) = 0, the quadratic formula is used to solve: 187 | ! 188 | ! a*x^2 + b*x + c = 0. 189 | ! 190 | ! The two solutions for x are: 191 | ! 192 | ! x(1) = ( -b + sqrt( b^2 - 4*a*c ) ) / (2*a); and 193 | ! x(2) = ( -b - sqrt( b^2 - 4*a*c ) ) / (2*a). 194 | ! 195 | ! The determinant, D, is given by: 196 | ! 197 | ! D = b^2 - 4*a*c. 198 | ! 199 | ! When D > 0, there are two unique, real-valued roots. When D = 0, there 200 | ! are two real-valued roots, but they are a double root. When D < 0, there 201 | ! there are two roots that are complex conjugates. 202 | 203 | ! References: 204 | !----------------------------------------------------------------------- 205 | 206 | use constants_clubb, only: & 207 | four, & ! Constant(s) 208 | two, & 209 | zero 210 | 211 | use clubb_precision, only: & 212 | core_rknd ! Variable(s) 213 | 214 | implicit none 215 | 216 | ! Input Variables 217 | integer, intent(in) :: & 218 | nz ! Number of vertical levels 219 | 220 | real( kind = core_rknd ), dimension(nz), intent(in) :: & 221 | a_coef, & ! Coefficient a (of x^2) in a*x^2 + b*x + c = 0 [-] 222 | b_coef, & ! Coefficient b (of x) in a*x^2 + b*x + c = 0 [-] 223 | c_coef ! Coefficient c in a*x^2 + b*x + c = 0 [-] 224 | 225 | ! Return Variables 226 | complex( kind = core_rknd ), dimension(nz,2) :: & 227 | roots ! Roots of x that satisfy a*x^2 + b*x + c = 0 [-] 228 | 229 | ! Local Variables 230 | real( kind = core_rknd ), dimension(nz) :: & 231 | determinant ! Determinant D in quadratic formula [-] 232 | 233 | complex( kind = core_rknd ), dimension(nz) :: & 234 | sqrt_det ! Square root of determinant D in quadratic formula [-] 235 | 236 | 237 | ! Find the value of the determinant D; where 238 | ! D = b^2 - 4*a*c. 239 | determinant = b_coef**2 - four * a_coef * c_coef 240 | 241 | ! Calculate the square root of the determinant. This will be a complex 242 | ! number. 243 | sqrt_det = sqrt( cmplx( determinant, kind = core_rknd ) ) 244 | 245 | ! Find the values of the roots. 246 | ! This root is real-valued when D > 0, as well as when D = 0 (when it is 247 | ! part of a double root). When D < 0, this root is a complex number. It is 248 | ! the complex conjugate of roots(2). 249 | ! x(1) = ( -b + sqrt( b^2 - 4*a*c ) ) / (2*a); and 250 | roots(:,1) = ( -cmplx( b_coef, kind = core_rknd ) + sqrt_det ) & 251 | / cmplx( two * a_coef, kind = core_rknd ) 252 | 253 | ! This root is real-valued when D > 0, as well as when D = 0 (when it is 254 | ! part of a double root). When D < 0, this root is a complex number. It is 255 | ! the complex conjugate of roots(1). 256 | ! x(2) = ( -b - sqrt( b^2 - 4*a*c ) ) / (2*a). 257 | roots(:,2) = ( -cmplx( b_coef, kind = core_rknd ) - sqrt_det ) & 258 | / cmplx( two * a_coef, kind = core_rknd ) 259 | 260 | 261 | return 262 | 263 | end function quadratic_solve 264 | 265 | !============================================================================= 266 | pure function cube_root( x ) 267 | 268 | ! Description: 269 | ! Calculates the cube root of x. 270 | ! 271 | ! When x >= 0, this code simply calculates x^(1/3). When x < 0, this code 272 | ! uses x^(1/3) = -|x|^(1/3). This eliminates numerical errors when the 273 | ! exponent of 1/3 is not treated as exactly 1/3, which would sometimes 274 | ! result in values of NaN. 275 | ! 276 | ! References: 277 | !----------------------------------------------------------------------- 278 | 279 | use constants_clubb, only: & 280 | one_third, & ! Constant(s) 281 | zero 282 | 283 | use clubb_precision, only: & 284 | core_rknd ! Variable(s) 285 | 286 | implicit none 287 | 288 | ! Input Variables 289 | real( kind = core_rknd ), intent(in) :: & 290 | x ! Variable x 291 | 292 | ! Return Variables 293 | real( kind = core_rknd ) :: & 294 | cube_root ! Cube root of x 295 | 296 | 297 | if ( x >= zero ) then 298 | cube_root = x**one_third 299 | else ! x < 0 300 | cube_root = -abs(x)**one_third 301 | endif ! x >= 0 302 | 303 | 304 | return 305 | 306 | end function cube_root 307 | 308 | !=============================================================================== 309 | 310 | end module calc_roots 311 | -------------------------------------------------------------------------------- /index_mapping.F90: -------------------------------------------------------------------------------- 1 | !--------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module index_mapping 5 | 6 | ! Description: 7 | ! Functions to map back and forth between the PDF arrays and the hydrometeor 8 | ! arrays. 9 | 10 | ! The “iiPDF” indices are used to index all PDF variates, including all 11 | ! hydrometeor variates. 12 | ! The “ii” indices are used to index hydrometeor arrays. 13 | ! The “ii” variates are a subset of the “iiPDF” variates. 14 | ! Conversions between the two sets of indices are done by the 15 | ! functions pdf2hydromet_idx and hydromet2pdf_idx below. 16 | ! 17 | ! ------------------------------------------------------------------------ 18 | ! 19 | ! iiPDF indices: 20 | ! 21 | ! Included indices: 22 | ! iiPDF_chi, iiPDF_eta, iiPDF_w, iiPDF_Ncn, iiPDF_rr, & all other hydrometeors 23 | ! 24 | ! Number of indices: pdf_dim 25 | ! 26 | ! Examples of arrays dimensioned by pdf_dim: 27 | ! mu_x_1_n, corr_array_n_cloud, . . . 28 | ! 29 | ! Declared as module variables in module array_index 30 | ! 31 | ! Initialized in subroutine setup_pdf_indices 32 | ! 33 | ! ---------------------------------------------------------------------- 34 | ! 35 | ! ii indices: 36 | ! 37 | ! Included indices: 38 | ! iirr, iiNr, iiri, iiNi, iirs, iiNs, iirg, iiNg 39 | ! 40 | ! Number of indices: hydromet_dim 41 | ! 42 | ! Examples of arrays dimensioned by hydromet_dim: 43 | ! hydromet, wphydrometp, . . . 44 | ! 45 | ! Declared as module variables in module array_index. 46 | ! 47 | ! Initialized in subroutine init_microphys 48 | ! 49 | ! ----------------------------------------------------------------------- 50 | ! 51 | ! References: 52 | ! None 53 | !------------------------------------------------------------------------- 54 | 55 | ! Hydrometeor array indices 56 | use array_index, only: & 57 | iirr, & ! Hydrometeor array index for rain water mixing ratio, rr 58 | iirs, & ! Hydrometeor array index for snow mixing ratio, rs 59 | iiri, & ! Hydrometeor array index for ice mixing ratio, ri 60 | iirg, & ! Hydrometeor array index for graupel mixing ratio, rg 61 | iiNr, & ! Hydrometeor array index for rain drop concentration, Nr 62 | iiNs, & ! Hydrometeor array index for snow concentration, Ns 63 | iiNi, & ! Hydrometeor array index for ice concentration, Ni 64 | iiNg, & ! Hydrometeor array index for graupel concentration, Ng 65 | ! PDF array indices 66 | iiPDF_rr, & ! PDF array index for rain water mixing ratio, rr 67 | iiPDF_rs, & ! PDF array index for snow mixing ratio, rs 68 | iiPDF_ri, & ! PDF array index for ice mixing ratio, ri 69 | iiPDF_rg, & ! PDF array index for graupel mixing ratio, rg 70 | iiPDF_Nr, & ! PDF array index for rain drop concentration, Nr 71 | iiPDF_Ns, & ! PDF array index for snow concentration, Ns 72 | iiPDF_Ni, & ! PDF array index for ice concentration, Ni 73 | iiPDF_Ng ! PDF array index for graupel concentration, Ng 74 | 75 | implicit none 76 | 77 | private ! Default Scope 78 | 79 | public :: pdf2hydromet_idx, & 80 | hydromet2pdf_idx, & 81 | rx2Nx_hm_idx, & 82 | Nx2rx_hm_idx, & 83 | mvr_hm_max 84 | 85 | contains 86 | 87 | !============================================================================= 88 | function pdf2hydromet_idx( pdf_idx ) result( hydromet_idx ) 89 | 90 | ! Description: 91 | ! Returns the position of a specific precipitating hydrometeor corresponding 92 | ! to the PDF index (pdf_idx) in the precipitating hydrometeor array 93 | ! (hydromet_idx). 94 | 95 | ! References: 96 | !----------------------------------------------------------------------- 97 | 98 | implicit none 99 | 100 | ! Input Variables 101 | integer, intent(in) :: & 102 | pdf_idx ! Index of a hydrometeor in the PDF array. 103 | 104 | ! Return Variable 105 | integer :: & 106 | hydromet_idx ! Index of a hydrometeor in the hydromet array. 107 | 108 | 109 | ! Initialize hydromet_idx 110 | hydromet_idx = 0 111 | 112 | if ( pdf_idx == iiPDF_rr ) then 113 | 114 | ! Index for rain water mixing ratio, rr. 115 | hydromet_idx = iirr 116 | 117 | elseif ( pdf_idx == iiPDF_Nr ) then 118 | 119 | ! Index for rain drop concentration, Nr. 120 | hydromet_idx = iiNr 121 | 122 | elseif ( pdf_idx == iiPDF_rs ) then 123 | 124 | ! Index for snow mixing ratio, rs. 125 | hydromet_idx = iirs 126 | 127 | elseif ( pdf_idx == iiPDF_Ns ) then 128 | 129 | ! Index for snow flake concentration, Ns. 130 | hydromet_idx = iiNs 131 | 132 | elseif ( pdf_idx == iiPDF_rg ) then 133 | 134 | ! Index for graupel mixing ratio, rg. 135 | hydromet_idx = iirg 136 | 137 | elseif ( pdf_idx == iiPDF_Ng ) then 138 | 139 | ! Index for graupel concentration, Ng. 140 | hydromet_idx = iiNg 141 | 142 | elseif ( pdf_idx == iiPDF_ri ) then 143 | 144 | ! Index for ice mixing ratio, ri. 145 | hydromet_idx = iiri 146 | 147 | elseif ( pdf_idx == iiPDF_Ni ) then 148 | 149 | ! Index for ice concentration, Ni. 150 | hydromet_idx = iiNi 151 | 152 | endif 153 | 154 | 155 | return 156 | 157 | end function pdf2hydromet_idx 158 | 159 | !============================================================================= 160 | function hydromet2pdf_idx( hydromet_idx ) result( pdf_idx ) 161 | 162 | ! Description: 163 | ! Returns the position of a specific precipitating hydrometeor corresponding 164 | ! to the precipitating hydrometeor index (hydromet_idx) in the PDF array 165 | ! (pdf_idx). 166 | 167 | ! References: 168 | !----------------------------------------------------------------------- 169 | 170 | implicit none 171 | 172 | ! Input Variable 173 | integer, intent(in) :: & 174 | hydromet_idx ! Index of a hydrometeor in the hydromet array. 175 | 176 | ! Return Variable 177 | integer :: & 178 | pdf_idx ! Index of a hydrometeor in the PDF array. 179 | 180 | 181 | ! Initialize pdf_idx. 182 | pdf_idx = 0 183 | 184 | if ( hydromet_idx == iirr ) then 185 | 186 | ! Index for rain water mixing ratio, rr. 187 | pdf_idx = iiPDF_rr 188 | 189 | elseif ( hydromet_idx == iiNr ) then 190 | 191 | ! Index for rain drop concentration, Nr. 192 | pdf_idx = iiPDF_Nr 193 | 194 | elseif ( hydromet_idx == iiri ) then 195 | 196 | ! Index for ice mixing ratio, ri. 197 | pdf_idx = iiPDF_ri 198 | 199 | elseif ( hydromet_idx == iiNi ) then 200 | 201 | ! Index for ice concentration, Ni. 202 | pdf_idx = iiPDF_Ni 203 | 204 | elseif ( hydromet_idx == iirs ) then 205 | 206 | ! Index for snow mixing ratio, rs. 207 | pdf_idx = iiPDF_rs 208 | 209 | elseif ( hydromet_idx == iiNs ) then 210 | 211 | ! Index for snow flake concentration, Ns. 212 | pdf_idx = iiPDF_Ns 213 | 214 | elseif ( hydromet_idx == iirg ) then 215 | 216 | ! Index for graupel mixing ratio, rg. 217 | pdf_idx = iiPDF_rg 218 | 219 | elseif ( hydromet_idx == iiNg ) then 220 | 221 | ! Index for graupel concentration, Ng. 222 | pdf_idx = iiPDF_Ng 223 | 224 | endif 225 | 226 | 227 | return 228 | 229 | end function hydromet2pdf_idx 230 | 231 | !============================================================================= 232 | function rx2Nx_hm_idx( rx_idx ) result( Nx_idx ) 233 | 234 | ! Description: 235 | ! Returns the position in the hydrometeor array of the specific 236 | ! precipitating hydrometeor concentration (Nx_idx) corresponding to the 237 | ! precipitating hydrometeor mixing ratio (rx_idx) of the same species of 238 | ! precipitating hydrometeor (rain, ice, snow, or graupel). 239 | 240 | ! References: 241 | !----------------------------------------------------------------------- 242 | 243 | implicit none 244 | 245 | ! Input Variable 246 | integer, intent(in) :: & 247 | rx_idx ! Index of the mixing ratio in the hydrometeor array. 248 | 249 | ! Return Variable 250 | integer :: & 251 | Nx_idx ! Index of the concentration in the hydrometeor array. 252 | 253 | 254 | ! Initialize Nx_idx. 255 | Nx_idx = 0 256 | 257 | if ( rx_idx == iirr ) then 258 | 259 | ! Index for rain drop concentration, Nr. 260 | Nx_idx = iiNr 261 | 262 | elseif ( rx_idx == iiri ) then 263 | 264 | ! Index for ice crystal concentration, Ni. 265 | Nx_idx = iiNi 266 | 267 | elseif ( rx_idx == iirs ) then 268 | 269 | ! Index for snow flake concentration, Ns. 270 | Nx_idx = iiNs 271 | 272 | elseif ( rx_idx == iirg ) then 273 | 274 | ! Index for graupel concentration, Ng. 275 | Nx_idx = iiNg 276 | 277 | endif 278 | 279 | 280 | return 281 | 282 | end function rx2Nx_hm_idx 283 | 284 | !============================================================================= 285 | function Nx2rx_hm_idx( Nx_idx ) result( rx_idx ) 286 | 287 | ! Description: 288 | ! Returns the position in the hydrometeor array of the specific 289 | ! precipitating hydrometeor mixing ratio (rx_idx) corresponding to the 290 | ! precipitating hydrometeor concentration (Nx_idx) of the same species of 291 | ! precipitating hydrometeor (rain, ice, snow, or graupel). 292 | 293 | ! References: 294 | !----------------------------------------------------------------------- 295 | 296 | implicit none 297 | 298 | ! Input Variable 299 | integer, intent(in) :: & 300 | Nx_idx ! Index of the concentration in the hydrometeor array. 301 | 302 | ! Return Variable 303 | integer :: & 304 | rx_idx ! Index of the mixing ratio in the hydrometeor array. 305 | 306 | 307 | ! Initialize rx_idx. 308 | rx_idx = 0 309 | 310 | if ( Nx_idx == iiNr ) then 311 | 312 | ! Index for rain water mixing ratio, rr. 313 | rx_idx = iirr 314 | 315 | elseif ( Nx_idx == iiNi ) then 316 | 317 | ! Index for ice mixing ratio, ri. 318 | rx_idx = iiri 319 | 320 | elseif ( Nx_idx == iiNs ) then 321 | 322 | ! Index for snow mixing ratio, rs. 323 | rx_idx = iirs 324 | 325 | elseif ( Nx_idx == iiNg ) then 326 | 327 | ! Index for graupel mixing ratio, rg. 328 | rx_idx = iirg 329 | 330 | endif 331 | 332 | 333 | return 334 | 335 | end function Nx2rx_hm_idx 336 | 337 | !============================================================================= 338 | function mvr_hm_max( hydromet_idx ) result( mvr_hydromet_max ) 339 | 340 | ! Description: 341 | ! Returns the maximum allowable mean volume radius of a specific 342 | ! precipitating hydrometeor type (rain, ice, snow, or graupel) corresponding 343 | ! to the precipitating hydrometeor index, whether that index is for the 344 | ! mixing ratio or concentration associated with that hydrometeor type. 345 | 346 | ! References: 347 | !----------------------------------------------------------------------- 348 | 349 | use constants_clubb, only: & 350 | mvr_rain_max, & ! Constant(s) 351 | mvr_ice_max, & 352 | mvr_snow_max, & 353 | mvr_graupel_max, & 354 | zero 355 | 356 | use clubb_precision, only: & 357 | core_rknd ! Variable(s) 358 | 359 | implicit none 360 | 361 | ! Input Variable 362 | integer, intent(in) :: & 363 | hydromet_idx ! Index of a hydrometeor in the hydromet array. 364 | 365 | ! Return Variable 366 | real( kind = core_rknd ) :: & 367 | mvr_hydromet_max ! Maximum allowable mean volume radius [m] 368 | 369 | 370 | ! Initialize mvr_hydromet_max. 371 | mvr_hydromet_max = zero 372 | 373 | if ( hydromet_idx == iirr .or. hydromet_idx == iiNr ) then 374 | 375 | ! Maximum allowable mean volume radius for rain drops. 376 | mvr_hydromet_max = mvr_rain_max 377 | 378 | elseif ( hydromet_idx == iiri .or. hydromet_idx == iiNi ) then 379 | 380 | ! Maximum allowable mean volume radius for ice crystals. 381 | mvr_hydromet_max = mvr_ice_max 382 | 383 | elseif ( hydromet_idx == iirs .or. hydromet_idx == iiNs ) then 384 | 385 | ! Maximum allowable mean volume radius for snow flakes. 386 | mvr_hydromet_max = mvr_snow_max 387 | 388 | elseif ( hydromet_idx == iirg .or. hydromet_idx == iiNg ) then 389 | 390 | ! Maximum allowable mean volume radius for graupel. 391 | mvr_hydromet_max = mvr_graupel_max 392 | 393 | endif 394 | 395 | 396 | return 397 | 398 | end function mvr_hm_max 399 | 400 | !=============================================================================== 401 | 402 | end module index_mapping 403 | -------------------------------------------------------------------------------- /lapack_interfaces.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module lapack_interfaces 5 | 6 | ! This module acts as an interface to Lapack routines. It's main purpose 7 | ! is to make interfaces available to clubb that can handle both 8 | ! single and doulbe precision. This may be compiled along with Lapack 9 | ! source code, or along with a linked Lapack library such as MKL. 10 | 11 | implicit none 12 | 13 | public :: lapack_gbsv, lapack_gbsvx, & 14 | lapack_gtsv, lapack_gtsvx, & 15 | lapack_isnan, lapack_potrf, & 16 | lapack_poequ, lapack_laqsy, & 17 | lapack_syev, lapack_trmv 18 | 19 | private :: & 20 | dgbsv_wrap, sgbsv_wrap, & 21 | dgbsvx_wrap, sgbsvx_wrap, & 22 | dgtsv_wrap, sgtsv_wrap, & 23 | dgtsvx_wrap, sgtsvx_wrap, & 24 | disnan_wrap, sisnan_wrap, & 25 | dpotrf_wrap, spotrf_wrap, & 26 | dpoequ_wrap, spoequ_wrap, & 27 | dlaqsy_wrap, slaqsy_wrap, & 28 | dsyev_wrap, ssyev_wrap, & 29 | dtrmv_wrap, strmv_wrap 30 | 31 | ! Interface for Lapack general band solver, single or double precision 32 | interface lapack_gbsv 33 | module procedure dgbsv_wrap 34 | module procedure sgbsv_wrap 35 | end interface 36 | 37 | ! Interface for Lapack general band solver, expert version, single or double precision 38 | interface lapack_gbsvx 39 | module procedure dgbsvx_wrap 40 | module procedure sgbsvx_wrap 41 | end interface 42 | 43 | ! Interface for Lapack tridiagonal matrix solver, single or double precision 44 | interface lapack_gtsv 45 | module procedure dgtsv_wrap 46 | module procedure sgtsv_wrap 47 | end interface 48 | 49 | ! Interface for Lapack tridiagonal matrix solver, expert version, single or double precision 50 | interface lapack_gtsvx 51 | module procedure dgtsvx_wrap 52 | module procedure sgtsvx_wrap 53 | end interface 54 | 55 | ! Interface for Lapack nan check, single or double precision 56 | interface lapack_isnan 57 | module procedure disnan_wrap 58 | module procedure sisnan_wrap 59 | end interface 60 | 61 | ! Interface for Lapack's Cholesky factorization of a real symmetric positive definite 62 | ! matrix, single or double precision 63 | interface lapack_potrf 64 | module procedure dpotrf_wrap 65 | module procedure spotrf_wrap 66 | end interface 67 | 68 | ! Interface for Lapack routine to compute row and column scalings intended to 69 | ! equilibriate a symmetric positive definite matrix, single or doulbe precision 70 | interface lapack_poequ 71 | module procedure dpoequ_wrap 72 | module procedure spoequ_wrap 73 | end interface 74 | 75 | ! Interface for Lapack routine to equilibriate a symmetric matrix, single or double precision 76 | interface lapack_laqsy 77 | module procedure dlaqsy_wrap 78 | module procedure slaqsy_wrap 79 | end interface 80 | 81 | ! Interface for Lapack routine to compute all eigenvalues and, optionally, eigenvectors 82 | ! of a real symmetric matrix, single or double precision 83 | interface lapack_syev 84 | module procedure dsyev_wrap 85 | module procedure ssyev_wrap 86 | end interface 87 | 88 | ! Interface for Lapack routines to performe one of the following matrix-vector operations 89 | ! x := A*x, or x := A**T*x, 90 | ! where A is an upper or lower triangular matrix, single or double precision 91 | interface lapack_trmv 92 | module procedure dtrmv_wrap 93 | module procedure strmv_wrap 94 | end interface 95 | 96 | 97 | private ! Set Default Scope 98 | 99 | contains 100 | 101 | ! ==================== General Band Solver Wrappers ==================== 102 | 103 | ! Double precision wrapper 104 | subroutine dgbsv_wrap( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) 105 | 106 | implicit none 107 | 108 | external :: dgbsv 109 | 110 | integer info, kl, ku, ldab, ldb, n, nrhs 111 | integer ipiv( * ) 112 | double precision ab( ldab, * ), b( ldb, * ) 113 | 114 | call dgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) 115 | 116 | end subroutine dgbsv_wrap 117 | 118 | ! Single precision wrapper 119 | subroutine sgbsv_wrap( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) 120 | 121 | implicit none 122 | 123 | external :: sgbsv 124 | 125 | integer info, kl, ku, ldab, ldb, n, nrhs 126 | integer ipiv( * ) 127 | real ab( ldab, * ), b( ldb, * ) 128 | 129 | call sgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) 130 | 131 | end subroutine sgbsv_wrap 132 | 133 | 134 | ! ==================== Band Solver Expert Wrappers ==================== 135 | 136 | ! Double precision wrapper 137 | subroutine dgbsvx_wrap( fact, trans, n, kl, ku, nrhs, ab, ldab, afb, & 138 | ldafb, ipiv, equed, r, c, b, ldb, x, ldx, & 139 | rcond, ferr, berr, work, iwork, info ) 140 | implicit none 141 | 142 | external :: dgbsvx 143 | 144 | character equed, fact, trans 145 | integer info, kl, ku, ldab, ldafb, ldb, ldx, n, nrhs 146 | double precision rcond 147 | integer ipiv( * ), iwork( * ) 148 | double precision ab( ldab, * ), afb( ldafb, * ), b( ldb, * ), & 149 | berr( * ), c( * ), ferr( * ), r( * ), & 150 | work( * ), x( ldx, * ) 151 | 152 | call dgbsvx( fact, trans, n, kl, ku, nrhs, ab, ldab, afb, & 153 | ldafb, ipiv, equed, r, c, b, ldb, x, ldx, & 154 | rcond, ferr, berr, work, iwork, info ) 155 | 156 | end subroutine dgbsvx_wrap 157 | 158 | ! Single precision wrapper 159 | subroutine sgbsvx_wrap( fact, trans, n, kl, ku, nrhs, ab, ldab, afb, & 160 | ldafb, ipiv, equed, r, c, b, ldb, x, ldx, & 161 | rcond, ferr, berr, work, iwork, info ) 162 | implicit none 163 | 164 | external :: sgbsvx 165 | 166 | character equed, fact, trans 167 | integer info, kl, ku, ldab, ldafb, ldb, ldx, n, nrhs 168 | real rcond 169 | integer ipiv( * ), iwork( * ) 170 | real ab( ldab, * ), afb( ldafb, * ), b( ldb, * ), & 171 | berr( * ), c( * ), ferr( * ), r( * ), & 172 | work( * ), x( ldx, * ) 173 | 174 | call sgbsvx( fact, trans, n, kl, ku, nrhs, ab, ldab, afb, & 175 | ldafb, ipiv, equed, r, c, b, ldb, x, ldx, & 176 | rcond, ferr, berr, work, iwork, info ) 177 | 178 | end subroutine sgbsvx_wrap 179 | 180 | 181 | ! ==================== Tridiagonal Solver Wrappers ==================== 182 | 183 | ! Double precision wrapper 184 | subroutine dgtsv_wrap( n, nrhs, dl, d, du, b, ldb, info ) 185 | 186 | implicit none 187 | 188 | external :: dgtsv 189 | 190 | integer info, ldb, n, nrhs 191 | double precision b( ldb, * ), d( * ), dl( * ), du( * ) 192 | 193 | call dgtsv( n, nrhs, dl, d, du, b, ldb, info ) 194 | 195 | end subroutine dgtsv_wrap 196 | 197 | ! Single precision wrapper 198 | subroutine sgtsv_wrap( n, nrhs, dl, d, du, b, ldb, info ) 199 | 200 | implicit none 201 | 202 | external :: sgtsv 203 | 204 | integer info, ldb, n, nrhs 205 | real b( ldb, * ), d( * ), dl( * ), du( * ) 206 | 207 | call sgtsv( n, nrhs, dl, d, du, b, ldb, info ) 208 | 209 | end subroutine sgtsv_wrap 210 | 211 | 212 | ! ==================== Tridiagonal Solver Expert Wrappers ==================== 213 | 214 | ! Double precision wrapper 215 | subroutine dgtsvx_wrap( fact, trans, n, nrhs, dl, d, du, dlf, df, duf, & 216 | du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, & 217 | work, iwork, info ) 218 | implicit none 219 | 220 | external :: dgtsvx 221 | 222 | character fact, trans 223 | integer info, ldb, ldx, n, nrhs 224 | double precision rcond 225 | integer ipiv( * ), iwork( * ) 226 | double precision b( ldb, * ), berr( * ), d( * ), df( * ), & 227 | dl( * ), dlf( * ), du( * ), du2( * ), duf( * ), & 228 | ferr( * ), work( * ), x( ldx, * ) 229 | 230 | call dgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf, & 231 | du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, & 232 | work, iwork, info ) 233 | 234 | end subroutine dgtsvx_wrap 235 | 236 | ! Single precision wrapper 237 | subroutine sgtsvx_wrap( fact, trans, n, nrhs, dl, d, du, dlf, df, duf, & 238 | du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, & 239 | work, iwork, info ) 240 | implicit none 241 | 242 | external :: sgtsvx 243 | 244 | character fact, trans 245 | integer info, ldb, ldx, n, nrhs 246 | real rcond 247 | integer ipiv( * ), iwork( * ) 248 | real b( ldb, * ), berr( * ), d( * ), df( * ), & 249 | dl( * ), dlf( * ), du( * ), du2( * ), duf( * ), & 250 | ferr( * ), work( * ), x( ldx, * ) 251 | 252 | call sgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf, & 253 | du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, & 254 | work, iwork, info ) 255 | 256 | end subroutine sgtsvx_wrap 257 | 258 | 259 | ! ==================== NaN Check Wrappers ==================== 260 | 261 | ! Double precision wrapper 262 | !----------------------------------------------------------------------- 263 | logical function disnan_wrap( ndim, nrhs, variable ) 264 | 265 | ! Description: 266 | ! Check for NaN values in a variable using the LAPACK subroutines 267 | 268 | ! References: 269 | ! 270 | ! 271 | !----------------------------------------------------------------------- 272 | 273 | implicit none 274 | 275 | #ifdef NO_LAPACK_ISNAN /* Used for older LAPACK libraries that don't have sisnan/disnan */ 276 | 277 | integer, intent(in) :: & 278 | ndim, & ! Size of variable 279 | nrhs ! Number of right hand sides 280 | 281 | double precision, dimension(ndim,nrhs), intent(in) :: & 282 | variable ! Variable to check 283 | 284 | disnan_wrap = any( variable(:,1:nrhs) /= variable(:,1:nrhs) ) 285 | #else 286 | 287 | logical, external :: & 288 | disnan ! Procedure 289 | 290 | integer, intent(in) :: & 291 | ndim, & ! Size of variable 292 | nrhs ! Number of right hand sides 293 | 294 | double precision, dimension(ndim,nrhs), intent(in) :: & 295 | variable ! Variable to check 296 | 297 | integer :: k, j 298 | 299 | ! ---- Begin Code ---- 300 | 301 | disnan_wrap = .false. 302 | 303 | do k = 1, ndim 304 | do j = 1, nrhs 305 | 306 | ! Lapack NaN check function, sisnan for single precision or disnan for double precision 307 | disnan_wrap = disnan( variable(k,j) ) 308 | 309 | if ( disnan_wrap ) exit 310 | end do 311 | if ( disnan_wrap ) exit 312 | end do 313 | 314 | #endif /* NO_LAPACK_ISNAN */ 315 | 316 | return 317 | end function disnan_wrap 318 | 319 | ! Single precision wrapper 320 | !----------------------------------------------------------------------- 321 | logical function sisnan_wrap( ndim, nrhs, variable ) 322 | 323 | ! Description: 324 | ! Check for NaN values in a variable using the LAPACK subroutines 325 | 326 | ! References: 327 | ! 328 | ! 329 | !----------------------------------------------------------------------- 330 | 331 | implicit none 332 | 333 | #ifdef NO_LAPACK_ISNAN /* Used for older LAPACK libraries that don't have sisnan/disnan */ 334 | 335 | integer, intent(in) :: & 336 | ndim, & ! Size of variable 337 | nrhs ! Number of right hand sides 338 | 339 | real, dimension(ndim,nrhs), intent(in) :: & 340 | variable ! Variable to check 341 | 342 | sisnan_wrap = any( variable(:,1:nrhs) /= variable(:,1:nrhs) ) 343 | #else 344 | 345 | logical, external :: & 346 | sisnan ! Procedure 347 | 348 | integer, intent(in) :: & 349 | ndim, & ! Size of variable 350 | nrhs ! Number of right hand sides 351 | 352 | real, dimension(ndim,nrhs), intent(in) :: & 353 | variable ! Variable to check 354 | 355 | integer :: k, j 356 | 357 | ! ---- Begin Code ---- 358 | 359 | sisnan_wrap = .false. 360 | 361 | do k = 1, ndim 362 | do j = 1, nrhs 363 | 364 | ! Lapack NaN check function, sisnan for single precision or disnan for double precision 365 | sisnan_wrap = sisnan( variable(k,j) ) 366 | 367 | if ( sisnan_wrap ) exit 368 | end do 369 | if ( sisnan_wrap ) exit 370 | end do 371 | 372 | #endif /* NO_LAPACK_ISNAN */ 373 | 374 | return 375 | end function sisnan_wrap 376 | 377 | 378 | ! ==================== Cholesky Factorization Wrappers ==================== 379 | 380 | ! Double precision wrapper 381 | subroutine dpotrf_wrap( uplo, n, a, lda, info ) 382 | 383 | implicit none 384 | 385 | external :: dpotrf 386 | 387 | character uplo 388 | integer info, lda, n 389 | double precision a( lda, * ) 390 | 391 | call dpotrf( uplo, n, a, lda, info ) 392 | 393 | end subroutine dpotrf_wrap 394 | 395 | ! Single precision wrapper 396 | subroutine spotrf_wrap( uplo, n, a, lda, info ) 397 | 398 | implicit none 399 | 400 | external :: spotrf 401 | 402 | character uplo 403 | integer info, lda, n 404 | real a( lda, * ) 405 | 406 | call spotrf( uplo, n, a, lda, info ) 407 | 408 | end subroutine spotrf_wrap 409 | 410 | 411 | ! ==================== Equilibrium Scaling Calculation Wrappers ==================== 412 | 413 | ! Double precision wrapper 414 | subroutine dpoequ_wrap( n, a, lda, s, scond, amax, info ) 415 | 416 | implicit none 417 | 418 | external :: dpoequ 419 | 420 | integer info, lda, n 421 | double precision amax, scond 422 | double precision a( lda, * ), s( * ) 423 | 424 | call dpoequ( n, a, lda, s, scond, amax, info ) 425 | 426 | end subroutine dpoequ_wrap 427 | 428 | ! Single precision wrapper 429 | subroutine spoequ_wrap( n, a, lda, s, scond, amax, info ) 430 | 431 | implicit none 432 | 433 | external :: spoequ 434 | 435 | integer info, lda, n 436 | real amax, scond 437 | real a( lda, * ), s( * ) 438 | 439 | call spoequ( n, a, lda, s, scond, amax, info ) 440 | 441 | end subroutine spoequ_wrap 442 | 443 | 444 | ! ==================== Matrix Equilibriator Wrappers ==================== 445 | 446 | ! Double precision wrapper 447 | subroutine dlaqsy_wrap( uplo, n, a, lda, s, scond, amax, equed ) 448 | 449 | implicit none 450 | 451 | external :: dlaqsy 452 | 453 | character equed, uplo 454 | integer lda, n 455 | double precision amax, scond 456 | double precision a( lda, * ), s( * ) 457 | 458 | call dlaqsy( uplo, n, a, lda, s, scond, amax, equed ) 459 | 460 | end subroutine dlaqsy_wrap 461 | 462 | ! Single precision wrapper 463 | subroutine slaqsy_wrap( uplo, n, a, lda, s, scond, amax, equed ) 464 | 465 | implicit none 466 | 467 | external :: slaqsy 468 | 469 | character equed, uplo 470 | integer lda, n 471 | real amax, scond 472 | real a( lda, * ), s( * ) 473 | 474 | call slaqsy( uplo, n, a, lda, s, scond, amax, equed ) 475 | 476 | end subroutine slaqsy_wrap 477 | 478 | 479 | ! ==================== Eigenvalue/vector Calculation Wrappers ==================== 480 | 481 | ! Double precision wrapper 482 | subroutine dsyev_wrap( jobz, uplo, n, a, lda, w, work, lwork, info ) 483 | 484 | implicit none 485 | 486 | external :: dsyev 487 | 488 | character jobz, uplo 489 | integer info, lda, lwork, n 490 | double precision a( lda, * ), w( * ), work( * ) 491 | 492 | call dsyev( jobz, uplo, n, a, lda, w, work, lwork, info ) 493 | 494 | end subroutine dsyev_wrap 495 | 496 | ! Single precision wrapper 497 | subroutine ssyev_wrap( jobz, uplo, n, a, lda, w, work, lwork, info ) 498 | 499 | implicit none 500 | 501 | external :: ssyev 502 | 503 | character jobz, uplo 504 | integer info, lda, lwork, n 505 | real a( lda, * ), w( * ), work( * ) 506 | 507 | call ssyev( jobz, uplo, n, a, lda, w, work, lwork, info ) 508 | 509 | end subroutine ssyev_wrap 510 | 511 | 512 | ! ==================== Matrix Operations Wrappers ==================== 513 | 514 | ! Double precision wrapper 515 | subroutine dtrmv_wrap( uplo, trans, diag, n, a, lda, x, incx) 516 | 517 | implicit none 518 | 519 | external :: dtrmv 520 | 521 | integer incx,lda,n 522 | character diag,trans,uplo 523 | double precision a(lda,*),x(*) 524 | 525 | call dtrmv( uplo, trans, diag, n, a, lda, x, incx) 526 | 527 | end subroutine dtrmv_wrap 528 | 529 | ! Single precision wrapper 530 | subroutine strmv_wrap( uplo, trans, diag, n, a, lda, x, incx) 531 | 532 | implicit none 533 | 534 | external :: strmv 535 | 536 | integer incx,lda,n 537 | character diag,trans,uplo 538 | real a(lda,*),x(*) 539 | 540 | call strmv( uplo, trans, diag, n, a, lda, x, incx) 541 | 542 | end subroutine strmv_wrap 543 | 544 | end module lapack_interfaces -------------------------------------------------------------------------------- /stats_sfc_module.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module stats_sfc_module 5 | 6 | 7 | implicit none 8 | 9 | private ! Set Default Scope 10 | 11 | public :: stats_init_sfc 12 | 13 | ! Constant parameters 14 | integer, parameter, public :: nvarmax_sfc = 250 ! Maximum variables allowed 15 | 16 | contains 17 | 18 | !----------------------------------------------------------------------- 19 | subroutine stats_init_sfc( vars_sfc, l_error ) 20 | 21 | ! Description: 22 | ! Initializes array indices for stats_sfc 23 | ! References: 24 | ! None 25 | !----------------------------------------------------------------------- 26 | 27 | use constants_clubb, only: & 28 | fstderr ! Constant(s) 29 | 30 | use stats_variables, only: & 31 | stats_sfc, & ! Variables 32 | iustar, & 33 | isoil_heat_flux, & 34 | iveg_T_in_K, & 35 | isfc_soil_T_in_K,& 36 | ideep_soil_T_in_K, & 37 | ilh, & 38 | ish, & 39 | icc, & 40 | ilwp, & 41 | ivwp, & 42 | iiwp, & 43 | iswp, & 44 | irwp, & 45 | iz_cloud_base, & 46 | iz_inversion, & 47 | iprecip_rate_sfc, & 48 | irain_flux_sfc, & 49 | irrm_sfc, & 50 | iprecip_frac_tol 51 | 52 | use stats_variables, only: & 53 | iwpthlp_sfc, & 54 | iwprtp_sfc, & 55 | iupwp_sfc, & 56 | ivpwp_sfc, & 57 | ithlm_vert_avg, & 58 | irtm_vert_avg, & 59 | ium_vert_avg, & 60 | ivm_vert_avg, & 61 | iwp2_vert_avg, & 62 | iup2_vert_avg, & 63 | ivp2_vert_avg, & 64 | irtp2_vert_avg, & 65 | ithlp2_vert_avg, & 66 | iT_sfc 67 | 68 | use stats_variables, only: & 69 | iwp23_matrix_condt_num, & 70 | irtm_matrix_condt_num, & 71 | ithlm_matrix_condt_num, & 72 | irtp2_matrix_condt_num, & 73 | ithlp2_matrix_condt_num, & 74 | irtpthlp_matrix_condt_num, & 75 | iup2_vp2_matrix_condt_num, & 76 | iwindm_matrix_condt_num 77 | 78 | use stats_variables, only: & 79 | imorr_snow_rate ! Variable(s) 80 | 81 | use stats_variables, only: & 82 | irtm_spur_src, & 83 | ithlm_spur_src, & 84 | irsm_sd_morr_int 85 | 86 | use stats_type_utilities, only: & 87 | stat_assign ! Procedure 88 | 89 | implicit none 90 | 91 | ! External 92 | intrinsic :: trim 93 | 94 | ! Input Variable 95 | character(len= * ), dimension(nvarmax_sfc), intent(in) :: vars_sfc 96 | 97 | ! Input / Output Variable 98 | logical, intent(inout) :: l_error 99 | 100 | ! Local Varables 101 | integer :: i, k 102 | 103 | ! ---- Begin Code ---- 104 | 105 | ! Default initialization for array indices for stats_sfc is zero (see module 106 | ! stats_variables) 107 | 108 | ! Assign pointers for statistics variables stats_sfc using stat_assign 109 | 110 | k = 1 111 | do i = 1, stats_sfc%num_output_fields 112 | 113 | select case ( trim( vars_sfc(i) ) ) 114 | case ('soil_heat_flux') 115 | isoil_heat_flux = k 116 | 117 | call stat_assign( var_index=isoil_heat_flux, var_name="soil_heat_flux", & 118 | var_description="soil_heat_flux[W/m^2]", var_units="W/m^2", l_silhs=.false., & 119 | grid_kind=stats_sfc ) 120 | k = k + 1 121 | case ('ustar') 122 | iustar = k 123 | 124 | call stat_assign( var_index=iustar, var_name="ustar", & 125 | var_description="Friction velocity [m/s]", var_units="m/s", l_silhs=.false., & 126 | grid_kind=stats_sfc ) 127 | k = k + 1 128 | case ('veg_T_in_K') 129 | iveg_T_in_K = k 130 | 131 | call stat_assign( var_index=iveg_T_in_K, var_name="veg_T_in_K", & 132 | var_description="Surface Vegetation Temperature [K]", var_units="K", & 133 | l_silhs=.false., grid_kind=stats_sfc ) 134 | k = k + 1 135 | case ('sfc_soil_T_in_K') 136 | isfc_soil_T_in_K = k 137 | 138 | call stat_assign( var_index=isfc_soil_T_in_K, var_name="sfc_soil_T_in_K", & 139 | var_description="Surface soil temperature [K]", var_units="K", l_silhs=.false., & 140 | grid_kind=stats_sfc ) 141 | k = k + 1 142 | case ('deep_soil_T_in_K') 143 | ideep_soil_T_in_K = k 144 | 145 | call stat_assign( var_index=ideep_soil_T_in_K, var_name="deep_soil_T_in_K", & 146 | var_description="Deep soil Temperature [K]", var_units="K", l_silhs=.false., & 147 | grid_kind=stats_sfc ) 148 | k = k + 1 149 | 150 | case ('lh') 151 | ilh = k 152 | call stat_assign( var_index=ilh, var_name="lh", & 153 | var_description="Surface latent heating [W/m^2]", var_units="W/m2", l_silhs=.false., & 154 | grid_kind=stats_sfc ) 155 | k = k + 1 156 | 157 | case ('sh') 158 | ish = k 159 | call stat_assign( var_index=ish, var_name="sh", & 160 | var_description="Surface sensible heating [W/m^2]", var_units="W/m2", & 161 | l_silhs=.false., grid_kind=stats_sfc ) 162 | k = k + 1 163 | 164 | case ('cc') 165 | icc = k 166 | call stat_assign( var_index=icc, var_name="cc", var_description="Cloud cover [count]", & 167 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 168 | k = k + 1 169 | 170 | case ('lwp') 171 | ilwp = k 172 | call stat_assign( var_index=ilwp, var_name="lwp", & 173 | var_description="Liquid water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & 174 | grid_kind=stats_sfc ) 175 | k = k + 1 176 | 177 | case ('vwp') 178 | ivwp = k 179 | call stat_assign( var_index=ivwp, var_name="vwp", & 180 | var_description="Vapor water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & 181 | grid_kind=stats_sfc ) 182 | k = k + 1 183 | 184 | case ('iwp') 185 | iiwp = k 186 | call stat_assign( var_index=iiwp, var_name="iwp", & 187 | var_description="Ice water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & 188 | grid_kind=stats_sfc ) 189 | k = k + 1 190 | 191 | case ('swp') 192 | iswp = k 193 | call stat_assign( var_index=iswp, var_name="swp", & 194 | var_description="Snow water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & 195 | grid_kind=stats_sfc ) 196 | k = k + 1 197 | 198 | case ('rwp') 199 | irwp = k 200 | call stat_assign( var_index=irwp, var_name="rwp", & 201 | var_description="Rain water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & 202 | grid_kind=stats_sfc ) 203 | k = k + 1 204 | 205 | case ('z_cloud_base') 206 | iz_cloud_base = k 207 | call stat_assign( var_index=iz_cloud_base, var_name="z_cloud_base", & 208 | var_description="Cloud base altitude [m]", var_units="m", l_silhs=.false., & 209 | grid_kind=stats_sfc ) 210 | k = k + 1 211 | 212 | case ('z_inversion') 213 | iz_inversion = k 214 | call stat_assign( var_index=iz_inversion, var_name="z_inversion", & 215 | var_description="Inversion altitude [m]", var_units="m", l_silhs=.false., & 216 | grid_kind=stats_sfc ) 217 | k = k + 1 218 | 219 | case ('precip_rate_sfc') ! Brian 220 | iprecip_rate_sfc = k 221 | call stat_assign( var_index=iprecip_rate_sfc, var_name="precip_rate_sfc", & 222 | var_description="Surface rainfall rate [mm/day]", var_units="mm/day", & 223 | l_silhs=.true., grid_kind=stats_sfc ) 224 | k = k + 1 225 | 226 | case ('rain_flux_sfc') ! Brian 227 | irain_flux_sfc = k 228 | 229 | call stat_assign( var_index=irain_flux_sfc, var_name="rain_flux_sfc", & 230 | var_description="Surface rain flux [W/m^2]", var_units="W/m^2", l_silhs=.false., & 231 | grid_kind=stats_sfc ) 232 | k = k + 1 233 | 234 | case ('rrm_sfc') ! Brian 235 | irrm_sfc = k 236 | 237 | call stat_assign( var_index=irrm_sfc, var_name="rrm_sfc", & 238 | var_description="Surface rain water mixing ratio [kg/kg]", var_units="kg/kg", & 239 | l_silhs=.false., grid_kind=stats_sfc ) 240 | k = k + 1 241 | 242 | case ('precip_frac_tol') 243 | iprecip_frac_tol = k 244 | 245 | call stat_assign( var_index=iprecip_frac_tol, & 246 | var_name="precip_frac_tol", & 247 | var_description="Smallest allowable precipitation " & 248 | // "fraction when hydrometeors are present [-]", & 249 | var_units="-", & 250 | l_silhs=.false., grid_kind=stats_sfc ) 251 | k = k + 1 252 | 253 | case ( 'morr_snow_rate' ) 254 | imorr_snow_rate = k 255 | call stat_assign( var_index=imorr_snow_rate, var_name="morr_snow_rate", & 256 | var_description="Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]", & 257 | var_units="mm/day", l_silhs=.false., grid_kind=stats_sfc ) 258 | k = k + 1 259 | 260 | case ('wpthlp_sfc') 261 | iwpthlp_sfc = k 262 | 263 | call stat_assign( var_index=iwpthlp_sfc, var_name="wpthlp_sfc", & 264 | var_description="wpthlp surface flux [K m/s]", var_units="K m/s", l_silhs=.false., & 265 | grid_kind=stats_sfc ) 266 | k = k + 1 267 | 268 | case ('wprtp_sfc') 269 | iwprtp_sfc = k 270 | 271 | call stat_assign( var_index=iwprtp_sfc, var_name="wprtp_sfc", & 272 | var_description="wprtp surface flux [kg/kg]", var_units="(kg/kg) m/s", & 273 | l_silhs=.false., grid_kind=stats_sfc ) 274 | k = k + 1 275 | 276 | case ('upwp_sfc') 277 | iupwp_sfc = k 278 | 279 | call stat_assign( var_index=iupwp_sfc, var_name="upwp_sfc", & 280 | var_description="upwp surface flux [m^2/s^2]", var_units="m^2/s^2", l_silhs=.false., & 281 | grid_kind=stats_sfc ) 282 | k = k + 1 283 | 284 | case ('vpwp_sfc') 285 | ivpwp_sfc = k 286 | 287 | call stat_assign( var_index=ivpwp_sfc, var_name="vpwp_sfc", & 288 | var_description="vpwp surface flux [m^2/s^2]", var_units="m^2/s^2", l_silhs=.false., & 289 | grid_kind=stats_sfc ) 290 | k = k + 1 291 | 292 | case ('thlm_vert_avg') 293 | ithlm_vert_avg = k 294 | 295 | call stat_assign( var_index=ithlm_vert_avg, var_name="thlm_vert_avg", & 296 | var_description="Vertical average (density-weighted) of thlm [K]", var_units="K", & 297 | l_silhs=.false., grid_kind=stats_sfc ) 298 | k = k + 1 299 | 300 | case ('rtm_vert_avg') 301 | irtm_vert_avg = k 302 | 303 | call stat_assign( var_index=irtm_vert_avg, var_name="rtm_vert_avg", & 304 | var_description="Vertical average (density-weighted) of rtm [kg/kg]", & 305 | var_units="kg/kg", l_silhs=.false., grid_kind=stats_sfc ) 306 | k = k + 1 307 | 308 | case ('um_vert_avg') 309 | ium_vert_avg = k 310 | 311 | call stat_assign( var_index=ium_vert_avg, var_name="um_vert_avg", & 312 | var_description="Vertical average (density-weighted) of um [m/s]", var_units="m/s", & 313 | l_silhs=.false., grid_kind=stats_sfc ) 314 | k = k + 1 315 | 316 | case ('vm_vert_avg') 317 | ivm_vert_avg = k 318 | 319 | call stat_assign( var_index=ivm_vert_avg, var_name="vm_vert_avg", & 320 | var_description="Vertical average (density-weighted) of vm [m/s]", var_units="m/s", & 321 | l_silhs=.false., grid_kind=stats_sfc ) 322 | k = k + 1 323 | 324 | case ('wp2_vert_avg') 325 | iwp2_vert_avg = k 326 | 327 | call stat_assign( var_index=iwp2_vert_avg, var_name="wp2_vert_avg", & 328 | var_description="Vertical average (density-weighted) of wp2 [m^2/s^2]", & 329 | var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) 330 | k = k + 1 331 | 332 | case ('up2_vert_avg') 333 | iup2_vert_avg = k 334 | 335 | call stat_assign( var_index=iup2_vert_avg, var_name="up2_vert_avg", & 336 | var_description="Vertical average (density-weighted) of up2 [m^2/s^2]", & 337 | var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) 338 | k = k + 1 339 | 340 | case ('vp2_vert_avg') 341 | ivp2_vert_avg = k 342 | 343 | call stat_assign( var_index=ivp2_vert_avg, var_name="vp2_vert_avg", & 344 | var_description="Vertical average (density-weighted) of vp2 [m^2/s^2]", & 345 | var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) 346 | k = k + 1 347 | 348 | case ('rtp2_vert_avg') 349 | irtp2_vert_avg = k 350 | 351 | call stat_assign( var_index=irtp2_vert_avg, var_name="rtp2_vert_avg", & 352 | var_description="Vertical average (density-weighted) of rtp2 [kg^2/kg^2]", & 353 | var_units="kg^2/kg^2", l_silhs=.false., grid_kind=stats_sfc ) 354 | k = k + 1 355 | 356 | case ('thlp2_vert_avg') 357 | ithlp2_vert_avg = k 358 | 359 | call stat_assign( var_index=ithlp2_vert_avg, var_name="thlp2_vert_avg", & 360 | var_description="Vertical average (density-weighted) of thlp2 [K^2]", & 361 | var_units="K^2", l_silhs=.false., grid_kind=stats_sfc ) 362 | k = k + 1 363 | 364 | case ('T_sfc') 365 | iT_sfc = k 366 | 367 | call stat_assign( var_index=iT_sfc, var_name="T_sfc", & 368 | var_description="Surface Temperature [K]", var_units="K", l_silhs=.false., & 369 | grid_kind=stats_sfc ) 370 | k = k + 1 371 | 372 | case ('wp23_matrix_condt_num') 373 | iwp23_matrix_condt_num = k 374 | call stat_assign( var_index=iwp23_matrix_condt_num, var_name="wp23_matrix_condt_num", & 375 | var_description="Estimate of the condition number for wp2/3 [count]", & 376 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 377 | k = k + 1 378 | 379 | case ('thlm_matrix_condt_num') 380 | ithlm_matrix_condt_num = k 381 | call stat_assign( var_index=ithlm_matrix_condt_num, var_name="thlm_matrix_condt_num", & 382 | var_description="Estimate of the condition number for thlm/wpthlp [count]", & 383 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 384 | k = k + 1 385 | 386 | case ('rtm_matrix_condt_num') 387 | irtm_matrix_condt_num = k 388 | 389 | call stat_assign( var_index=irtm_matrix_condt_num, var_name="rtm_matrix_condt_num", & 390 | var_description="Estimate of the condition number for rtm/wprtp [count]", & 391 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 392 | k = k + 1 393 | 394 | case ('thlp2_matrix_condt_num') 395 | ithlp2_matrix_condt_num = k 396 | 397 | call stat_assign( var_index=ithlp2_matrix_condt_num, var_name="thlp2_matrix_condt_num", & 398 | var_description="Estimate of the condition number for thlp2 [count]", & 399 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 400 | k = k + 1 401 | 402 | case ('rtp2_matrix_condt_num') 403 | irtp2_matrix_condt_num = k 404 | call stat_assign( var_index=irtp2_matrix_condt_num, var_name="rtp2_matrix_condt_num", & 405 | var_description="Estimate of the condition number for rtp2 [count]", & 406 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 407 | k = k + 1 408 | 409 | case ('rtpthlp_matrix_condt_num') 410 | irtpthlp_matrix_condt_num = k 411 | call stat_assign( var_index=irtpthlp_matrix_condt_num, & 412 | var_name="rtpthlp_matrix_condt_num", & 413 | var_description="Estimate of the condition number for rtpthlp [count]", & 414 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 415 | k = k + 1 416 | 417 | case ('up2_vp2_matrix_condt_num') 418 | iup2_vp2_matrix_condt_num = k 419 | call stat_assign( var_index=iup2_vp2_matrix_condt_num, & 420 | var_name="up2_vp2_matrix_condt_num", & 421 | var_description="Estimate of the condition number for up2/vp2 [count]", & 422 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 423 | k = k + 1 424 | 425 | case ('windm_matrix_condt_num') 426 | iwindm_matrix_condt_num = k 427 | call stat_assign( var_index=iwindm_matrix_condt_num, var_name="windm_matrix_condt_num", & 428 | var_description="Estimate of the condition number for the mean wind [count]", & 429 | var_units="count", l_silhs=.false., grid_kind=stats_sfc ) 430 | 431 | k = k + 1 432 | 433 | case ('rtm_spur_src') 434 | irtm_spur_src = k 435 | 436 | call stat_assign( var_index=irtm_spur_src, var_name="rtm_spur_src", & 437 | var_description="rtm spurious source [kg/(m^2 s)]", var_units="kg/(m^2 s)", & 438 | l_silhs=.false., grid_kind=stats_sfc ) 439 | k = k + 1 440 | 441 | case ('thlm_spur_src') 442 | ithlm_spur_src = k 443 | 444 | call stat_assign( var_index=ithlm_spur_src, var_name="thlm_spur_src", & 445 | var_description="thlm spurious source [(K kg) / (m^2 s)]", & 446 | var_units="(K kg) / (m^2 s)", l_silhs=.false., grid_kind=stats_sfc ) 447 | k = k + 1 448 | 449 | case ('rs_sd_morr_int') 450 | irsm_sd_morr_int = k 451 | 452 | call stat_assign( var_index=irsm_sd_morr_int, var_name="rs_sd_morr_int", & 453 | var_description="rsm_sd_morr vertical integral [(kg/kg)/s]", & 454 | var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_sfc ) 455 | k = k + 1 456 | 457 | case default 458 | write(fstderr,*) 'Error: unrecognized variable in vars_sfc: ', & 459 | trim( vars_sfc(i) ) 460 | l_error = .true. ! This will stop the run. 461 | 462 | end select 463 | 464 | end do ! 1 .. stats_sfc%num_output_fields 465 | 466 | return 467 | 468 | end subroutine stats_init_sfc 469 | 470 | 471 | end module stats_sfc_module 472 | 473 | -------------------------------------------------------------------------------- /matrix_operations.F90: -------------------------------------------------------------------------------- 1 | !----------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module matrix_operations 5 | 6 | implicit none 7 | 8 | 9 | public :: symm_covar_matrix_2_corr_matrix, Cholesky_factor, & 10 | row_mult_lower_tri_matrix, print_lower_triangular_matrix, & 11 | get_lower_triangular_matrix, set_lower_triangular_matrix, & 12 | mirror_lower_triangular_matrix 13 | 14 | private :: Symm_matrix_eigenvalues 15 | 16 | private ! Default scope 17 | 18 | contains 19 | 20 | !----------------------------------------------------------------------- 21 | subroutine symm_covar_matrix_2_corr_matrix( ndim, covar, corr ) 22 | 23 | ! Description: 24 | ! Convert a matrix of covariances in to a matrix of correlations. 25 | ! This only does the computation the lower triangular portion of the 26 | ! matrix. 27 | ! References: 28 | ! None 29 | !----------------------------------------------------------------------- 30 | 31 | use clubb_precision, only: & 32 | core_rknd ! double precision 33 | 34 | implicit none 35 | 36 | ! External 37 | intrinsic :: sqrt 38 | 39 | ! Input Variables 40 | integer, intent(in) :: ndim 41 | 42 | real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: & 43 | covar ! Covariance Matrix [units vary] 44 | 45 | ! Output Variables 46 | real( kind = core_rknd ), dimension(ndim,ndim), intent(out) :: & 47 | corr ! Correlation Matrix [-] 48 | 49 | ! Local Variables 50 | integer :: i, j 51 | 52 | ! ---- Begin Code ---- 53 | 54 | corr = 0._core_rknd ! Initialize to 0 55 | 56 | do i = 1, ndim 57 | do j = 1, i 58 | corr(i,j) = covar(i,j) / sqrt( covar(i,i) * covar(j,j) ) 59 | end do 60 | end do 61 | 62 | return 63 | end subroutine symm_covar_matrix_2_corr_matrix 64 | !----------------------------------------------------------------------- 65 | subroutine row_mult_lower_tri_matrix( ndim, xvector, tmatrix_in, tmatrix_out ) 66 | 67 | ! Description: 68 | ! Do a row-wise multiply of the elements of a lower triangular matrix. 69 | ! References: 70 | ! None 71 | !----------------------------------------------------------------------- 72 | 73 | use clubb_precision, only: & 74 | core_rknd ! double precision 75 | 76 | implicit none 77 | 78 | 79 | ! Input Variables 80 | integer, intent(in) :: ndim 81 | 82 | real( kind = core_rknd ), dimension(ndim), intent(in) :: & 83 | xvector ! Factors to be multiplied across a row [units vary] 84 | 85 | ! Input Variables 86 | real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: & 87 | tmatrix_in ! nxn matrix (usually a correlation matrix) [units vary] 88 | 89 | ! Output Variables 90 | real( kind = core_rknd ), dimension(ndim,ndim), intent(inout) :: & 91 | tmatrix_out ! nxn matrix (usually a covariance matrix) [units vary] 92 | 93 | ! Local Variables 94 | integer :: i, j 95 | 96 | ! ---- Begin Code ---- 97 | 98 | do i = 1, ndim 99 | do j = 1, i 100 | tmatrix_out(i,j) = tmatrix_in(i,j) * xvector(i) 101 | end do 102 | end do 103 | 104 | return 105 | end subroutine row_mult_lower_tri_matrix 106 | 107 | !------------------------------------------------------------------------------- 108 | subroutine Cholesky_factor( ndim, a_input, a_scaling, a_Cholesky, l_scaled ) 109 | ! Description: 110 | ! Create a Cholesky factorization of a_input. 111 | ! If the factorization fails we use a modified a_input matrix and attempt 112 | ! to factorize again. 113 | ! 114 | ! References: 115 | ! dpotrf 116 | ! dpoequ 117 | ! dlaqsy 118 | !------------------------------------------------------------------------------- 119 | use error_code, only: & 120 | clubb_at_least_debug_level ! Procedure 121 | 122 | use constants_clubb, only: & 123 | fstderr ! Constant 124 | 125 | use clubb_precision, only: & 126 | core_rknd 127 | 128 | use lapack_interfaces, only: & 129 | lapack_potrf, & ! Procedures 130 | lapack_poequ, & 131 | lapack_laqsy 132 | 133 | implicit none 134 | 135 | ! Constant Parameters 136 | integer, parameter :: itermax = 10 ! Max iterations of the modified method 137 | 138 | real( kind = core_rknd), parameter :: d_coef = 0.1_core_rknd 139 | ! Coefficient applied if the decomposition doesn't work 140 | 141 | ! Input Variables 142 | integer, intent(in) :: ndim 143 | 144 | real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: a_input 145 | 146 | ! Output Variables 147 | real( kind = core_rknd ), dimension(ndim), intent(out) :: a_scaling 148 | 149 | real( kind = core_rknd ), dimension(ndim,ndim), intent(out) :: a_Cholesky 150 | 151 | logical, intent(out) :: l_scaled 152 | 153 | ! Local Variables 154 | real( kind = core_rknd ), dimension(ndim) :: a_eigenvalues 155 | real( kind = core_rknd ), dimension(ndim,ndim) :: a_corr, a_scaled 156 | 157 | real( kind = core_rknd ) :: tau, d_smallest 158 | 159 | real( kind = core_rknd ) :: amax, scond 160 | integer :: info 161 | integer :: i, j, iter 162 | 163 | character :: equed 164 | 165 | ! ---- Begin code ---- 166 | 167 | a_scaled = a_input ! Copy input array into output array 168 | 169 | ! do i = 1, n 170 | ! do j = 1, n 171 | ! write(6,'(e10.3)',advance='no') a(i,j) 172 | ! end do 173 | ! write(6,*) "" 174 | ! end do 175 | ! pause 176 | 177 | equed = 'N' 178 | 179 | ! Compute scaling for a_input, using Lapack routine spoequ for single precision, 180 | ! or dpoequ for double precision 181 | call lapack_poequ( ndim, a_input, ndim, a_scaling, scond, amax, info ) 182 | 183 | if ( info == 0 ) then 184 | ! Apply scaling to a_input, using Lapack routine slaqsy for single precision, 185 | ! or dlaqsy for double precision 186 | call lapack_laqsy( 'Lower', ndim, a_scaled, ndim, a_scaling, scond, amax, equed ) 187 | end if 188 | 189 | ! Determine if scaling was necessary 190 | if ( equed == 'Y' ) then 191 | l_scaled = .true. 192 | a_Cholesky = a_scaled 193 | else 194 | l_scaled = .false. 195 | a_Cholesky = a_input 196 | end if 197 | 198 | do iter = 1, itermax 199 | 200 | ! Lapack Cholesky factorization, spotrf for single or dpotrf for double precision 201 | call lapack_potrf( 'Lower', ndim, a_Cholesky, ndim, info ) 202 | 203 | select case( info ) 204 | case( :-1 ) 205 | write(fstderr,*) "Cholesky_factor " // & 206 | " illegal value for argument ", -info 207 | stop 208 | case( 0 ) 209 | ! Success! 210 | if ( clubb_at_least_debug_level( 1 ) .and. iter > 1 ) then 211 | write(fstderr,*) "a_factored (worked)=" 212 | do i = 1, ndim 213 | do j = 1, i 214 | write(fstderr,'(g10.3)',advance='no') a_Cholesky(i,j) 215 | end do 216 | write(fstderr,*) "" 217 | end do 218 | end if 219 | exit 220 | case( 1: ) 221 | if ( clubb_at_least_debug_level( 1 ) ) then 222 | ! This shouldn't happen now that the s and t Mellor(chi/eta) elements have been 223 | ! modified to never be perfectly correlated, but it's here just in case. 224 | ! -dschanen 10 Sept 2010 225 | write(fstderr,*) "Cholesky_factor: leading minor of order ", & 226 | info, " is not positive definite." 227 | write(fstderr,*) "factorization failed." 228 | write(fstderr,*) "a_input=" 229 | do i = 1, ndim 230 | do j = 1, i 231 | write(fstderr,'(g10.3)',advance='no') a_input(i,j) 232 | end do 233 | write(fstderr,*) "" 234 | end do 235 | write(fstderr,*) "a_Cholesky=" 236 | do i = 1, ndim 237 | do j = 1, i 238 | write(fstderr,'(g10.3)',advance='no') a_Cholesky(i,j) 239 | end do 240 | write(fstderr,*) "" 241 | end do 242 | end if 243 | 244 | if ( clubb_at_least_debug_level( 2 ) ) then 245 | call Symm_matrix_eigenvalues( ndim, a_input, a_eigenvalues ) 246 | write(fstderr,*) "a_eigenvalues=" 247 | do i = 1, ndim 248 | write(fstderr,'(g10.3)',advance='no') a_eigenvalues(i) 249 | end do 250 | write(fstderr,*) "" 251 | 252 | call symm_covar_matrix_2_corr_matrix( ndim, a_input, a_corr ) 253 | write(fstderr,*) "a_correlations=" 254 | do i = 1, ndim 255 | do j = 1, i 256 | write(fstderr,'(g10.3)',advance='no') a_corr(i,j) 257 | end do 258 | write(fstderr,*) "" 259 | end do 260 | end if 261 | 262 | if ( iter == itermax ) then 263 | write(fstderr,*) "iteration =", iter, "itermax =", itermax 264 | write(fstderr,*) "Fatal error in Cholesky_factor" 265 | else if ( clubb_at_least_debug_level( 1 ) ) then 266 | ! Adding a STOP statement to prevent this problem from slipping under 267 | ! the rug. 268 | write(fstderr,*) "Fatal error in Cholesky_factor" 269 | write(fstderr,*) "Attempting to modify matrix to allow factorization." 270 | end if 271 | 272 | if ( l_scaled ) then 273 | a_Cholesky = a_scaled 274 | else 275 | a_Cholesky = a_input 276 | end if 277 | ! The number used for tau here is case specific to the Sigma covariance 278 | ! matrix in the latin hypercube code and is not at all general. 279 | ! Tau should be a number that is small relative to the other diagonal 280 | ! elements of the matrix to have keep the error caused by modifying 'a' low. 281 | ! -dschanen 30 Aug 2010 282 | d_smallest = a_Cholesky(1,1) 283 | do i = 2, ndim 284 | if ( d_smallest > a_Cholesky(i,i) ) d_smallest = a_Cholesky(i,i) 285 | end do 286 | ! Use the smallest element * d_coef * iteration 287 | tau = d_smallest * d_coef * real( iter, kind=core_rknd ) 288 | 289 | ! print *, "tau =", tau, "d_smallest = ", d_smallest 290 | 291 | do i = 1, ndim 292 | do j = 1, ndim 293 | if ( i == j ) then 294 | a_Cholesky(i,j) = a_Cholesky(i,j) + tau ! Add tau to the diagonal 295 | else 296 | a_Cholesky(i,j) = a_Cholesky(i,j) 297 | end if 298 | end do 299 | end do 300 | 301 | if ( clubb_at_least_debug_level( 2 ) ) then 302 | call Symm_matrix_eigenvalues( ndim, a_Cholesky, a_eigenvalues ) 303 | write(fstderr,*) "a_modified eigenvalues=" 304 | do i = 1, ndim 305 | write(fstderr,'(e10.3)',advance='no') a_eigenvalues(i) 306 | end do 307 | write(fstderr,*) "" 308 | end if 309 | 310 | end select ! info 311 | end do ! 1..itermax 312 | 313 | return 314 | end subroutine Cholesky_factor 315 | 316 | !---------------------------------------------------------------------- 317 | subroutine Symm_matrix_eigenvalues( ndim, a_input, a_eigenvalues ) 318 | 319 | ! Description: 320 | ! Computes the eigevalues of a_input 321 | ! 322 | ! References: 323 | ! None 324 | !----------------------------------------------------------------------- 325 | 326 | use constants_clubb, only: & 327 | fstderr ! Constant 328 | 329 | use clubb_precision, only: & 330 | core_rknd ! double precision 331 | 332 | use lapack_interfaces, only: & 333 | lapack_syev ! Procedure 334 | 335 | implicit none 336 | 337 | ! Parameters 338 | integer, parameter :: & 339 | lwork = 180 ! This is the optimal value I obtained for an n of 5 -dschanen 31 Aug 2010 340 | 341 | ! Input Variables 342 | integer, intent(in) :: ndim 343 | 344 | real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: a_input 345 | 346 | ! Output Variables 347 | real( kind = core_rknd ), dimension(ndim), intent(out) :: a_eigenvalues 348 | 349 | ! Local Variables 350 | real( kind = core_rknd ), dimension(ndim,ndim) :: a_scratch 351 | 352 | real( kind = core_rknd ), dimension(lwork) :: work 353 | 354 | integer :: info 355 | ! integer :: i, j 356 | ! ---- Begin code ---- 357 | 358 | a_scratch = a_input 359 | 360 | ! do i = 1, ndim 361 | ! do j = 1, ndim 362 | ! write(6,'(e10.3)',advance='no') a(i,j) 363 | ! end do 364 | ! write(6,*) "" 365 | ! end do 366 | ! pause 367 | 368 | ! Lapack routine for computing eigenvalues and, optionally, eigenvectors. ssyev for 369 | ! single precision or dsyev for double precision 370 | call lapack_syev( 'No eigenvectors', 'Lower', ndim, a_scratch, ndim, & 371 | a_eigenvalues, work, lwork, info ) 372 | 373 | select case( info ) 374 | case( :-1 ) 375 | write(fstderr,*) "Symm_matrix_eigenvalues:" // & 376 | " illegal value for argument ", -info 377 | case( 0 ) 378 | ! Success! 379 | 380 | case( 1: ) 381 | write(fstderr,*) "Symm_matrix_eigenvalues: Algorithm failed to converge." 382 | end select 383 | 384 | return 385 | end subroutine Symm_matrix_eigenvalues 386 | !------------------------------------------------------------------------------- 387 | subroutine set_lower_triangular_matrix( pdf_dim, index1, index2, xpyp, & 388 | matrix ) 389 | ! Description: 390 | ! Set a value for the lower triangular portion of a matrix. 391 | ! References: 392 | ! None 393 | !------------------------------------------------------------------------------- 394 | 395 | use clubb_precision, only: & 396 | core_rknd ! user defined precision 397 | 398 | implicit none 399 | 400 | ! External 401 | intrinsic :: max, min 402 | 403 | ! Input Variables 404 | integer, intent(in) :: & 405 | pdf_dim, & ! Number of variates 406 | index1, index2 ! Indices for 2 variates (the order doesn't matter) 407 | 408 | real( kind = core_rknd ), intent(in) :: & 409 | xpyp ! Value for the matrix (usually a correlation or covariance) [units vary] 410 | 411 | ! Input/Output Variables 412 | real( kind = core_rknd ), dimension(pdf_dim,pdf_dim), intent(inout) :: & 413 | matrix ! The lower triangular matrix 414 | 415 | integer :: i,j 416 | 417 | ! ---- Begin Code ---- 418 | 419 | ! Reverse these to set the values of upper triangular matrix 420 | i = max( index1, index2 ) 421 | j = min( index1, index2 ) 422 | 423 | if( i > 0 .and. j > 0 ) then 424 | matrix(i,j) = xpyp 425 | end if 426 | 427 | return 428 | end subroutine set_lower_triangular_matrix 429 | !------------------------------------------------------------------------------- 430 | 431 | !------------------------------------------------------------------------------- 432 | subroutine get_lower_triangular_matrix( pdf_dim, index1, index2, matrix, & 433 | xpyp ) 434 | ! Description: 435 | ! Returns a value from the lower triangular portion of a matrix. 436 | ! References: 437 | ! None 438 | !------------------------------------------------------------------------------- 439 | 440 | use clubb_precision, only: & 441 | core_rknd 442 | 443 | implicit none 444 | 445 | ! External 446 | intrinsic :: max, min 447 | 448 | ! Input Variables 449 | integer, intent(in) :: & 450 | pdf_dim, & ! Number of variates 451 | index1, index2 ! Indices for 2 variates (the order doesn't matter) 452 | 453 | ! Input/Output Variables 454 | real( kind = core_rknd ), dimension(pdf_dim,pdf_dim), intent(in) :: & 455 | matrix ! The covariance matrix 456 | 457 | real( kind = core_rknd ), intent(out) :: & 458 | xpyp ! Value from the matrix (usually a correlation or covariance) [units vary] 459 | 460 | integer :: i,j 461 | 462 | ! ---- Begin Code ---- 463 | 464 | ! Reverse these to set the values of upper triangular matrix 465 | i = max( index1, index2 ) 466 | j = min( index1, index2 ) 467 | 468 | xpyp = matrix(i,j) 469 | 470 | return 471 | end subroutine get_lower_triangular_matrix 472 | 473 | !----------------------------------------------------------------------- 474 | subroutine print_lower_triangular_matrix( iunit, ndim, matrix ) 475 | 476 | ! Description: 477 | ! Print the values of lower triangular matrix to a file or console. 478 | 479 | ! References: 480 | ! None 481 | !----------------------------------------------------------------------- 482 | 483 | use clubb_precision, only: & 484 | core_rknd ! Variable(s) 485 | 486 | implicit none 487 | 488 | ! Input Variables 489 | integer, intent(in) :: & 490 | iunit, & ! File I/O logical unit (usually 6 for stdout and 0 for stderr) 491 | ndim ! Dimension of the matrix 492 | 493 | real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: & 494 | matrix ! Lower triangular matrix [units vary] 495 | 496 | ! Local Variables 497 | integer :: i, j 498 | 499 | ! ---- Begin Code ---- 500 | 501 | do i = 1, ndim 502 | do j = 1, i 503 | write(iunit,fmt='(g15.6)',advance='no') matrix(i,j) 504 | end do 505 | write(iunit,fmt=*) "" ! newline 506 | end do 507 | 508 | return 509 | end subroutine print_lower_triangular_matrix 510 | 511 | !----------------------------------------------------------------------- 512 | subroutine mirror_lower_triangular_matrix( nvars, matrix ) 513 | 514 | ! Description: 515 | ! Mirrors the elements of a lower triangular matrix to the upper 516 | ! triangle so that it is symmetric. 517 | 518 | ! References: 519 | ! None 520 | !----------------------------------------------------------------------- 521 | 522 | use clubb_precision, only: & 523 | core_rknd ! Constant 524 | 525 | implicit none 526 | 527 | ! Input Variables 528 | integer, intent(in) :: & 529 | nvars ! Number of variables in each dimension of square matrix 530 | 531 | ! Input/Output Variables 532 | real( kind = core_rknd ), dimension(nvars,nvars), intent(inout) :: & 533 | matrix ! Lower triangluar square matrix 534 | 535 | ! Local Variables 536 | integer :: row, col 537 | 538 | !----------------------------------------------------------------------- 539 | 540 | !----- Begin Code ----- 541 | 542 | if ( nvars > 1 ) then 543 | 544 | do col=2, nvars 545 | do row=1, col-1 546 | 547 | matrix(row,col) = matrix(col,row) 548 | 549 | end do 550 | end do 551 | 552 | end if ! nvars > 1 553 | 554 | return 555 | 556 | end subroutine mirror_lower_triangular_matrix 557 | !----------------------------------------------------------------------- 558 | 559 | end module matrix_operations 560 | -------------------------------------------------------------------------------- /sponge_layer_damping.F90: -------------------------------------------------------------------------------- 1 | !--------------------------------------------------------------------------- 2 | ! $Id$ 3 | !=============================================================================== 4 | module sponge_layer_damping 5 | 6 | ! Description: 7 | ! This module is used for damping variables in upper altitudes of the grid. 8 | ! 9 | ! References: 10 | ! None 11 | !------------------------------------------------------------------------- 12 | 13 | use clubb_precision, only: & 14 | core_rknd ! Variable(s) 15 | 16 | implicit none 17 | 18 | public :: sponge_damp_xm, & ! Procedure(s) 19 | sponge_damp_xp2, & 20 | sponge_damp_xp3, & 21 | initialize_tau_sponge_damp, & 22 | finalize_tau_sponge_damp, & 23 | sponge_damp_settings, & ! Variable type(s) 24 | sponge_damp_profile 25 | 26 | 27 | type sponge_damp_settings 28 | 29 | real( kind = core_rknd ) :: & 30 | tau_sponge_damp_min, & ! Minimum damping time scale (model top) [s] 31 | tau_sponge_damp_max, & ! Maximum damping time scale (damp layer base) [s] 32 | sponge_damp_depth ! Damping depth as a fraction of domain height [-] 33 | 34 | logical :: & 35 | l_sponge_damping ! True if damping is being used 36 | 37 | end type sponge_damp_settings 38 | 39 | type sponge_damp_profile 40 | 41 | real( kind = core_rknd ), allocatable, dimension(:) :: & 42 | tau_sponge_damp ! Damping time scale [1/s] 43 | 44 | real( kind = core_rknd ) :: & 45 | sponge_layer_depth ! Depth of sponge damping layer [m] 46 | 47 | end type sponge_damp_profile 48 | 49 | 50 | type(sponge_damp_settings), public :: & 51 | thlm_sponge_damp_settings, & ! Variable(s) 52 | rtm_sponge_damp_settings, & 53 | uv_sponge_damp_settings, & 54 | wp2_sponge_damp_settings, & 55 | wp3_sponge_damp_settings, & 56 | up2_vp2_sponge_damp_settings 57 | !$omp threadprivate( thlm_sponge_damp_settings, rtm_sponge_damp_settings, & 58 | !$omp uv_sponge_damp_settings, wp2_sponge_damp_settings, & 59 | !$omp wp3_sponge_damp_settings, up2_vp2_sponge_damp_settings ) 60 | 61 | type(sponge_damp_profile), public :: & 62 | thlm_sponge_damp_profile, & ! Variable(s) 63 | rtm_sponge_damp_profile, & 64 | uv_sponge_damp_profile, & 65 | wp2_sponge_damp_profile, & 66 | wp3_sponge_damp_profile, & 67 | up2_vp2_sponge_damp_profile 68 | !$omp threadprivate( thlm_sponge_damp_profile, rtm_sponge_damp_profile, & 69 | !$omp uv_sponge_damp_profile, wp2_sponge_damp_profile, & 70 | !$omp wp3_sponge_damp_profile, up2_vp2_sponge_damp_profile ) 71 | 72 | 73 | private 74 | 75 | contains 76 | 77 | !============================================================================= 78 | function sponge_damp_xm( dt, z, xm_ref, xm, damping_profile ) result( xm_p ) 79 | 80 | ! Description: 81 | ! Damps specified mean field toward a reference profile. The module must be 82 | ! initialized for this function to work. Otherwise a stop is issued. 83 | 84 | ! References: 85 | ! None 86 | !----------------------------------------------------------------------- 87 | 88 | ! "Sponge"-layer damping at the domain top region 89 | 90 | use grid_class, only: & 91 | gr ! Variable(s) 92 | 93 | use clubb_precision, only: & 94 | core_rknd ! Variable(s) 95 | 96 | implicit none 97 | 98 | ! External 99 | intrinsic :: allocated 100 | 101 | ! Input Variable(s) 102 | real( kind = core_rknd ), intent(in) :: & 103 | dt ! Model Timestep [s] 104 | 105 | real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & 106 | z, & ! Height of model grid levels [m] 107 | xm_ref, & ! Reference profile of x to damp xm towards [units vary] 108 | xm ! Mean field being damped [units vary] 109 | 110 | type(sponge_damp_profile), intent(in) :: & 111 | damping_profile 112 | 113 | ! Output Variable 114 | real( kind = core_rknd ), dimension(gr%nz) :: & 115 | xm_p ! Damped value of xm [units_vary] 116 | 117 | ! Local Variable(s) 118 | real( kind = core_rknd ) :: & 119 | dt_on_tau ! Ratio of timestep to damping timescale [-] 120 | 121 | integer :: k 122 | 123 | ! ---- Begin Code ---- 124 | 125 | if ( allocated( damping_profile%tau_sponge_damp ) ) then 126 | 127 | xm_p = xm 128 | 129 | do k = gr%nz, 1, -1 130 | 131 | ! The height of the model top is gr%zm(gr%nz). 132 | if ( gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth ) then 133 | 134 | ! Vince Larson used implicit discretization in order to 135 | ! reduce noise in rtm in cloud_feedback_s12 (CGILS) 136 | !xm_p(k) = xm(k) - real( ( ( xm(k) - xm_ref(k) ) / & 137 | ! damping_profile%tau_sponge_damp(k) ) * dt ) 138 | dt_on_tau = dt / damping_profile%tau_sponge_damp(k) 139 | 140 | ! Really, we should be using xm_ref at time n+1 rather than n. 141 | ! However, for steady profiles of xm_ref, it won't matter. 142 | xm_p(k) = ( xm(k) + dt_on_tau * xm_ref(k) ) / & 143 | ( 1.0_core_rknd + dt_on_tau ) 144 | ! End Vince Larson's change 145 | 146 | else ! gr%zm(gr%nz) - z(k) >= damping_profile%sponge_layer_depth 147 | 148 | ! Below sponge damping layer; exit loop. 149 | exit 150 | 151 | endif ! gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth 152 | 153 | 154 | enddo ! k = gr%nz, 1, -1 155 | 156 | else 157 | 158 | stop "tau_sponge_damp in sponge_damp_xm used before initialization" 159 | 160 | endif 161 | 162 | 163 | return 164 | 165 | end function sponge_damp_xm 166 | 167 | !============================================================================= 168 | function sponge_damp_xp2( dt, z, xp2, x_tol_sqd, damping_profile ) & 169 | result( xp2_damped ) 170 | 171 | ! Description: 172 | ! Calculates the effects of "sponge"-layer damping on the variance of x, 173 | ! xp2. 174 | ! 175 | ! Sponge damping on a local value of x is given by the equation: 176 | ! 177 | ! x_d = x - ( delta_t / tau ) * ( x - ), 178 | ! 179 | ! where x is the local value prior to damping, x_d is the damped local value 180 | ! of x, is the grid-level mean value of x, delta_t is the model time 181 | ! step duration, and tau is the damping time scale. Since delta_t / tau has 182 | ! the same value everywhere at a grid level, the grid-level mean of x does 183 | ! not change as a result of damping. 184 | ! 185 | ! Subtracting from both sides: 186 | ! 187 | ! x_d - = ( x - ) - ( delta_t / tau ) * ( x - ), 188 | ! 189 | ! which results in: 190 | ! 191 | ! x_d - = ( 1 - delta_t / tau ) * ( x - ). 192 | ! 193 | ! Squaring both sides: 194 | ! 195 | ! ( x_d - )^2 = ( 1 - delta_t / tau )^2 * ( x - )^2. 196 | ! 197 | ! After averaging both sides, the damped value of xp2 is: 198 | ! 199 | ! < x_d'^2 > = ( 1 - delta_t / tau )^2 * < x'^2 >. 200 | ! 201 | ! Any sponge damping is applied to (predictive) xp2 after the field has been 202 | ! advanced in time. This allows sponge damping to be applied in an implicit 203 | ! manner. The damped value of xp2 must also be limited at a minimum value 204 | ! of x_tol^2. 205 | 206 | ! References: 207 | !----------------------------------------------------------------------- 208 | 209 | use grid_class, only: & 210 | gr ! Variable(s) 211 | 212 | use constants_clubb, only: & 213 | one ! Constant(s) 214 | 215 | use clubb_precision, only: & 216 | core_rknd ! Variable(s) 217 | 218 | implicit none 219 | 220 | ! Input Variable(s) 221 | real( kind = core_rknd ), intent(in) :: & 222 | dt ! Model Timestep [s] 223 | 224 | real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & 225 | z, & ! Height of model grid levels [m] 226 | xp2 ! Variance of x, , prior to damping [units vary] 227 | 228 | real( kind = core_rknd ), intent(in) :: & 229 | x_tol_sqd ! Square of the tolerance value of x [units vary] 230 | 231 | type(sponge_damp_profile), intent(in) :: & 232 | damping_profile 233 | 234 | ! Output Variable 235 | real( kind = core_rknd ), dimension(gr%nz) :: & 236 | xp2_damped ! Variance of x, , after damping [units vary] 237 | 238 | ! Local Variable(s) 239 | real( kind = core_rknd ) :: & 240 | dt_on_tau ! Ratio of model time step duration to damping timescale [-] 241 | 242 | integer :: & 243 | k ! Loop index 244 | 245 | 246 | if ( allocated( damping_profile%tau_sponge_damp ) ) then 247 | 248 | ! Set the entire profile of after damping to the profile of 249 | ! before damping. The values of after damping will be overwritten 250 | ! at any levels where "sponge"-layer damping occurs. 251 | xp2_damped = xp2 252 | 253 | do k = gr%nz, 1, -1 254 | 255 | ! The height of the model top is gr%zm(gr%nz). 256 | if ( gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth ) then 257 | 258 | ! Calculate the value of delta_t / tau at the grid level. 259 | dt_on_tau = dt / damping_profile%tau_sponge_damp(k) 260 | 261 | ! Calculate the damped value of . 262 | xp2_damped(k) = ( one - dt_on_tau )**2 * xp2(k) 263 | 264 | ! The damped value of needs to be greater than or equal to 265 | ! x_tol^2. 266 | xp2_damped(k) = max( xp2_damped(k), x_tol_sqd ) 267 | 268 | else ! gr%zm(gr%nz) - z(k) >= damping_profile%sponge_layer_depth 269 | 270 | ! Below sponge damping layer; exit loop. 271 | exit 272 | 273 | endif ! gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth 274 | 275 | 276 | enddo ! k = gr%nz, 1, -1 277 | 278 | else 279 | 280 | stop "tau_sponge_damp in sponge_damp_xp2 used before initialization" 281 | 282 | endif 283 | 284 | 285 | return 286 | 287 | end function sponge_damp_xp2 288 | 289 | !============================================================================= 290 | function sponge_damp_xp3( dt, z, xp3, damping_profile ) & 291 | result( xp3_damped ) 292 | 293 | ! Description: 294 | ! Calculates the effects of "sponge"-layer damping on xp3. 295 | ! 296 | ! Sponge damping on a local value of x is given by the equation: 297 | ! 298 | ! x_d = x - ( delta_t / tau ) * ( x - ), 299 | ! 300 | ! where x is the local value prior to damping, x_d is the damped local value 301 | ! of x, is the grid-level mean value of x, delta_t is the model time 302 | ! step duration, and tau is the damping time scale. Since delta_t / tau has 303 | ! the same value everywhere at a grid level, the grid-level mean of x does 304 | ! not change as a result of damping. 305 | ! 306 | ! Subtracting from both sides: 307 | ! 308 | ! x_d - = ( x - ) - ( delta_t / tau ) * ( x - ), 309 | ! 310 | ! which results in: 311 | ! 312 | ! x_d - = ( 1 - delta_t / tau ) * ( x - ). 313 | ! 314 | ! Taking both sides to the third power: 315 | ! 316 | ! ( x_d - )^3 = ( 1 - delta_t / tau )^3 * ( x - )^3. 317 | ! 318 | ! After averaging both sides, the damped value of xp3 is: 319 | ! 320 | ! < x_d'^3 > = ( 1 - delta_t / tau )^3 * < x'^3 >. 321 | ! 322 | ! Any sponge damping is applied to (predictive) xp3 after the field has been 323 | ! advanced in time. This allows sponge damping to be applied in an implicit 324 | ! manner. 325 | 326 | ! References: 327 | !----------------------------------------------------------------------- 328 | 329 | use grid_class, only: & 330 | gr ! Variable(s) 331 | 332 | use constants_clubb, only: & 333 | one ! Constant(s) 334 | 335 | use clubb_precision, only: & 336 | core_rknd ! Variable(s) 337 | 338 | implicit none 339 | 340 | ! Input Variable(s) 341 | real( kind = core_rknd ), intent(in) :: & 342 | dt ! Model Timestep [s] 343 | 344 | real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & 345 | z, & ! Height of model grid levels [m] 346 | xp3 ! prior to damping [units vary] 347 | 348 | type(sponge_damp_profile), intent(in) :: & 349 | damping_profile 350 | 351 | ! Output Variable 352 | real( kind = core_rknd ), dimension(gr%nz) :: & 353 | xp3_damped ! after damping [units vary] 354 | 355 | ! Local Variable(s) 356 | real( kind = core_rknd ) :: & 357 | dt_on_tau ! Ratio of model time step duration to damping timescale [-] 358 | 359 | integer :: & 360 | k ! Loop index 361 | 362 | 363 | if ( allocated( damping_profile%tau_sponge_damp ) ) then 364 | 365 | ! Set the entire profile of after damping to the profile of 366 | ! before damping. The values of after damping will be overwritten 367 | ! at any levels where "sponge"-layer damping occurs. 368 | xp3_damped = xp3 369 | 370 | do k = gr%nz, 1, -1 371 | 372 | ! The height of the model top is gr%zm(gr%nz). 373 | if ( gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth ) then 374 | 375 | ! Calculate the value of delta_t / tau at the grid level. 376 | dt_on_tau = dt / damping_profile%tau_sponge_damp(k) 377 | 378 | ! Calculate the damped value of . 379 | xp3_damped(k) = ( one - dt_on_tau )**3 * xp3(k) 380 | 381 | else ! gr%zm(gr%nz) - z(k) >= damping_profile%sponge_layer_depth 382 | 383 | ! Below sponge damping layer; exit loop. 384 | exit 385 | 386 | endif ! gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth 387 | 388 | 389 | enddo ! k = gr%nz, 1, -1 390 | 391 | else 392 | 393 | stop "tau_sponge_damp in sponge_damp_xp3 used before initialization" 394 | 395 | endif 396 | 397 | 398 | return 399 | 400 | end function sponge_damp_xp3 401 | 402 | !============================================================================= 403 | subroutine initialize_tau_sponge_damp( dt, z, settings, damping_profile ) 404 | 405 | ! Description: 406 | ! Initialize time scale, tau_sponge_damp, used for damping. The time scale 407 | ! attains its maximum value, tau_sponge_damp_max, at the bottom of the 408 | ! "sponge" damping layer, which results in minimal damping. Likewise, the 409 | ! time scale attains its minimum value, tau_sponge_damp_min, at the top of 410 | ! the model, which results in maximum damping. At levels in-between the top 411 | ! of the model and the base of the sponge damping layer, the value of 412 | ! tau_sponge_damp is in-between tau_sponge_damp_min and tau_sponge_damp_max, 413 | ! as calculated by an interpolation formula. 414 | 415 | ! References: 416 | ! None 417 | !----------------------------------------------------------------------- 418 | 419 | use clubb_precision, only: & 420 | core_rknd ! Variable(s) 421 | 422 | use constants_clubb, only: & 423 | two, & ! Constant(s) 424 | fstderr 425 | 426 | use grid_class, only: & 427 | gr ! Variable(s) 428 | 429 | ! use interpolation, only: & 430 | ! lin_interpolate_two_points ! Procedure(s) 431 | 432 | implicit none 433 | 434 | ! Input Variable(s) 435 | real( kind = core_rknd ), intent(in) :: & 436 | dt ! Model Timestep [s] 437 | 438 | real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & 439 | z ! Height of model grid levels [m] 440 | 441 | type(sponge_damp_settings), intent(in) :: & 442 | settings 443 | 444 | ! Output Variable(s) 445 | type(sponge_damp_profile), intent(out) :: & 446 | damping_profile 447 | 448 | ! Local Variable(s) 449 | real( kind = core_rknd ) :: & 450 | tau_sponge_damp_exponent ! Exponent in calculation of tau_sponge_damp [-] 451 | 452 | integer :: & 453 | k ! Loop index 454 | 455 | ! ---- Begin Code ---- 456 | 457 | ! Allocate the damping time scale. 458 | allocate( damping_profile%tau_sponge_damp(1:gr%nz) ) 459 | 460 | ! Calculate the depth of the sponge layer. 461 | ! The height of the model top is gr%zm(gr%nz). 462 | damping_profile%sponge_layer_depth & 463 | = settings%sponge_damp_depth * gr%zm(gr%nz) 464 | 465 | ! Check the value of tau_sponge_damp_min. 466 | if ( settings%tau_sponge_damp_min < two * dt ) then 467 | write(fstderr,*) "Error: tau_sponge_damp_min is too small!" 468 | write(fstderr,*) "It must be at least 2.0 * dt" 469 | stop 470 | endif 471 | 472 | ! Calculate the value of the damping time scale, tau_sponge_damp, at levels 473 | ! that are within the sponge damping layer. 474 | do k = gr%nz, 1, -1 475 | 476 | ! The height of the model top is gr%zm(gr%nz). 477 | if ( gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth ) then 478 | 479 | ! Vince Larson added code to use standard linear interpolation. 480 | ! Brian Griffin reverted the linear interpolation in order to use code 481 | ! that is similar to what is found in SAM LES. 482 | 483 | tau_sponge_damp_exponent & 484 | = ( gr%zm(gr%nz) - z(k) ) / damping_profile%sponge_layer_depth 485 | 486 | damping_profile%tau_sponge_damp(k) & 487 | = settings%tau_sponge_damp_min & 488 | * ( settings%tau_sponge_damp_max & 489 | / settings%tau_sponge_damp_min )**tau_sponge_damp_exponent 490 | 491 | !damping_profile%tau_sponge_damp(k) & 492 | != lin_interpolate_two_points( z(k), gr%zm(gr%nz), & 493 | ! gr%zm(gr%nz) & 494 | ! - damping_profile%sponge_layer_depth, & 495 | ! settings%tau_sponge_damp_min, & 496 | ! settings%tau_sponge_damp_max ) 497 | 498 | ! End Vince Larson's change 499 | ! End Brian Griffin's rebellious reversion. 500 | 501 | else ! gr%zm(gr%nz) - z(k) >= damping_profile%sponge_layer_depth 502 | 503 | ! Below sponge damping layer; exit loop. 504 | exit 505 | 506 | endif ! gr%zm(gr%nz) - z(k) < damping_profile%sponge_layer_depth 507 | 508 | enddo ! k = gr%nz, 1, -1 509 | 510 | 511 | return 512 | 513 | end subroutine initialize_tau_sponge_damp 514 | 515 | !============================================================================= 516 | subroutine finalize_tau_sponge_damp( damping_profile ) 517 | 518 | ! Description: 519 | ! Frees memory allocated in initialize_tau_sponge_damp 520 | ! 521 | ! References: 522 | ! None 523 | !----------------------------------------------------------------------- 524 | 525 | implicit none 526 | 527 | ! Input/Output Variable(s) 528 | type(sponge_damp_profile), intent(inout) :: & 529 | damping_profile ! Information for damping the profile 530 | 531 | ! ---- Begin Code ---- 532 | 533 | ! Deallocate the damping time scale. 534 | deallocate( damping_profile%tau_sponge_damp ) 535 | 536 | 537 | return 538 | 539 | end subroutine finalize_tau_sponge_damp 540 | 541 | !=============================================================================== 542 | 543 | end module sponge_layer_damping 544 | --------------------------------------------------------------------------------