MODULE MP2M_GLOBALS !============================================================================ ! ! Purpose ! ------- ! Parameters and global variables module. ! Defines and initialize all the parameters and global variables that are ! common to all other modules of the library. ! ! It is separated in two parts : ! - Main parameters and global saved variables. Most of these variables should be initialized ! once and should hold the same value during run-time. These variables are completly public and ! initialized by [[mm_globals(module):mm_global_init(interface)]] method. ! - The second part defines a set of vectors that defines the vertical structure of the atmosphere. ! Each time a new atmospheric column has to be computed (either on a new timestep or on a new couple ! of longitude/latitude), these vectors should be intialized with new values by calling ! [[mm_globals(module):mm_column_init(function)]] method. ! ! @note ! All the vectors that represent the vertical structure of the atmosphere (altitude, pressure and ! temperature...) are oriented from the __TOP__ of the atmosphere to the __GROUND__. ! ! Global variables overview: ! - Protected variables ! - Control flags ! - Related free parameters ! - Physical constants ! - Free parameters ! - Miscellaneous parameters ! - Vertical structure part ! ! The module also contains twenty methods: ! - mm_global_init_0 ! - mm_global_init_1 ! - mm_column_init ! - mm_aerosols_init ! - mm_clouds_init ! - mm_alpha_s, mm_alpha_f ! - mm_set_moments_thresholds ! - mm_get_rcs, mm_get_rcf ! - mm_set_moments_cld_thresholds ! - cldprop_sc, cldprop_ve ! - read_esp ! - mm_effg ! - mm_dump_parameters ! - check_r1, check_l1, check_i1, check_s1 ! ! Authors ! ------- ! B. de Batz de Trenquelléon, J. Burgalat (11/2024) ! !============================================================================ USE MP2M_MPREC ! From lint USE LINT_DATASETS ! From swift USE SWIFT_CFGPARSE USE SWIFT_STRING_OP USE SWIFT_ERRORS IMPLICIT NONE PUBLIC PRIVATE :: cldprop_sc,cldprop_ve,read_esp,check_r1,check_i1,check_l1,check_s1 ! ~~~~~~~~~~~~~~~~~~~ ! Protected variables ! ~~~~~~~~~~~~~~~~~~~ ! The following variables are read-only outside this module. ! One must call the afferent subroutine to update them. ! Haze model: !~~~~~~~~~~~~ ! Initialization control flags (cannot be updated) PROTECTED :: mm_ini,mm_ini_col,mm_ini_aer ! Model parameters (mm_global_init) PROTECTED :: mm_dt,mm_rhoaer,mm_df,mm_rm,mm_call_CH4hazeprod,mm_p_prod,mm_rc_prod,mm_tx_prod,mm_rpla,mm_g0,mm_rb2ra ! Atmospheric vertical structure (mm_column_init) PROTECTED :: mm_nla,mm_nle,mm_zlay,mm_zlev,mm_play,mm_plev,mm_temp,mm_rhoair,mm_btemp,mm_dzlev,mm_dzlay ! Moments parameters (mm_aerosols_init) PROTECTED :: mm_m0aer_s, mm_m3aer_s, mm_m0aer_f, mm_m3aer_f ! Moments parameters (derived, are updated with moments parameters) PROTECTED :: mm_rcs, mm_rcf ! Thresholds parameters PROTECTED :: mm_m0as_min, mm_m3as_min, mm_rcs_min, mm_m0af_min, mm_m3af_min, mm_rcf_min ! Cloud model: !~~~~~~~~~~~~~ ! Initialization control flags (cannot be updated) PROTECTED :: mm_ini_cld ! Condensible species parameters (mm_global_init) PROTECTED :: mm_nesp, mm_spcname, mm_xESPS ! Condensible species parameters (mm_clouds_init) PROTECTED :: mm_gas ! Moments parameters (mm_clouds_init) PROTECTED :: mm_m0ccn, mm_m3ccn, mm_m3ice ! Moments parameters (derived, are updated with moments parameters) PROTECTED :: mm_drad, mm_drho ! Thresholds parameters PROTECTED :: mm_m0ccn_min, mm_m3ccn_min, mm_m3cld_min, mm_drad_min, mm_drad_max ! ~~~~~~~~~~~~~ ! Control flags ! ~~~~~~~~~~~~~ ! Haze model: !~~~~~~~~~~~~ ! Enable/Disable haze production. LOGICAL, SAVE :: mm_call_hazeprod = .true. ! Enable/Disable haze production from CH4 photolysis. LOGICAL, SAVE :: mm_call_CH4hazeprod = .true. ! Enable/Disable haze sedimentation. LOGICAL, SAVE :: mm_call_hazesed = .true. ! Enable/Disable haze coagulation. LOGICAL, SAVE :: mm_call_hazecoag = .true. ! Force all aerosols moments to fall at M0 settling velocity. LOGICAL, SAVE :: mm_wsed_m0 = .false. ! Force all aerosols moments to fall at M3 settling velocity. LOGICAL, SAVE :: mm_wsed_m3 = .false. ! Enable/Disable spherical probability transfert. LOGICAL, SAVE :: mm_call_ps2s = .true. ! Enable/Disable aerosol electric charge correction. LOGICAL, SAVE :: mm_call_qe = .true. ! Cloud model: !~~~~~~~~~~~~~ ! Enable/Disable clouds microphysics. LOGICAL, SAVE :: mm_call_clouds = .false. ! Enable/Disable QnD debug mode (can be used for devel). LOGICAL, SAVE :: mm_debug = .false. ! Enable/Disable log mode (for configuration only). LOGICAL, SAVE :: mm_log = .false. ! Enable/Disable effective G for computations. LOGICAL, SAVE :: mm_use_effg = .true. ! Initialization control flag [[mm_globals(module):mm_global_init(interface)]]. LOGICAL, PUBLIC, SAVE :: mm_ini = .false. ! Initialization control flag [[mm_globals(module):mm_column_init(function)]]. LOGICAL, PUBLIC, SAVE :: mm_ini_col = .false. ! Initialization control flag [[mm_globals(module):mm_aerosols_init(function)]]. LOGICAL, PUBLIC, SAVE :: mm_ini_aer = .false. ! Initialization control flag [[mm_globals(module):mm_clouds_init(function)]]. LOGICAL, PUBLIC, SAVE :: mm_ini_cld = .false. ! ~~~~~~~~~~~~~~~~~~~~~~~ ! Related free parameters ! ~~~~~~~~~~~~~~~~~~~~~~~ ! No mode interaction for coagulation (i.e. no coagulation at all). INTEGER, PARAMETER :: mm_coag_no = 0 ! SS mode interaction for coagulation. INTEGER, PARAMETER :: mm_coag_ss = 1 ! SF mode interaction for coagulation. INTEGER, PARAMETER :: mm_coag_sf = 2 ! FF mode interaction for coagulation. INTEGER, PARAMETER :: mm_coag_ff = 4 ! Default interactions to activate (all by default). INTEGER, SAVE :: mm_coag_choice = mm_coag_ss+mm_coag_sf+mm_coag_ff ! ~~~~~~~~~~~~~~~~~~ ! Physical constants ! ~~~~~~~~~~~~~~~~~~ ! Pi number. REAL(kind=mm_wp), PARAMETER :: mm_pi = 4._mm_wp*atan(1._mm_wp) ! Avogadro number (mol-1). REAL(kind=mm_wp), PARAMETER :: mm_navo = 6.0221367e23_mm_wp ! Boltzmann constant (J.K-1). REAL(kind=mm_wp), PARAMETER :: mm_kboltz = 1.3806488e-23_mm_wp ! Perfect gas constant (J.mol-1.K-1). REAL(kind=mm_wp), PARAMETER :: mm_rgas = mm_kboltz * mm_navo ! Approximated slip-flow correction coefficient. REAL(kind=mm_wp), PARAMETER :: mm_akn = 1.591_mm_wp ! ~~~~~~~~~~~~~~~ ! Free parameters ! ~~~~~~~~~~~~~~~ ! Haze model: !~~~~~~~~~~~~ ! Spherical aerosol production pressure level (Pa). REAL(kind=mm_wp), SAVE :: mm_p_prod = 1.e-2_mm_wp ! Spherical aerosol production rate (kg.m-2.s-1). REAL(kind=mm_wp), SAVE :: mm_tx_prod = 9.8e-14_mm_wp ! Spherical aerosol equivalent radius production (m) REAL(kind=mm_wp), SAVE :: mm_rc_prod = 1.e-9_mm_wp ! Monomer radius (m). REAL(kind=mm_wp), SAVE :: mm_rm = 1.e-8_mm_wp ! Fractal dimension of fractal aerosols. REAL(kind=mm_wp), SAVE :: mm_df = 2._mm_wp ! Aerosol density (kg.m-3). REAL(kind=mm_wp), SAVE :: mm_rhoaer = 8.e2_mm_wp ! Total number of aerosols minimum threshold for the spherical mode. REAL(kind=mm_wp), SAVE :: mm_m0as_min = 1.e-8_mm_wp ! Total volume of aerosols minimum threshold for the spherical mode. REAL(kind=mm_wp), SAVE :: mm_m3as_min = 1.e-35_mm_wp ! Characteristic radius minimum threshold for the spherical mode. REAL(kind=mm_wp), SAVE :: mm_rcs_min = 1.e-9_mm_wp ! Total number of aerosols minimum threshold for the fractal mode. REAL(kind=mm_wp), SAVE :: mm_m0af_min = 1.e-8_mm_wp ! Total volume of aerosols minimum threshold for the fractal mode. REAL(kind=mm_wp), SAVE :: mm_m3af_min = 1.e-35_mm_wp ! Characteristic radius minimum threshold for the fractal mode. REAL(kind=mm_wp), SAVE :: mm_rcf_min = 1.e-9_mm_wp ! Cloud model: !~~~~~~~~~~~~~ ! Total number of cloud condensation nuclei minimum threshold. REAL(kind=mm_wp), SAVE :: mm_m0ccn_min = 1.e-8_mm_wp ! Total volume of cloud condensation nuclei minimum threshold. REAL(kind=mm_wp), SAVE :: mm_m3ccn_min = 1.e-35_mm_wp ! Total volume of cloud drop minimum threshold. REAL(kind=mm_wp), SAVE :: mm_m3cld_min = 1.e-35_mm_wp ! Characteristic cloud drop radius minimum threshold. REAL(kind=mm_wp), SAVE :: mm_drad_min = 1.e-9_mm_wp ! Characteristic cloud drop radius Maximum threshold. REAL(kind=mm_wp), SAVE :: mm_drad_max = 1.e-3_mm_wp ! Planet radius (m) and gravity acceleration (m.s-2). ! WARNING: initialization for Pluto. REAL(kind=mm_wp), SAVE :: mm_rpla = 1187000._mm_wp REAL(kind=mm_wp), SAVE :: mm_g0 = 0.617_mm_wp ! Air molecules mean radius (m), molar mass (kg.mol-1), and molecular mass (kg). ! WARNING: initialization for N2. REAL(kind=mm_wp), SAVE :: mm_air_rad = 1.75e-10_mm_wp REAL(kind=mm_wp), SAVE :: mm_air_mmol = 28.e-3_mm_wp REAL(kind=mm_wp), SAVE :: mm_air_mmas = 28.e-3_mm_wp / mm_navo ! Microphysical time-step (s). REAL(kind=mm_wp), SAVE :: mm_dt = 180._mm_wp ! ~~~~~~~~~~~~~~~~~~~~~~~~ ! Miscellaneous parameters ! ~~~~~~~~~~~~~~~~~~~~~~~~ ! Bulk to apparent radius (Haze model) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Bulk to apparent radius conversion pre-factor (m^X). ! ! With r_a = r_b^(3/Df) . r_m^((Df-3)/(Df)) ! Then rb2ra = r_m^((Df-3)/(Df)) REAL(kind=mm_wp), SAVE :: mm_rb2ra = 1._mm_wp ! Inter-moment relation (Haze model) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Alpha function parameters. ! It stores the parameters of the inter-moments relation functions. ! ! The inter-moments relation function is represented by the sum of exponential quadratic expressions: ! alpha(k) = Sum_{i=1}^{n} exp(a_i.k^2 + bi.k^2 + c_i) TYPE, PUBLIC :: aprm ! Quadratic coefficients of the quadratic expressions. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: a ! Linear coefficients of the quadratic expressions. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: b ! Free term of the quadratic expressions. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE :: c END TYPE ! Inter-moment relation set of parameters for the spherical mode. TYPE(aprm), PUBLIC, SAVE :: mm_asp ! Inter-moment relation set of parameters for the fractal mode. TYPE(aprm), PUBLIC, SAVE :: mm_afp ! Transfert probabilities (S --> F) (Haze model) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Data set for linear interpolation of transfert probability (M0/CO). TYPE(dset1d), PUBLIC, SAVE, TARGET :: mm_pco0p ! Data set for linear interpolation of transfert probability (M3/CO). TYPE(dset1d), PUBLIC, SAVE, TARGET :: mm_pco3p ! Data set for linear interpolation of transfert probability (M0/FM). TYPE(dset1d), PUBLIC, SAVE, TARGET :: mm_pfm0p ! Data set for linear interpolation of transfert probability (M3/FM). TYPE(dset1d), PUBLIC, SAVE, TARGET :: mm_pfm3p ! Mean electric correction (Haze model) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Data set for Q_SF(M0). TYPE(dset2d), PUBLIC, SAVE, TARGET :: mm_qbsf0 ! Extended values of [[mm_gcm(module):mm_qbsf0(variable)]] dataset. REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mm_qbsf0_e ! Data set for Q_SF(M3). TYPE(dset2d), PUBLIC, SAVE, TARGET :: mm_qbsf3 ! Extended values of [[mm_gcm(module):mm_qbsf3(variable)]] dataset. REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mm_qbsf3_e ! Data set for Q_FF(M0). TYPE(dset2d), PUBLIC, SAVE, TARGET :: mm_qbff0 ! Extended values of [[mm_gcm(module):mm_qbff0(variable)]] dataset. REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(2,2) :: mm_qbff0_e ! btk coefficients (Haze model) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Coefficients for Free-molecular regime kernel approximation (b_0(t)). REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(5) :: mm_bt0 = (/1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp/) ! Coefficients for Free-molecular regime kernel approximation (b_3(t)). REAL(kind=mm_wp), PUBLIC, SAVE, DIMENSION(5) :: mm_bt3 = (/1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp,1._mm_wp/) ! Chemical species properties (Cloud model) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ TYPE, PUBLIC :: mm_esp !! Cloud related chemical species properties. !! This derived type is used in thermodynamic methods related to cloud microphysics. !! CHARACTER(LEN=10) :: name !! Specie name. REAL(kind=mm_wp) :: mas !! Molecular weight (kg). REAL(kind=mm_wp) :: vol !! Molecular volume (m3). REAL(kind=mm_wp) :: ray !! Molecular radius (m). REAL(kind=mm_wp) :: masmol !! Molar mass (kg.mol-1). REAL(kind=mm_wp) :: rho_l !! Liquid density (kg.m-3). REAL(kind=mm_wp) :: rho_s !! Ice density (kg.m-3). REAL(kind=mm_wp) :: Tc !! Critical temperature (K). REAL(kind=mm_wp) :: pc !! Critical pressure (Bar). REAL(kind=mm_wp) :: Tb !! Boiling point temperature (K). REAL(kind=mm_wp) :: w !! Acentric factor. REAL(kind=mm_wp) :: a0_sat !! Saturation equation A0 coefficient. REAL(kind=mm_wp) :: a1_sat !! Saturation equation A1 coefficient. REAL(kind=mm_wp) :: a2_sat !! saturation equation A2 coefficient. REAL(kind=mm_wp) :: a3_sat !! Saturation equation A3 coefficient. REAL(kind=mm_wp) :: a4_sat !! Saturation equation A4 coefficient. REAL(kind=mm_wp) :: a5_sat !! Saturation equation A5 coefficient. REAL(kind=mm_wp) :: a6_sat !! Saturation equation A6 coefficient. REAL(kind=mm_wp) :: mteta !! Wettability. REAL(kind=mm_wp) :: fdes !! Desorption energy (J). REAL(kind=mm_wp) :: fdif !! Surface diffusion energy (J). REAL(kind=mm_wp) :: nus !! Jump frequency (s-1). REAL(kind=mm_wp) :: fmol2fmas !! Molar fraction to mass fraction coefficient = masmol(X)/masmol(AIR) END TYPE mm_esp ! Name of condensible species. CHARACTER(len=30), DIMENSION(:), ALLOCATABLE, SAVE :: mm_spcname ! Total number of clouds condensible species. INTEGER, SAVE :: mm_nesp = -1 ! Clouds chemical species properties. TYPE(mm_esp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_xESPS ! ~~~~~~~~~~~~~~~~~~~~~~~ ! Vertical structure part ! ~~~~~~~~~~~~~~~~~~~~~~~ ! Number of vertical layers. INTEGER, SAVE :: mm_nla = -1 ! Number of vertical levels. INTEGER, SAVE :: mm_nle = -1 ! Altitude layers (m). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_zlay ! Altitude levels (m). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_zlev !> Pressure layers (Pa). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_play ! Pressure levels (Pa). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_plev ! Temperature vertical profile (K). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_temp ! Air density vertical profile (kg.m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_rhoair ! Temperature vertical profil at interfaces (K). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_btemp ! Atmospheric levels thickness (m). ! @note: __mm_dzlev__ is defined on the total number of layers and actually ! corresponds to the thickness of a given layer. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_dzlev ! Atmospheric layers thickness (m). ! @note: __mm_dzlay__ is defined on the total number of layers. The last ! value of __mm_dzlay__ is set to twice the altitude of the ground layer. ! This value corresponds to the thickness between the center of the ! __GROUND__ layer and below the surface. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_dzlay ! Haze model: ! ~~~~~~~~~~~ ! Spherical mode - 0th order moment (m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0aer_s ! Spherical mode - 3rd order moment (m3.m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3aer_s ! Spherical mode - characteristic radius (m). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_rcs ! Fractal mode - 0th order moment (m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0aer_f ! Fractal mode - 3rd order moment (m3.m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3aer_f ! Fractal mode - characteristic radius (m). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_rcf ! Spherical aerosol precipitation (kg.m-2). REAL(kind=mm_wp), SAVE :: mm_aers_prec = 0._mm_wp ! Fractal aerosol precipitation (kg.m-2). REAL(kind=mm_wp), SAVE :: mm_aerf_prec = 0._mm_wp ! Spherical mode (M0) settling velocity (m.s-1). ! @note: This variable is always negative. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0as_vsed ! Spherical mode (M3) settling velocity (m.s-1). ! @note: This variable is always negative. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3as_vsed ! Fractal mode (M0) settling velocity (m.s-1). ! @note: This variable is always negative. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0af_vsed ! Fractal mode (M3) settling velocity (m.s-1). ! @note: This variable is always negative. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3af_vsed ! Spherical aerosol mass fluxes (kg.m-2.s-1). ! @note: This variable is always negative. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_aer_s_flux ! Fractal aerosol mass fluxes (kg.m-2.s-1). ! @note: This variable is always negative. REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_aer_f_flux ! Cloud model: ! ~~~~~~~~~~~~ ! Cloud condensation nuclei - 0th order moment (m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m0ccn ! Cloud condensation nuclei - 3rd order moment (m3.m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_m3ccn ! Mean drop radius (m). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_drad ! Mean Drop density (kg.m-3). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_drho ! Ice components - 3rd order moments (m3.m-3). ! It is a 2D array with the vertical layers in first dimension, and ! the number of ice components in the second. REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_m3ice ! Condensible species molar fraction (mol.mol-1). ! It is a 2D array with the vertical layers in first dimension, and ! the number of condensible species in the second. REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_gas ! CCN precipitation (kg.m-2). REAL(kind=mm_wp), SAVE :: mm_ccn_prec = 0._mm_wp ! Ice components precipitation (kg.m-2). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_ice_prec ! CCN (and ices) settling velocity (m.s-1). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_cld_vsed ! CCN mass fluxes (kg.m-2.s-1). REAL(kind=mm_wp), DIMENSION(:), ALLOCATABLE, SAVE :: mm_ccn_flux ! Ice components sedimentation fluxes (kg.m-2.s-1). REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_ice_fluxes ! Condensible species saturation ratio. REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_gas_sat ! Condensible components nucleation rates (m-2.s-1). REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_nrate ! Condensible components growth rates (m2.s-1). REAL(kind=mm_wp), DIMENSION(:,:), ALLOCATABLE, SAVE :: mm_grate ! --- OPENMP --------------- ! All variables related to column computations should be private to each thread !$OMP THREADPRIVATE(mm_ini_col,mm_ini_aer,mm_ini_cld) !$OMP THREADPRIVATE(mm_zlay,mm_zlev,mm_play,mm_plev,mm_temp,mm_rhoair,mm_btemp,mm_dzlev,mm_dzlay) !$OMP THREADPRIVATE(mm_m0aer_s,mm_m3aer_s,mm_m0aer_f,mm_m3aer_f) !$OMP THREADPRIVATE(mm_m0ccn,mm_m3ccn,mm_m3ice,mm_gas) !$OMP THREADPRIVATE(mm_rcs,mm_rcf,mm_drad,mm_drho) !$OMP THREADPRIVATE(mm_m0as_vsed,mm_m3as_vsed,mm_m0af_vsed,mm_m3af_vsed,mm_cld_vsed) !$OMP THREADPRIVATE(mm_aer_s_flux,mm_aer_f_flux,mm_ccn_prec,mm_ice_prec,mm_ccn_flux,mm_ice_fluxes,mm_gas_sat,mm_nrate,mm_grate) !$OMP THREADPRIVATE(mm_m0as_min,mm_m3as_min,mm_rcs_min,mm_m0af_min,mm_m3af_min,mm_rcf_min) !$OMP THREADPRIVATE(mm_m0ccn_min,mm_m3ccn_min,mm_m3cld_min,mm_drad_min,mm_drad_max) !$OMP THREADPRIVATE(mm_nla,mm_nle) ! -------------------------- ! Interface to global initialization. ! The method performs the global initialization of the model. INTERFACE mm_global_init MODULE PROCEDURE mm_global_init_0,mm_global_init_1 END INTERFACE mm_global_init ! Check an option from the configuration system. ! The method checks for an option in the configuration system and optionally ! set a default value if the option is not found. This is an overloaded method ! that can take in input either a floating point, integer, logical or string ! option value. INTERFACE mm_check_opt MODULE PROCEDURE check_r1,check_i1,check_l1,check_s1 END INTERFACE mm_check_opt ! Interface to cloud properties methods. ! The method computes clouds properties (mean drop radius and denstity) from their afferent ! moments. It is overloaded to compute properties at a single level or over all the vertical ! atmospheric structure. INTERFACE mm_cloud_properties MODULE PROCEDURE cldprop_sc,cldprop_ve END INTERFACE mm_cloud_properties CONTAINS !============================================================================ ! INITIALIZATION METHODS !============================================================================ FUNCTION mm_global_init_0(dt,df,rm,rho_aer,call_CH4hazeprod,p_prod,tx_prod,rc_prod, & rplanet,g0,air_rad,air_mmol, & coag_interactions,call_hazeprod,call_hazesed,call_hazecoag,& force_wsed_to_m0,force_wsed_to_m3, & m0as_min,rcs_min,m0af_min,rcf_min, & clouds,spcfile,m0ccn_min,drad_min,debug) RESULT(err) !! Initialize global parameters of the model. !! !! The function initializes all the global parameters of the model from direct input. !! Store input values in global variables !! !! @note !! If the method fails to initialize parameters the model should be aborted as the !! global variables of the model will not be correctly setup. !! ! Microphysical timestep (s). REAL(kind=mm_wp), INTENT(in) :: dt ! Fractal dimension of fractal aerosol (-). REAL(kind=mm_wp), INTENT(in) :: df ! Monomer radius (m). REAL(kind=mm_wp), INTENT(in) :: rm ! Aerosol density(kg.m-3). REAL(kind=mm_wp), INTENT(in) :: rho_aer ! Enable/Disable production from CH4 photolysis. LOGICAL, INTENT(in) :: call_CH4hazeprod ! Aerosol production pressure level (Pa). REAL(kind=mm_wp), INTENT(in) :: p_prod ! Spherical aerosol production rate kg.m-2.s-1). REAL(kind=mm_wp), INTENT(in) :: tx_prod ! Spherical aerosol characteristic radius of production (m). REAL(kind=mm_wp), INTENT(in) :: rc_prod ! Planet radius (m). REAL(kind=mm_wp), INTENT(in) :: rplanet ! Planet gravity acceleration at ground level (m.s-2). REAL(kind=mm_wp), INTENT(in) :: g0 ! Radius of air molecules (m). REAL(kind=mm_wp), INTENT(in) :: air_rad ! Molar mass of air molecules (kg.mol-1). REAL(kind=mm_wp), INTENT(in) :: air_mmol ! Coagulation interactions process control flag. INTEGER, INTENT(in) :: coag_interactions ! Haze production process control flag. LOGICAL, INTENT(in) :: call_hazeprod ! Haze sedimentation process control flag. LOGICAL, INTENT(in) :: call_hazesed ! Haze coagulation process control flag. LOGICAL, INTENT(in) :: call_hazecoag ! Force __all__ aerosols moments to fall at M0 settling velocity. LOGICAL, INTENT(in) :: force_wsed_to_m0 ! Force __all__ aerosols moments to fall at M3 settling velocity LOGICAL, INTENT(in) :: force_wsed_to_m3 ! Minimum threshold for M0 of the spherical mode (m-3). REAL(kind=mm_wp), INTENT(in) :: m0as_min ! Minimum threshold for the characteristic radius of the spherical mode (m). REAL(kind=mm_wp), INTENT(in) :: rcs_min ! Minimum threshold for M0 of the factal mode (m-3). REAL(kind=mm_wp), INTENT(in) :: m0af_min ! Minimum threshold for the characteristic radius of the fractal mode (m). REAL(kind=mm_wp), INTENT(in) :: rcf_min ! Clouds microphysics control flag. LOGICAL, INTENT(in) :: clouds ! Clouds microphysics condensible species properties file. CHARACTER(len=*), INTENT(in) :: spcfile ! Minimum threshold for M0 of cloud condensation nuceli (m-3). REAL(kind=mm_wp), INTENT(in) :: m0ccn_min ! Minimum threshold for the cloud drop radius (m). REAL(kind=mm_wp), INTENT(in) :: drad_min ! Debug mode control flag. LOGICAL, INTENT(in) :: debug ! Error status of the function. TYPE(error) :: err ! Local variables: INTEGER :: i TYPE(cfgparser) :: cp CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: species err = noerror ! Sanity check: IF (mm_ini) THEN err = error("mm_global_init: YAMMS global initialization already performed !",-1) RETURN ENDIF ! Free parameters: mm_dt = dt mm_df = df mm_rm = rm mm_rhoaer = rho_aer mm_call_CH4hazeprod = call_CH4hazeprod mm_p_prod = p_prod mm_tx_prod = tx_prod mm_rc_prod = rc_prod mm_rpla = rplanet mm_g0 = g0 mm_air_rad = air_rad mm_air_mmol = air_mmol mm_air_mmas = air_mmol / mm_navo ! Microphysical processes - Haze: mm_coag_choice = coag_interactions IF (mm_coag_choice < 0 .OR. mm_coag_choice > 7) THEN err = error("mm_global_init: Invalid choice for coagulation interactions activation",-1) RETURN ENDIF mm_call_hazeprod = call_hazeprod mm_call_hazesed = call_hazesed mm_call_hazecoag = call_hazecoag mm_wsed_m0 = force_wsed_to_m0 mm_wsed_m3 = force_wsed_to_m3 ! Moment threshold flags: mm_m0as_min = MAX(0._mm_wp,m0as_min) mm_rcs_min = MAX(1.e-9_mm_wp,rcs_min) mm_m0af_min = MAX(0._mm_wp,m0af_min) mm_rcf_min = MAX(mm_rm,rcf_min) ! Computes M3 thresholds from user-defined thresholds: mm_m3as_min = mm_m0as_min*mm_alpha_s(3._mm_wp) * mm_rcs_min**3._mm_wp mm_m3af_min = mm_m0af_min*mm_alpha_f(3._mm_wp) * mm_rcf_min**3._mm_wp ! Microphysical processes - Clouds: mm_call_clouds = clouds ! Check clouds microphysics species file IF (mm_call_clouds) THEN IF (LEN_TRIM(spcfile) == 0) THEN err = error("mm_global_init: No species properties file given",-1) RETURN ENDIF ! Reads species properties configuration file err = cfg_read_config(cp,TRIM(spcfile)) IF (err /= 0) THEN write(*,*) err RETURN ENDIF ! Reads used species err = cfg_get_value(cp,"used_species",species) IF (err /= 0) THEN err = error("mm_global_init: cannot retrieve 'used_species' values",-1) RETURN ENDIF mm_nesp = SIZE(species) ALLOCATE(mm_spcname(mm_nesp),mm_xESPS(mm_nesp)) ! Reads used species properties DO i=1,mm_nesp mm_spcname(i) = TRIM(species(i)) IF(.NOT.cfg_has_section(cp,TRIM(mm_spcname(i)))) THEN err = error("mm_global_init: Cannot find "//TRIM(mm_spcname(i))//" properties",-1) RETURN ELSE err = read_esp(cp,TRIM(mm_spcname(i)),mm_xESPS(i)) ! Compute conversion factor: mol.mol-1 => kg.kg-1 mm_xESPS(i)%fmol2fmas = mm_xESPS(i)%masmol / mm_air_mmol IF (err/=0) THEN err = error("mm_global_init: "//TRIM(mm_spcname(i))//": "//TRIM(err%msg),-1) RETURN ENDIF ENDIF ENDDO ! Moment threshold flags: mm_m0ccn_min = MAX(0._mm_wp,m0ccn_min) mm_drad_min = MAX(1.e-9_mm_wp,drad_min) ! Computes M3 thresholds: mm_m3ccn_min = mm_m0ccn_min*mm_alpha_s(3._mm_wp) * mm_rcs_min**3._mm_wp mm_m3cld_min = mm_m0ccn_min * mm_drad_min**3._mm_wp ENDIF ! end of mm_call_clouds ! Debug mode: mm_debug = debug ! Computes conversion factor for bulk to apparent radius: mm_rb2ra = mm_rm**((mm_df-3._mm_wp)/mm_df) ! Sanity check for settling velocity: IF (mm_wsed_m0 .AND. mm_wsed_m3) THEN err = error("'wsed_m0' and 'wsed_m3' options are mutually exclusive",-1) ENDIF ! End of initialization: mm_ini = err == noerror END FUNCTION mm_global_init_0 FUNCTION mm_global_init_1(cfg) RESULT(err) !! Set global configuration from a configuration file. !! !! @note: !! See [[mm_globals(module):mm_global_init_0(function)]]. !! ! Configuration file path. TYPE(cfgparser), INTENT(in) :: cfg ! Error status of the function. TYPE(error) :: err ! Local variables: INTEGER :: i TYPE(cfgparser) :: spccfg CHARACTER(len=st_slen) :: spcpath CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: species err = noerror ! Sanity check: IF (mm_ini) THEN err = error("mm_global_init: YAMMS global initialization already performed !",-1) RETURN ENDIF ! Free parameters: err = mm_check_opt(cfg_get_value(cfg,"timestep",mm_dt),mm_dt,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"df",mm_df),mm_df,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"rm",mm_rm),mm_rm,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"rho_aer",mm_rhoaer),mm_rhoaer,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"call_haze_prod",mm_call_CH4hazeprod),mm_call_CH4hazeprod,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"p_prod",mm_p_prod),mm_p_prod,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"tx_prod",mm_tx_prod),mm_tx_prod,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"rc_prod",mm_rc_prod),mm_rc_prod,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"planet_radius",mm_rpla),mm_rpla,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"g0",mm_g0),mm_g0,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"air_radius",mm_air_rad),mm_air_rad,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"air_molarmass",mm_air_mmol),mm_air_mmol,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"air_molecularmass",mm_air_mmas),mm_air_mmas,wlog=mm_log) IF (err/=0) RETURN ! Microphysical processes - Haze: err = mm_check_opt(cfg_get_value(cfg,"haze_coag_interactions",mm_coag_choice),mm_coag_choice,wlog=mm_log) IF (err/=0) RETURN IF (mm_coag_choice < 0 .OR. mm_coag_choice > 7) THEN err = error("mm_global_init: Invalid choice for coagulation interactions activation",-1) RETURN ENDIF err = mm_check_opt(cfg_get_value(cfg,"haze_production",mm_call_hazeprod),mm_call_hazeprod,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"haze_sedimentation",mm_call_hazesed),mm_call_hazesed,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"haze_coagulation",mm_call_hazecoag),mm_call_hazecoag,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"wsed_m0",mm_wsed_m0),mm_wsed_m0,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"wsed_m3",mm_wsed_m3),mm_wsed_m3,wlog=mm_log) IF (err/=0) RETURN ! Moment threshold flags: err = mm_check_opt(cfg_get_value(cfg,"m0as_min",mm_m0as_min),mm_m0as_min,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"rcs_min",mm_rcs_min),mm_rcs_min,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"m0af_min",mm_m0af_min),mm_m0af_min,wlog=mm_log) IF (err/=0) RETURN err = mm_check_opt(cfg_get_value(cfg,"rcf_min",mm_rcf_min),mm_rcf_min,wlog=mm_log) IF (err/=0) RETURN ! Microphysical processes - Clouds: err = mm_check_opt(cfg_get_value(cfg,"clouds_microphysics",mm_call_clouds),mm_call_clouds,wlog=mm_log) IF (err/=0) RETURN ! Check clouds microphysics input IF (mm_call_clouds) THEN ! Gets species property file path err = cfg_get_value(cfg,'species_cfg',spcpath) ; IF (err /= 0) RETURN ! Reads species properties configuration file err = cfg_read_config(spccfg,trim(spcpath)) ; IF (err /= 0) RETURN err = cfg_get_value(spccfg,"used_species",species) IF (err /= 0) THEN err = error("mm_global_init: cannot retrieve 'used_species' values",-1) RETURN ENDIF mm_nesp = SIZE(species) ALLOCATE(mm_spcname(mm_nesp),mm_xESPS(mm_nesp)) DO i=1,mm_nesp mm_spcname(i) = TRIM(species(i)) IF (.NOT.cfg_has_section(spccfg,TRIM(mm_spcname(i)))) THEN err = error("mm_global_init: Cannot find "//TRIM(mm_spcname(i))//" properties",-1) RETURN ELSE err = read_esp(spccfg,TRIM(mm_spcname(i)),mm_xESPS(i)) ! Compute conversion factor: mol.mol-1 => kg.kg-1 mm_xESPS(i)%fmol2fmas = mm_xESPS(i)%masmol / mm_air_mmol IF (err/=0) THEN err = error(TRIM(mm_spcname(i))//": "//TRIM(err%msg),-2) RETURN ENDIF ENDIF ENDDO ENDIF ! Debug mode: err = mm_check_opt(cfg_get_value(cfg,"debug",mm_debug),mm_debug,wlog=mm_log) IF (err/=0) RETURN ! Computes M3 thresholds from user-defined thresholds: mm_m0as_min = MAX(0._mm_wp,mm_m0as_min) mm_rcs_min = MAX(1.e-10_mm_wp,mm_rcs_min) mm_m0af_min = MAX(0._mm_wp,mm_m0af_min) mm_rcf_min = MAX(mm_rm,mm_rcf_min) mm_m3as_min = mm_m0as_min*mm_alpha_s(3._mm_wp) * mm_rcs_min**3._mm_wp mm_m3af_min = mm_m0af_min*mm_alpha_f(3._mm_wp) * mm_rcf_min**3._mm_wp ! Computes conversion factor for bulk to apparent radius: mm_rb2ra = mm_rm**((mm_df-3._mm_wp)/mm_df) ! Sanity check for settling velocity: IF (mm_wsed_m0 .AND. mm_wsed_m3) THEN err = error("'wsed_m0' and 'wsed_m3' options are mutually exclusive",-1) ENDIF ! End of initialization: mm_ini = err == noerror END FUNCTION mm_global_init_1 FUNCTION mm_column_init(plev,zlev,play,zlay,temp) RESULT(err) !! Initialize vertical atmospheric fields. !! !! This subroutine initializes vertical fields needed by the microphysics: !! 1. Save reversed input field into "local" array !! 2. Compute thicknesses layers and levels !! 3. Interpolate temperature at levels !! !! @warning !! The method should be called whenever the vertical structure of the atmosphere changes. !! All the input vectors should be defined from __GROUND__ to __TOP__ of the atmosphere, !! otherwise nasty things will occur in computations. !! REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: plev ! Pressure levels (Pa). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: zlev ! Altitude levels (m). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: play ! Pressure layers (Pa). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: zlay ! Altitude at the center of each layer (m). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: temp ! Temperature at the center of each layer (K). TYPE(error) :: err ! Error status of the function. INTEGER :: i err = noerror mm_ini_col = .false. ! Global initialization must be done before: IF (.NOT.mm_ini) THEN err = error("mm_column_init: Global initialization not done yet",-1) RETURN ENDIF ! Check number of vertical layers: IF (mm_nla < 0) THEN mm_nla = SIZE(play) ELSE IF (mm_nla /= SIZE(play)) THEN err = error("mm_column_init: mm_nla cannot be modified dynamically within the run",-1) RETURN ENDIF ENDIF ! Check number of vertical levels: IF (mm_nle < 0) THEN mm_nle = SIZE(plev) ELSE IF (mm_nle /= SIZE(plev)) THEN err = error("mm_column_init: mm_nle cannot be modified dynamically within the run",-1) RETURN ENDIF ENDIF ! Sanity check: IF (mm_nla+1 /= mm_nle) THEN err = error("mm_column_init: Inconsistent number of layers/levels",-1) RETURN ENDIF ! Allocates if required: IF (.NOT.ALLOCATED(mm_plev)) ALLOCATE(mm_plev(mm_nle)) IF (.NOT.ALLOCATED(mm_zlev)) ALLOCATE(mm_zlev(mm_nle)) IF (.NOT.ALLOCATED(mm_play)) ALLOCATE(mm_play(mm_nla)) IF (.NOT.ALLOCATED(mm_zlay)) ALLOCATE(mm_zlay(mm_nla)) IF (.NOT.ALLOCATED(mm_temp)) ALLOCATE(mm_temp(mm_nla)) IF (.NOT.ALLOCATED(mm_btemp)) ALLOCATE(mm_btemp(mm_nle)) IF (.NOT.ALLOCATED(mm_dzlev)) ALLOCATE(mm_dzlev(mm_nla)) IF (.NOT.ALLOCATED(mm_dzlay)) ALLOCATE(mm_dzlay(mm_nla)) IF (.NOT.ALLOCATED(mm_rhoair)) ALLOCATE(mm_rhoair(mm_nla)) ! Saves reversed input vectors: mm_plev = plev(mm_nle:1:-1) mm_zlev = zlev(mm_nle:1:-1) mm_play = play(mm_nla:1:-1) mm_zlay = zlay(mm_nla:1:-1) mm_temp = temp(mm_nla:1:-1) ! Computes temperature vertical profil at interfaces: mm_btemp(2:mm_nla) = (mm_temp(1:mm_nla-1) + mm_temp(2:mm_nla)) / 2._mm_wp mm_btemp(1) = mm_temp(1) mm_btemp(mm_nle) = mm_temp(mm_nla) + (mm_temp(mm_nla) - mm_temp(mm_nla-1)) / 2._mm_wp ! Computes atmospheric levels thickness: mm_dzlev(1:mm_nla) = mm_zlev(1:mm_nle-1)-mm_zlev(2:mm_nle) ! Computes atmospheric layers thickness : mm_dzlay(1:mm_nla-1) = mm_zlay(1:mm_nla-1)-mm_zlay(2:mm_nla) mm_dzlay(mm_nla) = mm_dzlay(mm_nla-1) ! Hydrostatic equilibrium: mm_rhoair(1:mm_nla) = (mm_plev(2:mm_nle)-mm_plev(1:mm_nla)) / (mm_effg(mm_zlay)*mm_dzlev) ! Write out profiles for debug and log: IF (mm_log.AND.mm_debug) THEN WRITE(*,'(a)') '# TEMP PLAY ZLAY DZLAY RHOAIR' DO i=1,mm_nla WRITE(*,'(5(ES15.7,2X))') mm_temp(i),mm_play(i),mm_zlay(i),mm_dzlay(i), mm_rhoair(i) ENDDO WRITE(*,'(a)') '# TEMP PLEV ZLEV DZLEV' DO i=1,mm_nle IF (i /= mm_nle) THEN WRITE(*,'(4(ES15.7,2X))') mm_btemp(i),mm_plev(i),mm_zlev(i),mm_dzlev(i) ELSE WRITE(*,'(3(ES15.7,2X))') mm_btemp(i),mm_plev(i),mm_zlev(i) ENDIF ENDDO ENDIF ! End of initialization: mm_ini_col = .true. RETURN END FUNCTION mm_column_init FUNCTION mm_aerosols_init(m0aer_s,m3aer_s,m0aer_f,m3aer_f) RESULT(err) !! Initialize aerosol tracers vertical grid. !! !! The subroutine initializes aerosols microphysics tracers columns. It allocates variables if !! required and stores input vectors in reversed order. It also computes the characteristic radii !! of each mode. !! !! @warning !! The method should be called after mm_global_init and mm_column_init. Moreover, it should be called !! whenever the vertical structure of the atmosphere changes. !! All the input vectors should be defined from __GROUND__ to __TOP__ of the atmosphere, !! otherwise nasty things will occur in computations. !! REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m0aer_s ! 0th order moment of the spherical mode (m-2). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m3aer_s ! 3rd order moment of the spherical mode (m3.m-2). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m0aer_f ! 0th order moment of the fractal mode (m-2). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m3aer_f ! 3rd order moment of the fractal mode (m3.m-2). TYPE(error) :: err ! Error status of the function. err = noerror ! Global initialization must be done before: IF (.NOT.mm_ini) THEN err = error("mm_aerosols_init: Global initialization not done yet",-1) ; RETURN ENDIF ! Column initialization must be done before: IF (.NOT.mm_ini_col) THEN err = error("mm_aerosols_init: Column initialization not done yet",-1) ; RETURN ENDIF ! Sanity check: IF (SIZE(m0aer_s) /= mm_nla) THEN err = error("mm_aerosols_init: Invalid size for input arrays",-1) ; RETURN ENDIF ! Allocate variable if required: IF (.NOT.ALLOCATED(mm_m0aer_s)) ALLOCATE(mm_m0aer_s(mm_nla)) IF (.NOT.ALLOCATED(mm_m3aer_s)) ALLOCATE(mm_m3aer_s(mm_nla)) IF (.NOT.ALLOCATED(mm_m0aer_f)) ALLOCATE(mm_m0aer_f(mm_nla)) IF (.NOT.ALLOCATED(mm_m3aer_f)) ALLOCATE(mm_m3aer_f(mm_nla)) IF (.NOT.ALLOCATED(mm_rcs)) ALLOCATE(mm_rcs(mm_nla)) IF (.NOT.ALLOCATED(mm_rcf)) ALLOCATE(mm_rcf(mm_nla)) ! Allocate memory for diagnostics if required: IF (.NOT.ALLOCATED(mm_m0as_vsed)) THEN ALLOCATE(mm_m0as_vsed(mm_nla)) mm_m0as_vsed(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_m3as_vsed)) THEN ALLOCATE(mm_m3as_vsed(mm_nla)) mm_m3as_vsed(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_m0af_vsed)) THEN ALLOCATE(mm_m0af_vsed(mm_nla)) mm_m0af_vsed(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_m3af_vsed)) THEN ALLOCATE(mm_m3af_vsed(mm_nla)) mm_m3af_vsed(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_aer_s_flux)) THEN ALLOCATE(mm_aer_s_flux(mm_nla)) mm_aer_s_flux(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_aer_f_flux)) THEN ALLOCATE(mm_aer_f_flux(mm_nla)) mm_aer_f_flux(:) = 0._mm_wp ENDIF ! Initialization of aerosol tracers: ! @note: mm_dzlev is already from top to ground mm_m0aer_s = m0aer_s(mm_nla:1:-1) / mm_dzlev(:) mm_m3aer_s = m3aer_s(mm_nla:1:-1) / mm_dzlev(:) mm_m0aer_f = m0aer_f(mm_nla:1:-1) / mm_dzlev(:) mm_m3aer_f = m3aer_f(mm_nla:1:-1) / mm_dzlev(:) ! Setup threshold (useful for preventing bugs): call mm_set_moments_thresholds() ! Initialization of spherical aerosol characteristic radii: WHERE(mm_m3aer_s > 0._mm_wp .AND. mm_m0aer_s > 0._mm_wp) mm_rcs = mm_get_rcs(mm_m0aer_s,mm_m3aer_s) ELSEWHERE mm_rcs = 0._mm_wp ENDWHERE ! Initialization of fractal aerosol characteristic radii: WHERE(mm_m3aer_f > 0._mm_wp .AND. mm_m0aer_f > 0._mm_wp) mm_rcf = mm_get_rcf(mm_m0aer_f,mm_m3aer_f) ELSEWHERE mm_rcf = 0._mm_wp ENDWHERE ! End of initialization: mm_ini_aer = .true. END FUNCTION mm_aerosols_init FUNCTION mm_clouds_init(m0ccn,m3ccn,m3ice,gas) RESULT(err) !! Initialize clouds tracers vertical grid. !! !! The subroutine initializes cloud microphysics tracers columns. It allocates variables if !! required and stores input vectors in reversed order. It also computes the mean drop radius !! and density and allocates diagnostic vectors. !! !! @note !! All the input arguments should be defined from __GROUND__ to __TOP__. !! !! @warning !! [[mm_global_init(interface)]] and [[mm_column_init(function)]] must have been called at least once before this method is called. !! Moreover, this method should be after each call of [[mm_column_init(function)]] to reflect changes in the !! vertical atmospheric structure. !! REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m0ccn ! 0th order moment of the CCN distribution (m-2). REAL(kind=mm_wp), DIMENSION(:), INTENT(in) :: m3ccn ! 3rd order moment of the CCN distribution (m3.m-2). REAL(kind=mm_wp), DIMENSION(:,:), INTENT(in) :: m3ice ! 3rd order moments of the ice components (m3.m-2). REAL(kind=mm_wp), DIMENSION(:,:), INTENT(in) :: gas ! Condensible species gas molar fraction (mol.mol-1). INTEGER :: i TYPE(error) :: err ! Error status of the function. err = noerror IF (.NOT.mm_ini) THEN err = error("Global initialization not done yet",-8) RETURN ENDIF IF (.NOT.mm_call_clouds) THEN IF (mm_debug) WRITE(*,'(a)') "[MM_DEBUG - mm_clouds_init] Cloud microphysic is not enabled..." RETURN ENDIF ! Allocate variable if required: IF (.NOT.ALLOCATED(mm_m0ccn)) ALLOCATE(mm_m0ccn(mm_nla)) IF (.NOT.ALLOCATED(mm_m3ccn)) ALLOCATE(mm_m3ccn(mm_nla)) IF (.NOT.ALLOCATED(mm_m3ice)) ALLOCATE(mm_m3ice(mm_nla,mm_nesp)) IF (.NOT.ALLOCATED(mm_gas)) ALLOCATE(mm_gas(mm_nla,mm_nesp)) IF (.NOT.ALLOCATED(mm_drad)) ALLOCATE(mm_drad(mm_nla)) IF (.NOT.ALLOCATED(mm_drho)) ALLOCATE(mm_drho(mm_nla)) ! Allocate memory for diagnostics: mm_ccn_prec = 0._mm_wp IF (.NOT.ALLOCATED(mm_ice_prec)) THEN ALLOCATE(mm_ice_prec(mm_nesp)) ; mm_ice_prec(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_cld_vsed)) THEN ALLOCATE(mm_cld_vsed(mm_nla)) ; mm_cld_vsed(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_ccn_flux)) THEN ALLOCATE(mm_ccn_flux(mm_nla)) ; mm_ccn_flux(:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_ice_fluxes)) THEN ALLOCATE(mm_ice_fluxes(mm_nla,mm_nesp)) ; mm_ice_fluxes(:,:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_gas_sat)) THEN ALLOCATE(mm_gas_sat(mm_nla,mm_nesp)) ; mm_gas_sat(:,:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_nrate)) THEN ALLOCATE(mm_nrate(mm_nla,mm_nesp)) ; mm_nrate(:,:) = 0._mm_wp ENDIF IF (.NOT.ALLOCATED(mm_grate)) THEN ALLOCATE(mm_grate(mm_nla,mm_nesp)) ; mm_grate(:,:) = 0._mm_wp ENDIF ! /!\ mm_dzlev already from top to ground mm_m0ccn = m0ccn(mm_nla:1:-1) / mm_dzlev(:) mm_m3ccn = m3ccn(mm_nla:1:-1) / mm_dzlev(:) DO i = 1, mm_nesp mm_m3ice(:,i) = m3ice(mm_nla:1:-1,i) / mm_dzlev(:) mm_gas(:,i) = gas(mm_nla:1:-1,i) ENDDO ! Setup threshold: call mm_set_moments_cld_thresholds() ! Drop mean radius and density: call mm_cloud_properties(mm_m0ccn,mm_m3ccn,mm_m3ice,mm_drad,mm_drho) ! End of initialization: mm_ini_cld = .true. END FUNCTION mm_clouds_init !============================================================================ ! INTER-MOMENT RELATION METHODS !============================================================================ PURE FUNCTION mm_alpha_s(k) RESULT (res) !! Inter-moment relation for spherical aerosols size distribution law. !! Mk / M0 = rc^k . alpha(k) !! REAL(kind=mm_wp), INTENT(in) :: k ! k order of the moment. REAL(kind=mm_wp) :: sigma ! Standard deviation. REAL(kind=mm_wp) :: res ! Alpha value. ! Titan's case !~~~~~~~~~~~~~ ! res = SUM(dexp(mm_asp%a*k**2 + mm_asp%b*k + mm_asp%c)) ! Pluto's case !~~~~~~~~~~~~~ sigma = 0.2_mm_wp res = exp(k**2 * sigma**2 / 2._mm_wp) RETURN END FUNCTION mm_alpha_s PURE FUNCTION mm_alpha_f(k) RESULT (res) !! Inter-moment relation for fractal aerosols size distribution law. !! Mk / M0 = rc^k . alpha(k) !! REAL(kind=mm_wp), INTENT(in) :: k ! k order of the moment. REAL(kind=mm_wp) :: sigma ! Standard deviation. REAL(kind=mm_wp) :: res ! Alpha value. ! Titan's case !~~~~~~~~~~~~~ ! res = SUM(dexp(mm_afp%a*k**2 + mm_afp%b*k + mm_afp%c)) ! Pluto's case !~~~~~~~~~~~~~ sigma = 0.35_mm_wp res = exp(k**2 * sigma**2 / 2._mm_wp) RETURN END FUNCTION mm_alpha_f !============================================================================ ! HAZE RELATED METHODS !============================================================================ SUBROUTINE mm_set_moments_thresholds() !! Apply minimum threshold for the aerosols moments. !! !! The method resets moments (for both modes and orders, 0 and 3) values to zero if !! their current value is below the minimum threholds. !! INTEGER :: i DO i=1,mm_nla IF ((mm_m0aer_s(i) < mm_m0as_min) .OR. (mm_m3aer_s(i) < mm_m3as_min)) THEN mm_m0aer_s(i) = 0._mm_wp mm_m3aer_s(i) = 0._mm_wp ENDIF IF ((mm_m0aer_f(i) < mm_m0af_min) .OR. (mm_m3aer_f(i) < mm_m3af_min)) THEN mm_m0aer_f(i) = 0._mm_wp mm_m3aer_f(i) = 0._mm_wp ENDIF ENDDO END SUBROUTINE mm_set_moments_thresholds ELEMENTAL FUNCTION mm_get_rcs(m0,m3) RESULT(res) !! Get the characteristic radius for the spherical aerosols size distribution. !! !! The method computes the characteristic radius of the spherical aerosol size distribution !! law according to its moments and its inter-moments relation. !! REAL(kind=mm_wp), INTENT(in) :: m0 ! 0th order moment REAL(kind=mm_wp), INTENT(in) :: m3 ! 3rd order moment REAL(kind=mm_wp) :: res ! Radius res = (m3 / (m0*mm_alpha_s(3._mm_wp)))**(1._mm_wp/3._mm_wp) END FUNCTION mm_get_rcs ELEMENTAL FUNCTION mm_get_rcf(m0,m3) RESULT(res) !! Get the characteristic radius for the fractal aerosols size distribution. !! !! The method computes the characteristic radius of the fractal aerosol size distribution !! law according to its moments and its inter-moments relation. !! REAL(kind=mm_wp), INTENT(in) :: m0 ! 0th order moment REAL(kind=mm_wp), INTENT(in) :: m3 ! 3rd order moment REAL(kind=mm_wp) :: res ! Radius res = (m3 / (m0*mm_alpha_f(3._mm_wp)))**(1._mm_wp/3._mm_wp) END FUNCTION mm_get_rcf !============================================================================ ! CLOUD RELATED METHODS !============================================================================ SUBROUTINE mm_set_moments_cld_thresholds() !! Apply minimum threshold for the cloud drop moments. !! The method resets moments values to zero if their current value is below the minimum threholds. !! INTEGER :: i, j REAL(kind=mm_wp) :: m3cld = 0._mm_wp DO i = 1, mm_nla m3cld = mm_m3ccn(i) DO j = 1, mm_nesp m3cld = m3cld + mm_m3ice(i,j) ENDDO IF ((mm_m0ccn(i) < mm_m0ccn_min) .OR. (mm_m3ccn(i) < mm_m3ccn_min) .OR. (m3cld < mm_m3cld_min)) THEN mm_m0ccn(i) = 0._mm_wp mm_m3ccn(i) = 0._mm_wp DO j = 1, mm_nesp mm_m3ice(i,j) = 0._mm_wp ENDDO ENDIF ENDDO END SUBROUTINE mm_set_moments_cld_thresholds SUBROUTINE cldprop_sc(m0ccn,m3ccn,m3ice,drad,drho) !! Get cloud drop properties (scalar). !! The method computes the mean radius and mean density of cloud drops. !! !! @warning !! If __drad__ is greater than __drmax__ it is automatically set to __drmax__, but computation of !! __drho__ remains unmodified. So __drho__ is not correct in that case! !! REAL(kind=mm_wp), INTENT(in) :: m0ccn ! 0th order moment of the ccn REAL(kind=mm_wp), INTENT(in) :: m3ccn ! 3rd order moment of the ccn REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: m3ice ! 3rd order moments of each ice component REAL(kind=mm_wp), INTENT(out) :: drad ! Output mean drop radius REAL(kind=mm_wp), INTENT(out), OPTIONAL :: drho ! Optional output mean drop density REAL(kind=mm_wp) :: Ntot, Vtot, Wtot REAL(kind=mm_wp), PARAMETER :: athird = 1._mm_wp / 3._mm_wp REAL(kind=mm_wp), PARAMETER :: pifac = (4._mm_wp * mm_pi) / 3._mm_wp ! Set to zero : drad = 0._mm_wp IF (PRESENT(drho)) drho = 0._mm_wp ! Initialization : Ntot = m0ccn Vtot = m3ccn + SUM(m3ice) Wtot = m3ccn*mm_rhoaer + SUM(m3ice*mm_xESPS(:)%rho_s) IF (Ntot <= mm_m0ccn_min .OR. Vtot <= mm_m3cld_min) THEN drad = mm_drad_min IF (PRESENT(drho)) drho = mm_rhoaer ELSE drad = (Vtot / Ntot)**athird drad = MAX(MIN(drad,mm_drad_max),mm_drad_min) IF (PRESENT(drho)) drho = Wtot / Vtot ENDIF RETURN END SUBROUTINE cldprop_sc SUBROUTINE cldprop_ve(m0ccn,m3ccn,m3ice,drad,drho) !! Get cloud drop properties (vector). !! !! The method performs the same computations than [[cldprop_sc(subroutine)]] !! but for the entire vertical atmospheric structure. !! REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: m0ccn ! 0th order moment of the ccn. REAL(kind=mm_wp), INTENT(in), DIMENSION(:) :: m3ccn ! 3rd order moment of the ccn. REAL(kind=mm_wp), INTENT(in), DIMENSION(:,:) :: m3ice ! 3rd order moments of each ice component. REAL(kind=mm_wp), INTENT(out), DIMENSION(:) :: drad ! Output mean drop radius. REAL(kind=mm_wp), INTENT(out), DIMENSION(:), OPTIONAL :: drho ! Optional output mean drop density. INTEGER :: i IF (PRESENT(drho)) THEN DO i = 1, SIZE(m0ccn) call cldprop_sc(m0ccn(i),m3ccn(i),m3ice(i,:),drad(i),drho(i)) ENDDO ELSE DO i = 1, SIZE(m0ccn) call cldprop_sc(m0ccn(i),m3ccn(i),m3ice(i,:),drad(i)) ENDDO ENDIF RETURN END SUBROUTINE cldprop_ve FUNCTION read_esp(parser,sec,pp) RESULT (err) !! Read and store [[mm_esp(type)]] parameters. !! TYPE(cfgparser), INTENT(in) :: parser ! Configuration parser. CHARACTER(len=*), INTENT(in) :: sec ! Name of the species. TYPE(mm_esp), INTENT(out) :: pp ! [[mm_esp(type)]] object that stores the parameters. TYPE(error) :: err ! Error status of the function. err = cfg_get_value(parser,TRIM(sec)//'/name',pp%name) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/mas',pp%mas) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/vol',pp%vol) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/ray',pp%ray) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/masmol',pp%masmol) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/rho_l',pp%rho_l) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/rho_s',pp%rho_s) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/Tc',pp%Tc) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/pc',pp%pc) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/Tb',pp%Tb) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/w',pp%w) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/a0_sat',pp%a0_sat) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/a1_sat',pp%a1_sat) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/a2_sat',pp%a2_sat) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/a3_sat',pp%a3_sat) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/a4_sat',pp%a4_sat) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/a5_sat',pp%a5_sat) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/a6_sat',pp%a6_sat) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/mteta',pp%mteta) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/fdes',pp%fdes) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/fdif',pp%fdif) ; IF (err /= 0) RETURN err = cfg_get_value(parser,TRIM(sec)//'/nus',pp%nus) ; IF (err /= 0) RETURN RETURN END FUNCTION read_esp !============================================================================ ! MISCELLANEOUS METHODS !============================================================================ ELEMENTAL FUNCTION mm_effg(z) RESULT(effg) !! Compute effective gravitational acceleration. !! REAL(kind=mm_wp), INTENT(in) :: z ! Altitude (m) REAL(kind=mm_wp) :: effg ! Effective gravitational acceleration (m.s-2) effg = mm_g0 IF (mm_use_effg) THEN effg = effg * (mm_rpla/(mm_rpla+z))**2 ENDIF RETURN END FUNCTION mm_effg SUBROUTINE mm_dump_parameters() !! Dump global parameters on stdout. !! WRITE(*,'(a)') "========= YAMMS PARAMETERS ============" WRITE(*,'(a,a)') "mm_fp_precision : ", mm_wp_s WRITE(*,'(a,L2)') "mm_debug : ", mm_debug WRITE(*,'(a)') "---------------------------------------" WRITE(*,'(a)') "Microphysical control flags" ! Haze production: WRITE(*,'(a,L2)') "mm_call_hazeprod : ", mm_call_hazeprod WRITE(*,'(a,ES14.7)') "mm_rc_prod (m) : ", mm_rc_prod WRITE(*,'(a,L2)') "mm_call_CH4hazeprod : ", mm_call_CH4hazeprod IF (.NOT. mm_call_CH4hazeprod) THEN WRITE(*,'(a,ES14.7)') " --> mm_p_prod (Pa) : ", mm_p_prod WRITE(*,'(a,ES14.7)') " --> mm_tx_prod (kg.m-2.s-1): ", mm_tx_prod ENDIF ! Haze coagulation: WRITE(*,'(a,L2)') "mm_call_hazecoag : ", mm_call_hazecoag IF (mm_call_hazecoag) THEN WRITE(*,'(a,I2.2)') " --> mm_coag_interactions : ", mm_coag_choice ENDIF ! Haze sedimentation: WRITE(*,'(a,L2)') "mm_call_hazesed : ", mm_call_hazesed IF (mm_call_hazesed) THEN WRITE(*,'(a,L2)') " --> mm_wsed_m0 : ", mm_wsed_m0 WRITE(*,'(a,L2)') " --> mm_wsed_m3 : ", mm_wsed_m3 ENDIF WRITE(*,'(a)') "---------------------------------------" ! Haze threshold: WRITE(*,'(a)') "Spherical aerosol thresholds" WRITE(*,'(a,ES14.7)') " mm_m0as_min (m-3) : ", mm_m0as_min WRITE(*,'(a,ES14.7)') " mm_rcs_min (m) : ", mm_rcs_min WRITE(*,'(a)') "Fractal aerosol thresholds" WRITE(*,'(a,ES14.7)') " mm_m0af_min (m-3) : ", mm_m0af_min WRITE(*,'(a,ES14.7)') " mm_rcf_min (m) : ", mm_rcf_min WRITE(*,'(a)') "---------------------------------------" ! Clouds related: WRITE(*,'(a,L2)') "mm_call_clouds : ", mm_call_clouds IF (mm_call_clouds) THEN WRITE(*,'(a)') " Thresholds clouds drop" WRITE(*,'(a,ES14.7)') " --> mm_m0ccn_min : ", mm_m0ccn_min WRITE(*,'(a,ES14.7)') " --> mm_drad_min : ", mm_drad_min WRITE(*,'(a,ES14.7)') " --> mm_drad_max : ", mm_drad_max ENDIF WRITE(*,'(a)') "---------------------------------------" ! Free parameters: WRITE(*,'(a)') "Free parameters" WRITE(*,'(a,ES14.7)') "mm_rm (m) : ", mm_rm WRITE(*,'(a,ES14.7)') "mm_df (-) : ", mm_df WRITE(*,'(a,ES14.7)') "mm_rhoaer (kg.m-3) : ", mm_rhoaer WRITE(*,'(a,ES14.7)') "mm_rplanete (m) : ", mm_rpla WRITE(*,'(a,ES14.7)') "mm_g0 (m.s-2) : ", mm_g0 WRITE(*,'(a,ES14.7)') "mm_air_rad (m) : ", mm_air_rad WRITE(*,'(a,ES14.7)') "mm_air_mmol (kg.mol-1) : ", mm_air_mmol WRITE(*,'(a,ES14.7)') "mm_air_mmas (kg) : ", mm_air_mmas WRITE(*,'(a,ES14.7)') "mm_dt (s) : ", mm_dt IF (mm_nla > -1) THEN WRITE(*,'(a,I3.3)') "mm_nla : ", mm_nla ELSE WRITE(*,'(a)') "mm_nla : not initialized yet" ENDIF WRITE(*,'(a)') "=======================================" END SUBROUTINE mm_dump_parameters ! ========================================================================= ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! CONFIGURATION PARSER checking methods ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! ========================================================================= FUNCTION check_r1(err,var,def,wlog) RESULT(ret) !! Check an option value (float). !! !! The method checks an option value and optionally set a default value, __def__ to initialize !! __var__ on error if given. !! TYPE(error), INTENT(in) :: err ! Error object from value getter. REAL(kind=mm_wp), INTENT(inout) :: var ! Input/output option value. REAL(kind=mm_wp), INTENT(in), OPTIONAL :: def ! Default value to set. LOGICAL, INTENT(in), OPTIONAL :: wlog ! .true. to print warning/error message. TYPE(error) :: ret ! Input error. CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' LOGICAL :: zlog ret = err zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog IF (err == 0) RETURN IF (PRESENT(def)) THEN var = def IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,to_string(var) ret = noerror ELSE IF (zlog) WRITE(*,'(a)') error_to_string(err,'',.true.) ENDIF END FUNCTION check_r1 FUNCTION check_l1(err,var,def,wlog) RESULT(ret) !! Check an option value (logical). !! !! The method checks an option value and optionally set a default value, __def__ to initialize !! __var__ on error if given. !! TYPE(error), INTENT(in) :: err ! Error object from value getter. LOGICAL, INTENT(inout) :: var ! Input/output option value. LOGICAL, INTENT(in), OPTIONAL :: def ! Default value to set. LOGICAL, INTENT(in), OPTIONAL :: wlog ! .true. to print warning/error message. TYPE(error) :: ret ! Input error. CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' LOGICAL :: zlog ret = err zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog IF (err == 0) RETURN IF (PRESENT(def)) THEN var = def IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,to_string(var) ret = noerror ELSE IF (zlog) WRITE(*,'(a)') error_to_string(err,'',.true.) ENDIF END FUNCTION check_l1 FUNCTION check_i1(err,var,def,wlog) RESULT(ret) !! Check an option value (integer). !! !! The method checks an option value and optionally set a default value, __def__ to initialize !! __var__ on error if given. !! TYPE(error), INTENT(in) :: err ! Error object from value getter. INTEGER, INTENT(inout) :: var ! Input/output option value. INTEGER, INTENT(in), OPTIONAL :: def ! Default value to set. LOGICAL, INTENT(in), OPTIONAL :: wlog ! .true. to print warning/error message. TYPE(error) :: ret ! Input error. CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' LOGICAL :: zlog ret = err zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog IF (err == 0) RETURN IF (PRESENT(def)) THEN var = def IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,to_string(var) ret = noerror ELSE IF (zlog) WRITE(*,'(a)') error_to_string(err,'',.true.) ENDIF END FUNCTION check_i1 FUNCTION check_s1(err,var,def,wlog) RESULT(ret) !! Check an option value (string). !! !! The method checks an option value and optionally set a default value, __def__ to initialize !! __var__ on error if given. !! TYPE(error), INTENT(in) :: err ! Error object from value getter. CHARACTER(len=*), INTENT(inout) :: var ! Input/output option value. CHARACTER(len=*), INTENT(in), OPTIONAL :: def ! Default value to set. LOGICAL, INTENT(in), OPTIONAL :: wlog ! .true. to print warning/error message. TYPE(error) :: ret ! Input error. CHARACTER(len=*), PARAMETER :: defmsg = '... Using default value: ' LOGICAL :: zlog ret = err zlog = .false. ; IF (PRESENT(wlog)) zlog = wlog IF (err == 0) RETURN IF (PRESENT(def)) THEN var = TRIM(def) IF (zlog) WRITE(*,'(a,a,a)') error_to_string(err,'',.true.),defmsg,var ret = noerror ELSE IF (zlog) WRITE(*,'(a)') error_to_string(err,'') ENDIF RETURN END FUNCTION check_s1 END MODULE MP2M_GLOBALS