From 3b41b8a316bad75f908f4e67dfe1434e621a282b Mon Sep 17 00:00:00 2001 From: Anders Jensen Date: Thu, 7 Dec 2023 14:01:51 -0700 Subject: [PATCH 001/154] Thompson refactor --- physics/module_mp_thompson.F90 | 5858 ++++++++++++++++---------------- 1 file changed, 2916 insertions(+), 2942 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 44e552160..b8c702883 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -57,33 +57,32 @@ !! with his WRF version, including bug fixes and designed !! changes. -MODULE module_mp_thompson +module module_mp_thompson - USE machine, only : kind_phys - - USE module_mp_radar + use machine, only: kind_phys, kind_dbl_prec + use module_mp_radar #ifdef MPI - use mpi + use mpi #endif - IMPLICIT NONE + implicit none - LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false. - LOGICAL, PRIVATE:: is_aerosol_aware = .false. - LOGICAL, PRIVATE:: merra2_aerosol_aware = .false. - LOGICAL, PARAMETER, PRIVATE:: dustyIce = .true. - LOGICAL, PARAMETER, PRIVATE:: homogIce = .true. + logical, parameter, private :: iiwarm = .false. + logical, private :: is_aerosol_aware = .false. + logical, private :: merra2_aerosol_aware = .false. + logical, parameter, private :: dustyIce = .true. + logical, parameter, private :: homogIce = .true. - INTEGER, PARAMETER, PRIVATE:: IFDRY = 0 - REAL, PARAMETER, PRIVATE:: T_0 = 273.15 - REAL, PARAMETER, PRIVATE:: PI = 3.1415926536 + integer, parameter, private :: IFDRY = 0 + real(kind_phys), parameter, private :: T_0 = 273.15 + real(kind_phys), parameter, private :: PI = 3.1415926536 !..Densities of rain, snow, graupel, and cloud ice. - REAL, PARAMETER, PRIVATE:: rho_w = 1000.0 - REAL, PARAMETER, PRIVATE:: rho_s = 100.0 - REAL, PARAMETER, PRIVATE:: rho_g = 500.0 - REAL, PARAMETER, PRIVATE:: rho_i = 890.0 + real(kind_phys), parameter, private :: rho_w = 1000.0 + real(kind_phys), parameter, private :: rho_s = 100.0 + real(kind_phys), parameter, private :: rho_g = 500.0 + real(kind_phys), parameter, private :: rho_i = 890.0 !..Prescribed number of cloud droplets. Set according to known data or !.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and @@ -92,278 +91,278 @@ MODULE module_mp_thompson !.. scheme. In 2-moment cloud water, Nt_c represents a maximum of !.. droplet concentration and nu_c is also variable depending on local !.. droplet number concentration. - !REAL, PARAMETER :: Nt_c = 100.E6 - REAL, PARAMETER :: Nt_c_o = 50.E6 - REAL, PARAMETER :: Nt_c_l = 100.E6 - REAL, PARAMETER, PRIVATE:: Nt_c_max = 1999.E6 + !real(kind_phys), parameter :: Nt_c = 100.E6 + real(kind_phys), parameter :: Nt_c_o = 50.E6 + real(kind_phys), parameter :: Nt_c_l = 100.E6 + real(kind_phys), parameter, private :: Nt_c_max = 1999.E6 !..Declaration of constants for assumed CCN/IN aerosols when none in !.. the input data. Look inside the init routine for modifications !.. due to surface land-sea points or vegetation characteristics. - REAL, PARAMETER :: naIN0 = 1.5E6 - REAL, PARAMETER :: naIN1 = 0.5E6 - REAL, PARAMETER :: naCCN0 = 300.0E6 - REAL, PARAMETER :: naCCN1 = 50.0E6 + real(kind_phys), parameter :: naIN0 = 1.5E6 + real(kind_phys), parameter :: naIN1 = 0.5E6 + real(kind_phys), parameter :: naCCN0 = 300.0E6 + real(kind_phys), parameter :: naCCN1 = 50.0E6 !..Generalized gamma distributions for rain, graupel and cloud ice. !.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. - REAL, PARAMETER, PRIVATE:: mu_r = 0.0 - REAL, PARAMETER, PRIVATE:: mu_g = 0.0 - REAL, PARAMETER, PRIVATE:: mu_i = 0.0 - REAL, PRIVATE:: mu_c_o, mu_c_l + real(kind_phys), parameter, private :: mu_r = 0.0 + real(kind_phys), parameter, private :: mu_g = 0.0 + real(kind_phys), parameter, private :: mu_i = 0.0 + real(kind_phys), private :: mu_c_o, mu_c_l !..Sum of two gamma distrib for snow (Field et al. 2005). !.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) !.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] !.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively !.. calculated as function of ice water content and temperature. - REAL, PARAMETER, PRIVATE:: mu_s = 0.6357 - REAL, PARAMETER, PRIVATE:: Kap0 = 490.6 - REAL, PARAMETER, PRIVATE:: Kap1 = 17.46 - REAL, PARAMETER, PRIVATE:: Lam0 = 20.78 - REAL, PARAMETER, PRIVATE:: Lam1 = 3.29 + real(kind_phys), parameter, private :: mu_s = 0.6357 + real(kind_phys), parameter, private :: Kap0 = 490.6 + real(kind_phys), parameter, private :: Kap1 = 17.46 + real(kind_phys), parameter, private :: Lam0 = 20.78 + real(kind_phys), parameter, private :: Lam1 = 3.29 !..Y-intercept parameter for graupel is not constant and depends on !.. mixing ratio. Also, when mu_g is non-zero, these become equiv !.. y-intercept for an exponential distrib and proper values are !.. computed based on same mixing ratio and total number concentration. - REAL, PARAMETER, PRIVATE:: gonv_min = 1.E2 - REAL, PARAMETER, PRIVATE:: gonv_max = 1.E6 + real(kind_phys), parameter, private :: gonv_min = 1.E2 + real(kind_phys), parameter, private :: gonv_max = 1.E6 !..Mass power law relations: mass = am*D**bm !.. Snow from Field et al. (2005), others assume spherical form. - REAL, PARAMETER, PRIVATE:: am_r = PI*rho_w/6.0 - REAL, PARAMETER, PRIVATE:: bm_r = 3.0 - REAL, PARAMETER, PRIVATE:: am_s = 0.069 - REAL, PARAMETER, PRIVATE:: bm_s = 2.0 - REAL, PARAMETER, PRIVATE:: am_g = PI*rho_g/6.0 - REAL, PARAMETER, PRIVATE:: bm_g = 3.0 - REAL, PARAMETER, PRIVATE:: am_i = PI*rho_i/6.0 - REAL, PARAMETER, PRIVATE:: bm_i = 3.0 + real(kind_phys), parameter, private :: am_r = PI*rho_w/6.0 + real(kind_phys), parameter, private :: bm_r = 3.0 + real(kind_phys), parameter, private :: am_s = 0.069 + real(kind_phys), parameter, private :: bm_s = 2.0 + real(kind_phys), parameter, private :: am_g = PI*rho_g/6.0 + real(kind_phys), parameter, private :: bm_g = 3.0 + real(kind_phys), parameter, private :: am_i = PI*rho_i/6.0 + real(kind_phys), parameter, private :: bm_i = 3.0 !..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) !.. Rain from Ferrier (1994), ice, snow, and graupel from !.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. - REAL, PARAMETER, PRIVATE:: av_r = 4854.0 - REAL, PARAMETER, PRIVATE:: bv_r = 1.0 - REAL, PARAMETER, PRIVATE:: fv_r = 195.0 - REAL, PARAMETER, PRIVATE:: av_s = 40.0 - REAL, PARAMETER, PRIVATE:: bv_s = 0.55 - REAL, PARAMETER, PRIVATE:: fv_s = 100.0 - REAL, PARAMETER, PRIVATE:: av_g = 442.0 - REAL, PARAMETER, PRIVATE:: bv_g = 0.89 - REAL, PARAMETER, PRIVATE:: bv_i = 1.0 - REAL, PARAMETER, PRIVATE:: av_c = 0.316946E8 - REAL, PARAMETER, PRIVATE:: bv_c = 2.0 + real(kind_phys), parameter, private :: av_r = 4854.0 + real(kind_phys), parameter, private :: bv_r = 1.0 + real(kind_phys), parameter, private :: fv_r = 195.0 + real(kind_phys), parameter, private :: av_s = 40.0 + real(kind_phys), parameter, private :: bv_s = 0.55 + real(kind_phys), parameter, private :: fv_s = 100.0 + real(kind_phys), parameter, private :: av_g = 442.0 + real(kind_phys), parameter, private :: bv_g = 0.89 + real(kind_phys), parameter, private :: bv_i = 1.0 + real(kind_phys), parameter, private :: av_c = 0.316946E8 + real(kind_phys), parameter, private :: bv_c = 2.0 !..Capacitance of sphere and plates/aggregates: D**3, D**2 - REAL, PARAMETER, PRIVATE:: C_cube = 0.5 - REAL, PARAMETER, PRIVATE:: C_sqrd = 0.15 + real(kind_phys), parameter, private :: C_cube = 0.5 + real(kind_phys), parameter, private :: C_sqrd = 0.15 !..Collection efficiencies. Rain/snow/graupel collection of cloud !.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and !.. get computed elsewhere because they are dependent on stokes !.. number. - REAL, PARAMETER, PRIVATE:: Ef_si = 0.05 - REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95 - REAL, PARAMETER, PRIVATE:: Ef_rg = 0.75 - REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95 + real(kind_phys), parameter, private :: Ef_si = 0.05 + real(kind_phys), parameter, private :: Ef_rs = 0.95 + real(kind_phys), parameter, private :: Ef_rg = 0.75 + real(kind_phys), parameter, private :: Ef_ri = 0.95 !..Minimum microphys values !.. R1 value, 1.E-12, cannot be set lower because of numerical !.. problems with Paul Field's moments and should not be set larger !.. because of truncation problems in snow/ice growth. - REAL, PARAMETER, PRIVATE:: R1 = 1.E-12 - REAL, PARAMETER, PRIVATE:: R2 = 1.E-6 - REAL, PARAMETER :: eps = 1.E-15 + real(kind_phys), parameter, private :: R1 = 1.E-12 + real(kind_phys), parameter, private :: R2 = 1.E-6 + real(kind_phys), parameter :: eps = 1.E-15 !..Constants in Cooper curve relation for cloud ice number. - REAL, PARAMETER, PRIVATE:: TNO = 5.0 - REAL, PARAMETER, PRIVATE:: ATO = 0.304 + real(kind_phys), parameter, private :: TNO = 5.0 + real(kind_phys), parameter, private :: ATO = 0.304 !..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. - REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0) + real(kind_phys), parameter, private :: rho_not = 101325.0 / (287.05*298.0) !..Schmidt number - REAL, PARAMETER, PRIVATE:: Sc = 0.632 - REAL, PRIVATE:: Sc3 + real(kind_phys), parameter, private :: Sc = 0.632 + real(kind_phys), private :: Sc3 !..Homogeneous freezing temperature - REAL, PARAMETER, PRIVATE:: HGFR = 235.16 + real(kind_phys), parameter, private:: HGFR = 235.16 !..Water vapor and air gas constants at constant pressure - REAL, PARAMETER, PRIVATE:: Rv = 461.5 - REAL, PARAMETER, PRIVATE:: oRv = 1./Rv - REAL, PARAMETER, PRIVATE:: R = 287.04 - REAL, PARAMETER, PRIVATE:: Cp = 1004.0 - REAL, PARAMETER, PRIVATE:: R_uni = 8.314 !< J (mol K)-1 - - DOUBLE PRECISION, PARAMETER, PRIVATE:: k_b = 1.38065E-23 !< Boltzmann constant [J/K] - DOUBLE PRECISION, PARAMETER, PRIVATE:: M_w = 18.01528E-3 !< molecular mass of water [kg/mol] - DOUBLE PRECISION, PARAMETER, PRIVATE:: M_a = 28.96E-3 !< molecular mass of air [kg/mol] - DOUBLE PRECISION, PARAMETER, PRIVATE:: N_avo = 6.022E23 !< Avogadro number [1/mol] - DOUBLE PRECISION, PARAMETER, PRIVATE:: ma_w = M_w / N_avo !< mass of water molecule [kg] - REAL, PARAMETER, PRIVATE:: ar_volume = 4./3.*PI*(2.5e-6)**3 !< assume radius of 0.025 micrometer, 2.5e-6 cm + real(kind_phys), parameter, private :: Rv = 461.5 + real(kind_phys), parameter, private :: oRv = 1./Rv + real(kind_phys), parameter, private :: R = 287.04 + real(kind_phys), parameter, private :: Cp = 1004.0 + real(kind_phys), parameter, private :: R_uni = 8.314 !< J (mol K)-1 + + real(kind_dbl_prec), parameter, private :: k_b = 1.38065E-23 !< Boltzmann constant [J/K] + real(kind_dbl_prec), parameter, private :: M_w = 18.01528E-3 !< molecular mass of water [kg/mol] + real(kind_dbl_prec), parameter, private :: M_a = 28.96E-3 !< molecular mass of air [kg/mol] + real(kind_dbl_prec), parameter, private :: N_avo = 6.022E23 !< Avogadro number [1/mol] + real(kind_dbl_prec), parameter, private :: ma_w = M_w / N_avo !< mass of water molecule [kg] + real(kind_phys), parameter, private :: ar_volume = 4./3.*PI*(2.5e-6)**3 !< assume radius of 0.025 micrometer, 2.5e-6 cm !..Enthalpy of sublimation, vaporization, and fusion at 0C. - REAL, PARAMETER, PRIVATE:: lsub = 2.834E6 - REAL, PARAMETER, PRIVATE:: lvap0 = 2.5E6 - REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0 - REAL, PARAMETER, PRIVATE:: olfus = 1./lfus + real(kind_phys), parameter, private :: lsub = 2.834E6 + real(kind_phys), parameter, private :: lvap0 = 2.5E6 + real(kind_phys), parameter, private :: lfus = lsub - lvap0 + real(kind_phys), parameter, private :: olfus = 1./lfus !..Ice initiates with this mass (kg), corresponding diameter calc. !..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). - REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12 - REAL, PARAMETER, PRIVATE:: D0c = 1.E-6 - REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 - REAL, PARAMETER, PRIVATE:: D0s = 300.E-6 - REAL, PARAMETER, PRIVATE:: D0g = 350.E-6 - REAL, PRIVATE:: D0i, xm0s, xm0g + real(kind_phys), parameter, private :: xm0i = 1.E-12 + real(kind_phys), parameter, private :: D0c = 1.E-6 + real(kind_phys), parameter, private :: D0r = 50.E-6 + real(kind_phys), parameter, private :: D0s = 300.E-6 + real(kind_phys), parameter, private :: D0g = 350.E-6 + real(kind_phys), private :: D0i, xm0s, xm0g !..Min and max radiative effective radius of cloud water, cloud ice, and snow; !.. performed by subroutine calc_effectRad. On purpose, these should stay PUBLIC. - REAL, PARAMETER:: re_qc_min = 2.50E-6 ! 2.5 microns - REAL, PARAMETER:: re_qc_max = 50.0E-6 ! 50 microns - REAL, PARAMETER:: re_qi_min = 2.50E-6 ! 2.5 microns - REAL, PARAMETER:: re_qi_max = 125.0E-6 ! 125 microns - REAL, PARAMETER:: re_qs_min = 5.00E-6 ! 5 microns - REAL, PARAMETER:: re_qs_max = 999.0E-6 ! 999 microns (1 mm) + real(kind_phys), parameter :: re_qc_min = 2.50E-6 ! 2.5 microns + real(kind_phys), parameter :: re_qc_max = 50.0E-6 ! 50 microns + real(kind_phys), parameter :: re_qi_min = 2.50E-6 ! 2.5 microns + real(kind_phys), parameter :: re_qi_max = 125.0E-6 ! 125 microns + real(kind_phys), parameter :: re_qs_min = 5.00E-6 ! 5 microns + real(kind_phys), parameter :: re_qs_max = 999.0E-6 ! 999 microns (1 mm) !..Lookup table dimensions - INTEGER, PARAMETER, PRIVATE:: nbins = 100 - INTEGER, PARAMETER, PRIVATE:: nbc = nbins - INTEGER, PARAMETER, PRIVATE:: nbi = nbins - INTEGER, PARAMETER, PRIVATE:: nbr = nbins - INTEGER, PARAMETER, PRIVATE:: nbs = nbins - INTEGER, PARAMETER, PRIVATE:: nbg = nbins - INTEGER, PARAMETER, PRIVATE:: ntb_c = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i = 64 - INTEGER, PARAMETER, PRIVATE:: ntb_r = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_s = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_g = 28 - INTEGER, PARAMETER, PRIVATE:: ntb_g1 = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37 - INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 - INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 - INTEGER, PRIVATE:: nic1, nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3 - INTEGER, PARAMETER, PRIVATE:: ntb_arc = 7 - INTEGER, PARAMETER, PRIVATE:: ntb_arw = 9 - INTEGER, PARAMETER, PRIVATE:: ntb_art = 7 - INTEGER, PARAMETER, PRIVATE:: ntb_arr = 5 - INTEGER, PARAMETER, PRIVATE:: ntb_ark = 4 - INTEGER, PARAMETER, PRIVATE:: ntb_IN = 55 - INTEGER, PRIVATE:: niIN2 - - DOUBLE PRECISION, DIMENSION(nbins+1):: xDx - DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc - DOUBLE PRECISION, DIMENSION(nbi):: Di, dti - DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr - DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts - DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg - DOUBLE PRECISION, DIMENSION(nbc):: t_Nc + integer, parameter, private :: nbins = 100 + integer, parameter, private :: nbc = nbins + integer, parameter, private :: nbi = nbins + integer, parameter, private :: nbr = nbins + integer, parameter, private :: nbs = nbins + integer, parameter, private :: nbg = nbins + integer, parameter, private :: ntb_c = 37 + integer, parameter, private :: ntb_i = 64 + integer, parameter, private :: ntb_r = 37 + integer, parameter, private :: ntb_s = 28 + integer, parameter, private :: ntb_g = 28 + integer, parameter, private :: ntb_g1 = 37 + integer, parameter, private :: ntb_r1 = 37 + integer, parameter, private :: ntb_i1 = 55 + integer, parameter, private :: ntb_t = 9 + integer, private :: nic1, nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3 + integer, parameter, private :: ntb_arc = 7 + integer, parameter, private :: ntb_arw = 9 + integer, parameter, private :: ntb_art = 7 + integer, parameter, private :: ntb_arr = 5 + integer, parameter, private :: ntb_ark = 4 + integer, parameter, private :: ntb_IN = 55 + integer, private:: niIN2 + + real(kind_dbl_prec), dimension(nbins+1) :: xDx + real(kind_dbl_prec), dimension(nbc) :: Dc, dtc + real(kind_dbl_prec), dimension(nbi) :: Di, dti + real(kind_dbl_prec), dimension(nbr) :: Dr, dtr + real(kind_dbl_prec), dimension(nbs) :: Ds, dts + real(kind_dbl_prec), dimension(nbg) :: Dg, dtg + real(kind_dbl_prec), dimension(nbc) :: t_Nc !> Lookup tables for cloud water content (kg/m**3). - REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: & - r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) + real(kind_phys), dimension(ntb_c), parameter, private :: & + r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) !> Lookup tables for cloud ice content (kg/m**3). - REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: & - r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & - 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & - 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & - 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, & - 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, & - 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3/) + real(kind_phys), dimension(ntb_i), parameter, private :: & + r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & + 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & + 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & + 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, & + 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, & + 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3/) !> Lookup tables for rain content (kg/m**3). - REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: & - r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & - 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) + real(kind_phys), dimension(ntb_r), parameter, private :: & + r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & + 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) !> Lookup tables for graupel content (kg/m**3). - REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: & - r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) + real(kind_phys), dimension(ntb_g), parameter, private :: & + r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) !> Lookup tables for snow content (kg/m**3). - REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: & - r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & - 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & - 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & - 1.e-2/) + real(kind_phys), dimension(ntb_s), parameter, private :: & + r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & + 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & + 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & + 1.e-2/) !> Lookup tables for rain y-intercept parameter (/m**4). - REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: & - N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & - 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & - 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & - 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & - 1.e10/) + real(kind_phys), dimension(ntb_r1), parameter, private :: & + N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & + 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & + 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & + 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & + 1.e10/) !> Lookup tables for graupel y-intercept parameter (/m**4). - REAL, DIMENSION(ntb_g1), PARAMETER, PRIVATE:: & - N0g_exp = (/1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & - 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & - 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & - 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & - 1.e6/) - -!> Lookup tables for ice number concentration (/m**3). - REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: & - Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & - 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & - 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & + real(kind_phys), dimension(ntb_g1), parameter, private :: & + N0g_exp = (/1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & 1.e6/) +!> Lookup tables for ice number concentration (/m**3). + real(kind_phys), dimension(ntb_i1), parameter, private :: & + Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & + 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & + 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & + 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & + 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & + 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & + 1.e6/) + !..Aerosol table parameter: Number of available aerosols, vertical !.. velocity, temperature, aerosol mean radius, and hygroscopicity. - REAL, DIMENSION(ntb_arc), PARAMETER, PRIVATE:: & - ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) - REAL, DIMENSION(ntb_arw), PARAMETER, PRIVATE:: & - ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) - REAL, DIMENSION(ntb_art), PARAMETER, PRIVATE:: & - ta_Tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/) - REAL, DIMENSION(ntb_arr), PARAMETER, PRIVATE:: & - ta_Ra = (/0.01, 0.02, 0.04, 0.08, 0.16/) - REAL, DIMENSION(ntb_ark), PARAMETER, PRIVATE:: & - ta_Ka = (/0.2, 0.4, 0.6, 0.8/) + real(kind_phys), dimension(ntb_arc), parameter, private :: & + ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) + real(kind_phys), dimension(ntb_arw), parameter, private :: & + ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) + real(kind_phys), dimension(ntb_art), parameter, private :: & + ta_Tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/) + real(kind_phys), dimension(ntb_arr), parameter, private :: & + ta_Ra = (/0.01, 0.02, 0.04, 0.08, 0.16/) + real(kind_phys), dimension(ntb_ark), parameter, private :: & + ta_Ka = (/0.2, 0.4, 0.6, 0.8/) !> Lookup tables for IN concentration (/m**3) from 0.001 to 1000/Liter. - REAL, DIMENSION(ntb_IN), PARAMETER, PRIVATE:: & - Nt_IN = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & - 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & - 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & - 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & - 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & - 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & - 1.e6/) + real(kind_phys), dimension(ntb_IN), parameter, private :: & + Nt_IN = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & + 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & + 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & + 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & + 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & + 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & + 1.e6/) !> For snow moments conversions (from Field et al. 2005) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & - 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) - REAL, DIMENSION(10), PARAMETER, PRIVATE:: & - sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & - 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) + real(kind_phys), dimension(10), parameter, private :: & + sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & + 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) + real(kind_phys), dimension(10), parameter, private :: & + sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & + 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) !> Temperatures (5 C interval 0 to -40) used in lookup tables. - REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: & - Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) + real(kind_phys), dimension(ntb_t), parameter, private :: & + Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) !..Lookup tables for various accretion/collection terms. !.. ntb_x refers to the number of elements for rain, snow, graupel, @@ -374,57 +373,55 @@ MODULE module_mp_thompson !..To permit possible creation of new lookup tables as variables expand/change, !.. specify a name of external file(s) including version number for pre-computed !.. Thompson tables. - character(len=*), parameter :: thomp_table_file = 'thompson_tables_precomp_v2.sl' - character(len=*), parameter :: qr_acr_qg_file = 'qr_acr_qgV2.dat' - character(len=*), parameter :: qr_acr_qs_file = 'qr_acr_qsV2.dat' - character(len=*), parameter :: freeze_h2o_file = 'freezeH2O.dat' - - INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 - INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & - tnr_racg, tnr_gacr - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & - tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & - tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tpi_qcfz, tni_qcfz - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & - tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: & - tps_iaus, tni_iaus, tpi_ide - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efsw - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev - REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: & - tpc_wev, tnc_wev - REAL (KIND=R4SIZE), ALLOCATABLE, DIMENSION(:,:,:,:,:):: tnccn_act + character(len=*), parameter :: thomp_table_file = 'thompson_tables_precomp_v2.sl' + character(len=*), parameter :: qr_acr_qg_file = 'qr_acr_qgV2.dat' + character(len=*), parameter :: qr_acr_qs_file = 'qr_acr_qsV2.dat' + character(len=*), parameter :: freeze_h2o_file = 'freezeH2O.dat' + + real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & + tnr_racg, tnr_gacr + real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & + tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & + tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 + real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + tpi_qcfz, tni_qcfz + real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz + real (kind_dbl_prec), allocatable, dimension(:,:) :: & + tps_iaus, tni_iaus, tpi_ide + real (kind_dbl_prec), allocatable, dimension(:,:) :: t_Efrw + real (kind_dbl_prec), allocatable, dimension(:,:) :: t_Efsw + real (kind_dbl_prec), allocatable, dimension(:,:,:) :: tnr_rev + real (kind_dbl_prec), allocatable, dimension(:,:,:) :: & + tpc_wev, tnc_wev + real (kind_phys), allocatable, dimension(:,:,:,:,:) :: tnccn_act !..Variables holding a bunch of exponents and gamma values (cloud water, !.. cloud ice, rain, snow, then graupel). - REAL, DIMENSION(5,15), PRIVATE:: cce, ccg - REAL, DIMENSION(15), PRIVATE:: ocg1, ocg2 - REAL, DIMENSION(7), PRIVATE:: cie, cig - REAL, PRIVATE:: oig1, oig2, obmi - REAL, DIMENSION(13), PRIVATE:: cre, crg - REAL, PRIVATE:: ore1, org1, org2, org3, obmr - REAL, DIMENSION(18), PRIVATE:: cse, csg - REAL, PRIVATE:: oams, obms, ocms - REAL, DIMENSION(12), PRIVATE:: cge, cgg - REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg + real(kind_phys), dimension(5,15), private :: cce, ccg + real(kind_phys), dimension(15), private :: ocg1, ocg2 + real(kind_phys), dimension(7), private :: cie, cig + real(kind_phys), private :: oig1, oig2, obmi + real(kind_phys), dimension(13), private :: cre, crg + real(kind_phys), private :: ore1, org1, org2, org3, obmr + real(kind_phys), dimension(18), private :: cse, csg + real(kind_phys), private :: oams, obms, ocms + real(kind_phys), dimension(12), private :: cge, cgg + real(kind_phys), private :: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg !..Declaration of precomputed constants in various rate eqns. - REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi - REAL:: t1_qr_ev, t2_qr_ev - REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd - REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me + real(kind_phys) :: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi + real(kind_phys) :: t1_qr_ev, t2_qr_ev + real(kind_phys) :: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd + real(kind_phys) :: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me !..MPI communicator - INTEGER:: mpi_communicator + integer :: mpi_communicator !..Write tables with master MPI task after computing them in thompson_init - LOGICAL:: thompson_table_writer + logical :: thompson_table_writer !+---+ !+---+-----------------------------------------------------------------+ @@ -433,101 +430,101 @@ MODULE module_mp_thompson !+---+ !ctrlL - CONTAINS + contains !>\ingroup aathompson !! This subroutine calculates simplified cloud species equations and create !! lookup tables in Thomspson scheme. !>\section gen_thompson_init thompson_init General Algorithm !> @{ - SUBROUTINE thompson_init(is_aerosol_aware_in, & + subroutine thompson_init(is_aerosol_aware_in, & merra2_aerosol_aware_in, & mpicomm, mpirank, mpiroot, & threads, errmsg, errflg) - IMPLICIT NONE + implicit none - LOGICAL, INTENT(IN) :: is_aerosol_aware_in - LOGICAL, INTENT(IN) :: merra2_aerosol_aware_in - INTEGER, INTENT(IN) :: mpicomm, mpirank, mpiroot - INTEGER, INTENT(IN) :: threads - CHARACTER(len=*), INTENT(INOUT) :: errmsg - INTEGER, INTENT(INOUT) :: errflg + logical, intent(in) :: is_aerosol_aware_in + logical, intent(in) :: merra2_aerosol_aware_in + integer, intent(in) :: mpicomm, mpirank, mpiroot + integer, intent(In) :: threads + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg - INTEGER:: i, j, k, l, m, n - LOGICAL:: micro_init - real :: stime, etime - LOGICAL, PARAMETER :: precomputed_tables = .FALSE. + integer:: i, j, k, l, m, n + logical:: micro_init + real :: stime, etime + logical, parameter :: precomputed_tables = .FALSE. ! Set module variable is_aerosol_aware/merra2_aerosol_aware - is_aerosol_aware = is_aerosol_aware_in - merra2_aerosol_aware = merra2_aerosol_aware_in - if (is_aerosol_aware .and. merra2_aerosol_aware) then - errmsg = 'Logic error in thompson_init: only one of the two options can be true, ' // & - 'not both: is_aerosol_aware or merra2_aerosol_aware' - errflg = 1 - return - end if - if (mpirank==mpiroot) then - if (is_aerosol_aware) then - write (*,'(a)') 'Using aerosol-aware version of Thompson microphysics' - else if(merra2_aerosol_aware) then - write (*,'(a)') 'Using merra2 aerosol-aware version of Thompson microphysics' - else - write (*,'(a)') 'Using non-aerosol-aware version of Thompson microphysics' - end if - end if + is_aerosol_aware = is_aerosol_aware_in + merra2_aerosol_aware = merra2_aerosol_aware_in + if (is_aerosol_aware .and. merra2_aerosol_aware) then + errmsg = 'Logic error in thompson_init: only one of the two options can be true, ' // & + 'not both: is_aerosol_aware or merra2_aerosol_aware' + errflg = 1 + return + end if + if (mpirank==mpiroot) then + if (is_aerosol_aware) then + write (*,'(a)') 'Using aerosol-aware version of Thompson microphysics' + else if(merra2_aerosol_aware) then + write (*,'(a)') 'Using merra2 aerosol-aware version of Thompson microphysics' + else + write (*,'(a)') 'Using non-aerosol-aware version of Thompson microphysics' + end if + end if - micro_init = .FALSE. + micro_init = .FALSE. !> - Allocate space for lookup tables (J. Michalakes 2009Jun08). - if (.NOT. ALLOCATED(tcg_racg) ) then - ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) - micro_init = .TRUE. - endif + if (.NOT. ALLOCATED(tcg_racg) ) then + ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + micro_init = .TRUE. + endif - if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) - - if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) - if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) - - if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,nbc,45,ntb_IN)) - if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,nbc,45,ntb_IN)) - - if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45,ntb_IN)) - if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45,ntb_IN)) - if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45,ntb_IN)) - if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45,ntb_IN)) - - if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1)) - if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1)) - if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1)) - - if (.NOT. ALLOCATED(t_Efrw)) ALLOCATE(t_Efrw(nbr,nbc)) - if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc)) - - if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r)) - if (.NOT. ALLOCATED(tpc_wev)) ALLOCATE(tpc_wev(nbc,ntb_c,nbc)) - if (.NOT. ALLOCATED(tnc_wev)) ALLOCATE(tnc_wev(nbc,ntb_c,nbc)) - - if (.NOT. ALLOCATED(tnccn_act)) & - ALLOCATE(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark)) - - if_micro_init: if (micro_init) then + if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,nbc,45,ntb_IN)) + if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,nbc,45,ntb_IN)) + + if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45,ntb_IN)) + + if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1)) + if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1)) + if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1)) + + if (.NOT. ALLOCATED(t_Efrw)) ALLOCATE(t_Efrw(nbr,nbc)) + if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc)) + + if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r)) + if (.NOT. ALLOCATED(tpc_wev)) ALLOCATE(tpc_wev(nbc,ntb_c,nbc)) + if (.NOT. ALLOCATED(tnc_wev)) ALLOCATE(tnc_wev(nbc,ntb_c,nbc)) + + if (.NOT. ALLOCATED(tnccn_act)) & + ALLOCATE(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark)) + + if_micro_init: if (micro_init) then !> - From Martin et al. (1994), assign gamma shape parameter mu for cloud !! drops according to general dispersion characteristics (disp=~0.25 @@ -535,452 +532,452 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & !.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime !.. to 2 for really dirty air. This not used in 2-moment cloud water !.. scheme and nu_c used instead and varies from 2 to 15 (integer-only). - mu_c_l = MIN(15., (1000.E6/Nt_c_l + 2.)) - mu_c_o = MIN(15., (1000.E6/Nt_c_o + 2.)) + mu_c_l = MIN(15., (1000.E6/Nt_c_l + 2.)) + mu_c_o = MIN(15., (1000.E6/Nt_c_o + 2.)) !> - Compute Schmidt number to one-third used numerous times - Sc3 = Sc**(1./3.) + Sc3 = Sc**(1./3.) !> - Compute minimum ice diam from mass, min snow/graupel mass from diam - D0i = (xm0i/am_i)**(1./bm_i) - xm0s = am_s * D0s**bm_s - xm0g = am_g * D0g**bm_g + D0i = (xm0i/am_i)**(1./bm_i) + xm0s = am_s * D0s**bm_s + xm0g = am_g * D0g**bm_g !> - Compute constants various exponents and gamma() associated with cloud, !! rain, snow, and graupel - do n = 1, 15 - cce(1,n) = n + 1. - cce(2,n) = bm_r + n + 1. - cce(3,n) = bm_r + n + 4. - cce(4,n) = n + bv_c + 1. - cce(5,n) = bm_r + n + bv_c + 1. - ccg(1,n) = WGAMMA(cce(1,n)) - ccg(2,n) = WGAMMA(cce(2,n)) - ccg(3,n) = WGAMMA(cce(3,n)) - ccg(4,n) = WGAMMA(cce(4,n)) - ccg(5,n) = WGAMMA(cce(5,n)) - ocg1(n) = 1./ccg(1,n) - ocg2(n) = 1./ccg(2,n) - enddo + do n = 1, 15 + cce(1,n) = n + 1. + cce(2,n) = bm_r + n + 1. + cce(3,n) = bm_r + n + 4. + cce(4,n) = n + bv_c + 1. + cce(5,n) = bm_r + n + bv_c + 1. + ccg(1,n) = WGAMMA(cce(1,n)) + ccg(2,n) = WGAMMA(cce(2,n)) + ccg(3,n) = WGAMMA(cce(3,n)) + ccg(4,n) = WGAMMA(cce(4,n)) + ccg(5,n) = WGAMMA(cce(5,n)) + ocg1(n) = 1./ccg(1,n) + ocg2(n) = 1./ccg(2,n) + enddo - cie(1) = mu_i + 1. - cie(2) = bm_i + mu_i + 1. - cie(3) = bm_i + mu_i + bv_i + 1. - cie(4) = mu_i + bv_i + 1. - cie(5) = mu_i + 2. - cie(6) = bm_i*0.5 + mu_i + bv_i + 1. - cie(7) = bm_i*0.5 + mu_i + 1. - cig(1) = WGAMMA(cie(1)) - cig(2) = WGAMMA(cie(2)) - cig(3) = WGAMMA(cie(3)) - cig(4) = WGAMMA(cie(4)) - cig(5) = WGAMMA(cie(5)) - cig(6) = WGAMMA(cie(6)) - cig(7) = WGAMMA(cie(7)) - oig1 = 1./cig(1) - oig2 = 1./cig(2) - obmi = 1./bm_i - - cre(1) = bm_r + 1. - cre(2) = mu_r + 1. - cre(3) = bm_r + mu_r + 1. - cre(4) = bm_r*2. + mu_r + 1. - cre(5) = mu_r + bv_r + 1. - cre(6) = bm_r + mu_r + bv_r + 1. - cre(7) = bm_r*0.5 + mu_r + bv_r + 1. - cre(8) = bm_r + mu_r + bv_r + 3. - cre(9) = mu_r + bv_r + 3. - cre(10) = mu_r + 2. - cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) - cre(12) = bm_r*0.5 + mu_r + 1. - cre(13) = bm_r*2. + mu_r + bv_r + 1. - do n = 1, 13 - crg(n) = WGAMMA(cre(n)) - enddo - obmr = 1./bm_r - ore1 = 1./cre(1) - org1 = 1./crg(1) - org2 = 1./crg(2) - org3 = 1./crg(3) - - cse(1) = bm_s + 1. - cse(2) = bm_s + 2. - cse(3) = bm_s*2. - cse(4) = bm_s + bv_s + 1. - cse(5) = bm_s*2. + bv_s + 1. - cse(6) = bm_s*2. + 1. - cse(7) = bm_s + mu_s + 1. - cse(8) = bm_s + mu_s + 2. - cse(9) = bm_s + mu_s + 3. - cse(10) = bm_s + mu_s + bv_s + 1. - cse(11) = bm_s*2. + mu_s + bv_s + 1. - cse(12) = bm_s*2. + mu_s + 1. - cse(13) = bv_s + 2. - cse(14) = bm_s + bv_s - cse(15) = mu_s + 1. - cse(16) = 1.0 + (1.0 + bv_s)/2. - cse(17) = cse(16) + mu_s + 1. - cse(18) = bv_s + mu_s + 3. - do n = 1, 18 - csg(n) = WGAMMA(cse(n)) - enddo - oams = 1./am_s - obms = 1./bm_s - ocms = oams**obms - - cge(1) = bm_g + 1. - cge(2) = mu_g + 1. - cge(3) = bm_g + mu_g + 1. - cge(4) = bm_g*2. + mu_g + 1. - cge(5) = bm_g*2. + mu_g + bv_g + 1. - cge(6) = bm_g + mu_g + bv_g + 1. - cge(7) = bm_g + mu_g + bv_g + 2. - cge(8) = bm_g + mu_g + bv_g + 3. - cge(9) = mu_g + bv_g + 3. - cge(10) = mu_g + 2. - cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) - cge(12) = 0.5*(bv_g + 5.) + mu_g - do n = 1, 12 - cgg(n) = WGAMMA(cge(n)) - enddo - oamg = 1./am_g - obmg = 1./bm_g - ocmg = oamg**obmg - oge1 = 1./cge(1) - ogg1 = 1./cgg(1) - ogg2 = 1./cgg(2) - ogg3 = 1./cgg(3) + cie(1) = mu_i + 1. + cie(2) = bm_i + mu_i + 1. + cie(3) = bm_i + mu_i + bv_i + 1. + cie(4) = mu_i + bv_i + 1. + cie(5) = mu_i + 2. + cie(6) = bm_i*0.5 + mu_i + bv_i + 1. + cie(7) = bm_i*0.5 + mu_i + 1. + cig(1) = WGAMMA(cie(1)) + cig(2) = WGAMMA(cie(2)) + cig(3) = WGAMMA(cie(3)) + cig(4) = WGAMMA(cie(4)) + cig(5) = WGAMMA(cie(5)) + cig(6) = WGAMMA(cie(6)) + cig(7) = WGAMMA(cie(7)) + oig1 = 1./cig(1) + oig2 = 1./cig(2) + obmi = 1./bm_i + + cre(1) = bm_r + 1. + cre(2) = mu_r + 1. + cre(3) = bm_r + mu_r + 1. + cre(4) = bm_r*2. + mu_r + 1. + cre(5) = mu_r + bv_r + 1. + cre(6) = bm_r + mu_r + bv_r + 1. + cre(7) = bm_r*0.5 + mu_r + bv_r + 1. + cre(8) = bm_r + mu_r + bv_r + 3. + cre(9) = mu_r + bv_r + 3. + cre(10) = mu_r + 2. + cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) + cre(12) = bm_r*0.5 + mu_r + 1. + cre(13) = bm_r*2. + mu_r + bv_r + 1. + do n = 1, 13 + crg(n) = WGAMMA(cre(n)) + enddo + obmr = 1./bm_r + ore1 = 1./cre(1) + org1 = 1./crg(1) + org2 = 1./crg(2) + org3 = 1./crg(3) + + cse(1) = bm_s + 1. + cse(2) = bm_s + 2. + cse(3) = bm_s*2. + cse(4) = bm_s + bv_s + 1. + cse(5) = bm_s*2. + bv_s + 1. + cse(6) = bm_s*2. + 1. + cse(7) = bm_s + mu_s + 1. + cse(8) = bm_s + mu_s + 2. + cse(9) = bm_s + mu_s + 3. + cse(10) = bm_s + mu_s + bv_s + 1. + cse(11) = bm_s*2. + mu_s + bv_s + 1. + cse(12) = bm_s*2. + mu_s + 1. + cse(13) = bv_s + 2. + cse(14) = bm_s + bv_s + cse(15) = mu_s + 1. + cse(16) = 1.0 + (1.0 + bv_s)/2. + cse(17) = cse(16) + mu_s + 1. + cse(18) = bv_s + mu_s + 3. + do n = 1, 18 + csg(n) = WGAMMA(cse(n)) + enddo + oams = 1./am_s + obms = 1./bm_s + ocms = oams**obms + + cge(1) = bm_g + 1. + cge(2) = mu_g + 1. + cge(3) = bm_g + mu_g + 1. + cge(4) = bm_g*2. + mu_g + 1. + cge(5) = bm_g*2. + mu_g + bv_g + 1. + cge(6) = bm_g + mu_g + bv_g + 1. + cge(7) = bm_g + mu_g + bv_g + 2. + cge(8) = bm_g + mu_g + bv_g + 3. + cge(9) = mu_g + bv_g + 3. + cge(10) = mu_g + 2. + cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) + cge(12) = 0.5*(bv_g + 5.) + mu_g + do n = 1, 12 + cgg(n) = WGAMMA(cge(n)) + enddo + oamg = 1./am_g + obmg = 1./bm_g + ocmg = oamg**obmg + oge1 = 1./cge(1) + ogg1 = 1./cgg(1) + ogg2 = 1./cgg(2) + ogg3 = 1./cgg(3) !+---+-----------------------------------------------------------------+ !> - Simplify various rate equations !+---+-----------------------------------------------------------------+ !> - Compute rain collecting cloud water and cloud ice - t1_qr_qc = PI*.25*av_r * crg(9) - t1_qr_qi = PI*.25*av_r * crg(9) - t2_qr_qi = PI*.25*am_r*av_r * crg(8) + t1_qr_qc = PI*.25*av_r * crg(9) + t1_qr_qi = PI*.25*av_r * crg(9) + t2_qr_qi = PI*.25*am_r*av_r * crg(8) !> - Compute graupel collecting cloud water - t1_qg_qc = PI*.25*av_g * cgg(9) + t1_qg_qc = PI*.25*av_g * cgg(9) !> - Compute snow collecting cloud water - t1_qs_qc = PI*.25*av_s + t1_qs_qc = PI*.25*av_s !> - Compute snow collecting cloud ice - t1_qs_qi = PI*.25*av_s + t1_qs_qi = PI*.25*av_s !> - Compute evaporation of rain; ignore depositional growth of rain - t1_qr_ev = 0.78 * crg(10) - t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) + t1_qr_ev = 0.78 * crg(10) + t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) !> - Compute sublimation/depositional growth of snow - t1_qs_sd = 0.86 - t2_qs_sd = 0.28*Sc3*SQRT(av_s) + t1_qs_sd = 0.86 + t2_qs_sd = 0.28*Sc3*SQRT(av_s) !> - Compute melting of snow - t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 - t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) + t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 + t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) !> - Compute sublimation/depositional growth of graupel - t1_qg_sd = 0.86 * cgg(10) - t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) + t1_qg_sd = 0.86 * cgg(10) + t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) !> - Compute melting of graupel - t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) - t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) + t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) + t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) !> - Compute constants for helping find lookup table indexes - nic2 = NINT(ALOG10(r_c(1))) - nii2 = NINT(ALOG10(r_i(1))) - nii3 = NINT(ALOG10(Nt_i(1))) - nir2 = NINT(ALOG10(r_r(1))) - nir3 = NINT(ALOG10(N0r_exp(1))) - nis2 = NINT(ALOG10(r_s(1))) - nig2 = NINT(ALOG10(r_g(1))) - nig3 = NINT(ALOG10(N0g_exp(1))) - niIN2 = NINT(ALOG10(Nt_IN(1))) + nic2 = NINT(ALOG10(r_c(1))) + nii2 = NINT(ALOG10(r_i(1))) + nii3 = NINT(ALOG10(Nt_i(1))) + nir2 = NINT(ALOG10(r_r(1))) + nir3 = NINT(ALOG10(N0r_exp(1))) + nis2 = NINT(ALOG10(r_s(1))) + nig2 = NINT(ALOG10(r_g(1))) + nig3 = NINT(ALOG10(N0g_exp(1))) + niIN2 = NINT(ALOG10(Nt_IN(1))) !> - Create bins of cloud water (from min diameter up to 100 microns) - Dc(1) = D0c*1.0d0 - dtc(1) = D0c*1.0d0 - do n = 2, nbc - Dc(n) = Dc(n-1) + 1.0D-6 - dtc(n) = (Dc(n) - Dc(n-1)) - enddo + Dc(1) = D0c*1.0d0 + dtc(1) = D0c*1.0d0 + do n = 2, nbc + Dc(n) = Dc(n-1) + 1.0D-6 + dtc(n) = (Dc(n) - Dc(n-1)) + enddo !> - Create bins of cloud ice (from min diameter up to 2x min snow size) - xDx(1) = D0i*1.0d0 - xDx(nbi+1) = 2.0d0*D0s - do n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & - *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbi - Di(n) = DSQRT(xDx(n)*xDx(n+1)) - dti(n) = xDx(n+1) - xDx(n) - enddo + xDx(1) = D0i*1.0d0 + xDx(nbi+1) = 2.0d0*D0s + do n = 2, nbi + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & + *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbi + Di(n) = DSQRT(xDx(n)*xDx(n+1)) + dti(n) = xDx(n+1) - xDx(n) + enddo !> - Create bins of rain (from min diameter up to 5 mm) - xDx(1) = D0r*1.0d0 - xDx(nbr+1) = 0.005d0 - do n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & - *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbr - Dr(n) = DSQRT(xDx(n)*xDx(n+1)) - dtr(n) = xDx(n+1) - xDx(n) - enddo + xDx(1) = D0r*1.0d0 + xDx(nbr+1) = 0.005d0 + do n = 2, nbr + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & + *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbr + Dr(n) = DSQRT(xDx(n)*xDx(n+1)) + dtr(n) = xDx(n+1) - xDx(n) + enddo !> - Create bins of snow (from min diameter up to 2 cm) - xDx(1) = D0s*1.0d0 - xDx(nbs+1) = 0.02d0 - do n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & - *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbs - Ds(n) = DSQRT(xDx(n)*xDx(n+1)) - dts(n) = xDx(n+1) - xDx(n) - enddo + xDx(1) = D0s*1.0d0 + xDx(nbs+1) = 0.02d0 + do n = 2, nbs + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & + *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbs + Ds(n) = DSQRT(xDx(n)*xDx(n+1)) + dts(n) = xDx(n+1) - xDx(n) + enddo !> - Create bins of graupel (from min diameter up to 5 cm) - xDx(1) = D0g*1.0d0 - xDx(nbg+1) = 0.05d0 - do n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & - *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbg - Dg(n) = DSQRT(xDx(n)*xDx(n+1)) - dtg(n) = xDx(n+1) - xDx(n) - enddo + xDx(1) = D0g*1.0d0 + xDx(nbg+1) = 0.05d0 + do n = 2, nbg + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & + *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbg + Dg(n) = DSQRT(xDx(n)*xDx(n+1)) + dtg(n) = xDx(n+1) - xDx(n) + enddo !> - Create bins of cloud droplet number concentration (1 to 3000 per cc) - xDx(1) = 1.0d0 - xDx(nbc+1) = 3000.0d0 - do n = 2, nbc - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbc) & - *DLOG(xDx(nbc+1)/xDx(1)) +DLOG(xDx(1))) - enddo - do n = 1, nbc - t_Nc(n) = DSQRT(xDx(n)*xDx(n+1)) * 1.D6 - enddo - nic1 = DLOG(t_Nc(nbc)/t_Nc(1)) + xDx(1) = 1.0d0 + xDx(nbc+1) = 3000.0d0 + do n = 2, nbc + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbc) & + *DLOG(xDx(nbc+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbc + t_Nc(n) = DSQRT(xDx(n)*xDx(n+1)) * 1.D6 + enddo + nic1 = DLOG(t_Nc(nbc)/t_Nc(1)) !+---+-----------------------------------------------------------------+ !> - Create lookup tables for most costly calculations !+---+-----------------------------------------------------------------+ - ! Assign mpicomm to module variable - mpi_communicator = mpicomm +! Assign mpicomm to module variable + mpi_communicator = mpicomm - ! Standard tables are only written by master MPI task; - ! (physics init cannot be called by multiple threads, - ! hence no need to test for a specific thread number) - if (mpirank==mpiroot) then - thompson_table_writer = .true. - else - thompson_table_writer = .false. - end if - - precomputed_tables_1: if (.not.precomputed_tables) then - - call cpu_time(stime) - - do m = 1, ntb_r - do k = 1, ntb_r1 - do j = 1, ntb_g - do i = 1, ntb_g1 - tcg_racg(i,j,k,m) = 0.0d0 - tmr_racg(i,j,k,m) = 0.0d0 - tcr_gacr(i,j,k,m) = 0.0d0 - tmg_gacr(i,j,k,m) = 0.0d0 - tnr_racg(i,j,k,m) = 0.0d0 - tnr_gacr(i,j,k,m) = 0.0d0 +! Standard tables are only written by master MPI task; +! (physics init cannot be called by multiple threads, +! hence no need to test for a specific thread number) + if (mpirank==mpiroot) then + thompson_table_writer = .true. + else + thompson_table_writer = .false. + end if + + precomputed_tables_1: if (.not.precomputed_tables) then + + call cpu_time(stime) + + do m = 1, ntb_r + do k = 1, ntb_r1 + do j = 1, ntb_g + do i = 1, ntb_g1 + tcg_racg(i,j,k,m) = 0.0d0 + tmr_racg(i,j,k,m) = 0.0d0 + tcr_gacr(i,j,k,m) = 0.0d0 + tmg_gacr(i,j,k,m) = 0.0d0 + tnr_racg(i,j,k,m) = 0.0d0 + tnr_gacr(i,j,k,m) = 0.0d0 + enddo enddo enddo enddo - enddo - do m = 1, ntb_r - do k = 1, ntb_r1 - do j = 1, ntb_t - do i = 1, ntb_s - tcs_racs1(i,j,k,m) = 0.0d0 - tmr_racs1(i,j,k,m) = 0.0d0 - tcs_racs2(i,j,k,m) = 0.0d0 - tmr_racs2(i,j,k,m) = 0.0d0 - tcr_sacr1(i,j,k,m) = 0.0d0 - tms_sacr1(i,j,k,m) = 0.0d0 - tcr_sacr2(i,j,k,m) = 0.0d0 - tms_sacr2(i,j,k,m) = 0.0d0 - tnr_racs1(i,j,k,m) = 0.0d0 - tnr_racs2(i,j,k,m) = 0.0d0 - tnr_sacr1(i,j,k,m) = 0.0d0 - tnr_sacr2(i,j,k,m) = 0.0d0 + do m = 1, ntb_r + do k = 1, ntb_r1 + do j = 1, ntb_t + do i = 1, ntb_s + tcs_racs1(i,j,k,m) = 0.0d0 + tmr_racs1(i,j,k,m) = 0.0d0 + tcs_racs2(i,j,k,m) = 0.0d0 + tmr_racs2(i,j,k,m) = 0.0d0 + tcr_sacr1(i,j,k,m) = 0.0d0 + tms_sacr1(i,j,k,m) = 0.0d0 + tcr_sacr2(i,j,k,m) = 0.0d0 + tms_sacr2(i,j,k,m) = 0.0d0 + tnr_racs1(i,j,k,m) = 0.0d0 + tnr_racs2(i,j,k,m) = 0.0d0 + tnr_sacr1(i,j,k,m) = 0.0d0 + tnr_sacr2(i,j,k,m) = 0.0d0 + enddo enddo enddo enddo - enddo - do m = 1, ntb_IN - do k = 1, 45 - do j = 1, ntb_r1 - do i = 1, ntb_r - tpi_qrfz(i,j,k,m) = 0.0d0 - tni_qrfz(i,j,k,m) = 0.0d0 - tpg_qrfz(i,j,k,m) = 0.0d0 - tnr_qrfz(i,j,k,m) = 0.0d0 + do m = 1, ntb_IN + do k = 1, 45 + do j = 1, ntb_r1 + do i = 1, ntb_r + tpi_qrfz(i,j,k,m) = 0.0d0 + tni_qrfz(i,j,k,m) = 0.0d0 + tpg_qrfz(i,j,k,m) = 0.0d0 + tnr_qrfz(i,j,k,m) = 0.0d0 + enddo enddo - enddo - do j = 1, nbc - do i = 1, ntb_c - tpi_qcfz(i,j,k,m) = 0.0d0 - tni_qcfz(i,j,k,m) = 0.0d0 + do j = 1, nbc + do i = 1, ntb_c + tpi_qcfz(i,j,k,m) = 0.0d0 + tni_qcfz(i,j,k,m) = 0.0d0 + enddo enddo enddo enddo - enddo - do j = 1, ntb_i1 - do i = 1, ntb_i - tps_iaus(i,j) = 0.0d0 - tni_iaus(i,j) = 0.0d0 - tpi_ide(i,j) = 0.0d0 + do j = 1, ntb_i1 + do i = 1, ntb_i + tps_iaus(i,j) = 0.0d0 + tni_iaus(i,j) = 0.0d0 + tpi_ide(i,j) = 0.0d0 + enddo enddo - enddo - do j = 1, nbc - do i = 1, nbr - t_Efrw(i,j) = 0.0 - enddo - do i = 1, nbs - t_Efsw(i,j) = 0.0 + do j = 1, nbc + do i = 1, nbr + t_Efrw(i,j) = 0.0 + enddo + do i = 1, nbs + t_Efsw(i,j) = 0.0 + enddo enddo - enddo - do k = 1, ntb_r - do j = 1, ntb_r1 - do i = 1, nbr - tnr_rev(i,j,k) = 0.0d0 + do k = 1, ntb_r + do j = 1, ntb_r1 + do i = 1, nbr + tnr_rev(i,j,k) = 0.0d0 + enddo enddo enddo - enddo - do k = 1, nbc - do j = 1, ntb_c - do i = 1, nbc - tpc_wev(i,j,k) = 0.0d0 - tnc_wev(i,j,k) = 0.0d0 + do k = 1, nbc + do j = 1, ntb_c + do i = 1, nbc + tpc_wev(i,j,k) = 0.0d0 + tnc_wev(i,j,k) = 0.0d0 + enddo enddo enddo - enddo - do m = 1, ntb_ark - do l = 1, ntb_arr - do k = 1, ntb_art - do j = 1, ntb_arw - do i = 1, ntb_arc - tnccn_act(i,j,k,l,m) = 1.0 + do m = 1, ntb_ark + do l = 1, ntb_arr + do k = 1, ntb_art + do j = 1, ntb_arw + do i = 1, ntb_arc + tnccn_act(i,j,k,l,m) = 1.0 + enddo enddo enddo enddo enddo - enddo - if (mpirank==mpiroot) write (*,*)'creating microphysics lookup tables ... ' - if (mpirank==mpiroot) write (*,'(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & - ' using: mu_c_o=',mu_c_o,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g + if (mpirank==mpiroot) write (*,*)'creating microphysics lookup tables ... ' + if (mpirank==mpiroot) write (*,'(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & + ' using: mu_c_o=',mu_c_o,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g !> - Call table_ccnact() to read a static file containing CCN activation of aerosols. The !! data were created from a parcel model by Feingold & Heymsfield with !! further changes by Eidhammer and Kriedenweis - if (mpirank==mpiroot) write(*,*) ' calling table_ccnAct routine' - call table_ccnAct(errmsg,errflg) - if (.not. errflg==0) return + if (mpirank==mpiroot) write(*,*) ' calling table_ccnAct routine' + call table_ccnAct(errmsg,errflg) + if (.not. errflg==0) return !> - Call table_efrw() and table_efsw() to creat collision efficiency table !! between rain/snow and cloud water - if (mpirank==mpiroot) write(*,*) ' creating qc collision eff tables' - call table_Efrw - call table_Efsw + if (mpirank==mpiroot) write(*,*) ' creating qc collision eff tables' + call table_Efrw + call table_Efsw !> - Call table_dropevap() to creat rain drop evaporation table - if (mpirank==mpiroot) write(*,*) ' creating rain evap table' - call table_dropEvap + if (mpirank==mpiroot) write(*,*) ' creating rain evap table' + call table_dropEvap !> - Call qi_aut_qs() to create conversion of some ice mass into snow category - if (mpirank==mpiroot) write(*,*) ' creating ice converting to snow table' - call qi_aut_qs + if (mpirank==mpiroot) write(*,*) ' creating ice converting to snow table' + call qi_aut_qs - call cpu_time(etime) - if (mpirank==mpiroot) print '("Calculating Thompson tables part 1 took ",f10.3," seconds.")', etime-stime + call cpu_time(etime) + if (mpirank==mpiroot) print '("Calculating Thompson tables part 1 took ",f10.3," seconds.")', etime-stime - end if precomputed_tables_1 + end if precomputed_tables_1 !> - Call radar_init() to initialize various constants for computing radar reflectivity - call cpu_time(stime) - xam_r = am_r - xbm_r = bm_r - xmu_r = mu_r - xam_s = am_s - xbm_s = bm_s - xmu_s = mu_s - xam_g = am_g - xbm_g = bm_g - xmu_g = mu_g - call radar_init - call cpu_time(etime) - if (mpirank==mpiroot) print '("Calling radar_init took ",f10.3," seconds.")', etime-stime + call cpu_time(stime) + xam_r = am_r + xbm_r = bm_r + xmu_r = mu_r + xam_s = am_s + xbm_s = bm_s + xmu_s = mu_s + xam_g = am_g + xbm_g = bm_g + xmu_g = mu_g + call radar_init + call cpu_time(etime) + if (mpirank==mpiroot) print '("Calling radar_init took ",f10.3," seconds.")', etime-stime - if_not_iiwarm: if (.not. iiwarm) then + if_not_iiwarm: if (.not. iiwarm) then - precomputed_tables_2: if (.not.precomputed_tables) then + precomputed_tables_2: if (.not.precomputed_tables) then - call cpu_time(stime) + call cpu_time(stime) !> - Call qr_acr_qg() to create rain collecting graupel & graupel collecting rain table - if (mpirank==mpiroot) write(*,*) ' creating rain collecting graupel table' - call cpu_time(stime) - call qr_acr_qg - call cpu_time(etime) - if (mpirank==mpiroot) print '("Computing rain collecting graupel table took ",f10.3," seconds.")', etime-stime + if (mpirank==mpiroot) write(*,*) ' creating rain collecting graupel table' + call cpu_time(stime) + call qr_acr_qg + call cpu_time(etime) + if (mpirank==mpiroot) print '("Computing rain collecting graupel table took ",f10.3," seconds.")', etime-stime !> - Call qr_acr_qs() to create rain collecting snow & snow collecting rain table - if (mpirank==mpiroot) write (*,*) ' creating rain collecting snow table' - call cpu_time(stime) - call qr_acr_qs - call cpu_time(etime) - if (mpirank==mpiroot) print '("Computing rain collecting snow table took ",f10.3," seconds.")', etime-stime + if (mpirank==mpiroot) write (*,*) ' creating rain collecting snow table' + call cpu_time(stime) + call qr_acr_qs + call cpu_time(etime) + if (mpirank==mpiroot) print '("Computing rain collecting snow table took ",f10.3," seconds.")', etime-stime !> - Call freezeh2o() to create cloud water and rain freezing (Bigg, 1953) table - if (mpirank==mpiroot) write(*,*) ' creating freezing of water drops table' - call cpu_time(stime) - call freezeH2O(threads) - call cpu_time(etime) - if (mpirank==mpiroot) print '("Computing freezing of water drops table took ",f10.3," seconds.")', etime-stime + if (mpirank==mpiroot) write(*,*) ' creating freezing of water drops table' + call cpu_time(stime) + call freezeH2O(threads) + call cpu_time(etime) + if (mpirank==mpiroot) print '("Computing freezing of water drops table took ",f10.3," seconds.")', etime-stime - call cpu_time(etime) - if (mpirank==mpiroot) print '("Calculating Thompson tables part 2 took ",f10.3," seconds.")', etime-stime + call cpu_time(etime) + if (mpirank==mpiroot) print '("Calculating Thompson tables part 2 took ",f10.3," seconds.")', etime-stime - end if precomputed_tables_2 + end if precomputed_tables_2 - endif if_not_iiwarm + endif if_not_iiwarm - if (mpirank==mpiroot) write(*,*) ' ... DONE microphysical lookup tables' + if (mpirank==mpiroot) write(*,*) ' ... DONE microphysical lookup tables' - endif if_micro_init + endif if_micro_init - END SUBROUTINE thompson_init + end subroutine thompson_init !> @} !>\ingroup aathompson !!This is a wrapper routine designed to transfer values from 3D to 1D. !!\section gen_mpgtdriver Thompson mp_gt_driver General Algorithm !> @{ - SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & + subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa, nifa, nwfa2d, nifa2d, & tt, th, pii, & p, w, dz, dt_in, dt_inner, & @@ -1025,223 +1022,223 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nrten3, ncten3, qcten3, & pfils, pflls) - implicit none + implicit none !..Subroutine arguments - INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - qv, qc, qr, qi, qs, qg, ni, nr - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & - tt, th - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(IN):: & - pii - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & - nc, nwfa, nifa - REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d - INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(IN):: lsm - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & - re_cloud, re_ice, re_snow - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: pfils, pflls - INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch, n_var_spp - REAL, DIMENSION(:,:), INTENT(IN) :: rand_pert - REAL, DIMENSION(:), INTENT(IN) :: spp_prt_list, spp_stddev_cutoff - CHARACTER(len=10), DIMENSION(:), INTENT(IN) :: spp_var_list - INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs + integer, intent(in):: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + qv, qc, qr, qi, qs, qg, ni, nr + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + tt, th + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(in):: & + pii + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + nc, nwfa, nifa + real(kind_phys), dimension(ims:ime, jms:jme), optional, intent(in):: nwfa2d, nifa2d + integer, dimension(ims:ime, jms:jme), intent(in):: lsm + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + re_cloud, re_ice, re_snow + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: pfils, pflls + integer, intent(in) :: rand_perturb_on, kme_stoch, n_var_spp + real(kind_phys), dimension(:,:), intent(in) :: rand_pert + real(kind_phys), dimension(:), intent(in) :: spp_prt_list, spp_stddev_cutoff + character(len=10), dimension(:), intent(in) :: spp_var_list + integer, intent(in):: has_reqc, has_reqi, has_reqs #if ( WRF_CHEM == 1 ) - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - rainprod, evapprod + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + rainprod, evapprod #endif - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & - p, w, dz - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & - RAINNC, RAINNCV, SR - REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: & - SNOWNC, SNOWNCV, & - ICENC, ICENCV, & - GRAUPELNC, GRAUPELNCV - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - refl_10cm - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & - max_hail_diam_sfc - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & - vt_dbz_wt - LOGICAL, INTENT(IN) :: first_time_step - REAL, INTENT(IN):: dt_in, dt_inner - LOGICAL, INTENT(IN) :: sedi_semi - INTEGER, INTENT(IN) :: decfl - ! To support subcycling: current step and maximum number of steps - INTEGER, INTENT (IN) :: istep, nsteps - LOGICAL, INTENT (IN) :: fullradar_diag - ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. - LOGICAL, INTENT (IN) :: ext_diag - LOGICAL, OPTIONAL, INTENT(IN):: aero_ind_fdb - REAL, DIMENSION(:,:,:), INTENT(INOUT):: & - !vts1, txri, txrc, & - prw_vcdc, & - prw_vcde, tpri_inu, tpri_ide_d, & - tpri_ide_s, tprs_ide, & - tprs_sde_d, tprs_sde_s, tprg_gde_d, & - tprg_gde_s, tpri_iha, tpri_wfz, & - tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & - tprg_rcs, tprs_rcs, & - tprr_rci, tprg_rcg, & - tprw_vcd_c, tprw_vcd_e, tprr_sml, & - tprr_gml, tprr_rcg, & - tprr_rcs, tprv_rev, tten3, qvten3, & - qrten3, qsten3, qgten3, qiten3, niten3, & - nrten3, ncten3, qcten3 - -!..Local variables - REAL, DIMENSION(kts:kte):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, nc1d, nwfa1d, nifa1d, & - t1d, p1d, w1d, dz1d, rho, dBZ, pfil1, pfll1 -!..Extended diagnostics, single column arrays - REAL, DIMENSION(:), ALLOCATABLE:: & - !vtsk1, txri1, txrc1, & - prw_vcdc1, & - prw_vcde1, tpri_inu1, tpri_ide1_d, & - tpri_ide1_s, tprs_ide1, & - tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & - tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& - tprg_rcs1, tprs_rcs1, & - tprr_rci1, tprg_rcg1, & - tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & - tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, tten1, qvten1, & - qrten1, qsten1, qgten1, qiten1, niten1, & - nrten1, ncten1, qcten1 - - REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(in):: & + p, w, dz + real(kind_phys), dimension(ims:ime, jms:jme), intent(inout):: & + RAINNC, RAINNCV, SR + real(kind_phys), dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC, SNOWNCV, & + ICENC, ICENCV, & + GRAUPELNC, GRAUPELNCV + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + refl_10cm + real(kind_phys), dimension(ims:ime, jms:jme), intent(inout):: & + max_hail_diam_sfc + real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + vt_dbz_wt + logical, intent(in) :: first_time_step + real(kind_phys), intent(in):: dt_in, dt_inner + logical, intent(in) :: sedi_semi + integer, intent(in) :: decfl + ! To support subcycling: current step and maximum number of steps + integer, intent (in) :: istep, nsteps + logical, intent (in) :: fullradar_diag + ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. + logical, intent (in) :: ext_diag + logical, optional, intent(in):: aero_ind_fdb + real(kind_phys), dimension(:,:,:), intent(inout):: & + !vts1, txri, txrc, & + prw_vcdc, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide, & + tprs_sde_d, tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprg_rcs, tprs_rcs, & + tprr_rci, tprg_rcg, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg, & + tprr_rcs, tprv_rev, tten3, qvten3, & + qrten3, qsten3, qgten3, qiten3, niten3, & + nrten3, ncten3, qcten3 + + !..Local variables + real(kind_phys), dimension(kts:kte):: & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, & + t1d, p1d, w1d, dz1d, rho, dBZ, pfil1, pfll1 + !..Extended diagnostics, single column arrays + real(kind_phys), dimension(:), allocatable:: & + !vtsk1, txri1, txrc1, & + prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1, & + tprr_rci1, tprg_rcg1, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, tten1, qvten1, & + qrten1, qsten1, qgten1, qiten1, niten1, & + nrten1, ncten1, qcten1 + + real(kind_phys), dimension(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) - REAL, DIMENSION(kts:kte):: & - rainprod1d, evapprod1d + real(kind_phys), dimension(kts:kte):: & + rainprod1d, evapprod1d #endif - REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic - REAL:: dt, pptrain, pptsnow, pptgraul, pptice - REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max - INTEGER:: lsml - REAL:: rand1, rand2, rand3, rand_pert_max - INTEGER:: i, j, k, m - INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr - INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr - INTEGER:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr - INTEGER:: i_start, j_start, i_end, j_end - LOGICAL, OPTIONAL, INTENT(IN) :: diagflag - INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref - logical :: melti = .false. - INTEGER :: ndt, it - - ! CCPP error handling - character(len=*), optional, intent( out) :: errmsg - integer, optional, intent( out) :: errflg - - ! CCPP - if (present(errmsg)) errmsg = '' - if (present(errflg)) errflg = 0 - - ! No need to test for every subcycling step - test_only_once: if (first_time_step .and. istep==1) then - ! Activate this code when removing the guard above - - if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & - (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then - if (present(errmsg) .and. present(errflg)) then - write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' - errflg = 1 - return - else - write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' - stop + real(kind_phys), dimension(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic + real(kind_phys) :: dt, pptrain, pptsnow, pptgraul, pptice + real(kind_phys) :: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max + integer:: lsml + real(kind_phys) :: rand1, rand2, rand3, rand_pert_max + integer:: i, j, k, m + integer:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr + integer:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr + integer:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr + integer:: i_start, j_start, i_end, j_end + logical, optional, intent(in) :: diagflag + integer, optional, intent(in) :: do_radar_ref + logical :: melti = .false. + integer :: ndt, it + + ! CCPP error handling + character(len=*), optional, intent( out) :: errmsg + integer, optional, intent( out) :: errflg + + ! CCPP + if (present(errmsg)) errmsg = '' + if (present(errflg)) errflg = 0 + + ! No need to test for every subcycling step + test_only_once: if (first_time_step .and. istep==1) then + ! Activate this code when removing the guard above + + if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & + (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then + if (present(errmsg) .and. present(errflg)) then + write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' + errflg = 1 + return + else + write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' + stop + end if end if - end if - if (is_aerosol_aware .and. (.not.present(nc) .or. & - .not.present(nwfa) .or. & - .not.present(nifa) .or. & - .not.present(nwfa2d) .or. & - .not.present(nifa2d) )) then - if (present(errmsg) .and. present(errflg)) then - write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & - ' and nifa2d for aerosol-aware version of Thompson microphysics' - errflg = 1 - return - else - write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & - ' and nifa2d for aerosol-aware version of Thompson microphysics' - stop - end if - else if (merra2_aerosol_aware .and. (.not.present(nc) .or. & - .not.present(nwfa) .or. & - .not.present(nifa) )) then - if (present(errmsg) .and. present(errflg)) then - write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', & - ' for merra2 aerosol-aware version of Thompson microphysics' - errflg = 1 - return - else - write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', & - ' for merra2 aerosol-aware version of Thompson microphysics' - stop + if (is_aerosol_aware .and. (.not.present(nc) .or. & + .not.present(nwfa) .or. & + .not.present(nifa) .or. & + .not.present(nwfa2d) .or. & + .not.present(nifa2d) )) then + if (present(errmsg) .and. present(errflg)) then + write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of Thompson microphysics' + errflg = 1 + return + else + write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of Thompson microphysics' + stop + end if + else if (merra2_aerosol_aware .and. (.not.present(nc) .or. & + .not.present(nwfa) .or. & + .not.present(nifa) )) then + if (present(errmsg) .and. present(errflg)) then + write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', & + ' for merra2 aerosol-aware version of Thompson microphysics' + errflg = 1 + return + else + write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, and nifa', & + ' for merra2 aerosol-aware version of Thompson microphysics' + stop + end if + else if (.not.is_aerosol_aware .and. .not.merra2_aerosol_aware .and. & + (present(nwfa) .or. present(nifa) .or. present(nwfa2d) .or. present(nifa2d))) then + write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware/merra2_aerosol_aware are FALSE' end if - else if (.not.is_aerosol_aware .and. .not.merra2_aerosol_aware .and. & - (present(nwfa) .or. present(nifa) .or. present(nwfa2d) .or. present(nifa2d))) then - write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware/merra2_aerosol_aware are FALSE' - end if - end if test_only_once - - ! These must be alwyas allocated - !allocate (vtsk1(kts:kte)) - !allocate (txri1(kts:kte)) - !allocate (txrc1(kts:kte)) - allocate_extended_diagnostics: if (ext_diag) then - allocate (prw_vcdc1(kts:kte)) - allocate (prw_vcde1(kts:kte)) - allocate (tpri_inu1(kts:kte)) - allocate (tpri_ide1_d(kts:kte)) - allocate (tpri_ide1_s(kts:kte)) - allocate (tprs_ide1(kts:kte)) - allocate (tprs_sde1_d(kts:kte)) - allocate (tprs_sde1_s(kts:kte)) - allocate (tprg_gde1_d(kts:kte)) - allocate (tprg_gde1_s(kts:kte)) - allocate (tpri_iha1(kts:kte)) - allocate (tpri_wfz1(kts:kte)) - allocate (tpri_rfz1(kts:kte)) - allocate (tprg_rfz1(kts:kte)) - allocate (tprs_scw1(kts:kte)) - allocate (tprg_scw1(kts:kte)) - allocate (tprg_rcs1(kts:kte)) - allocate (tprs_rcs1(kts:kte)) - allocate (tprr_rci1(kts:kte)) - allocate (tprg_rcg1(kts:kte)) - allocate (tprw_vcd1_c(kts:kte)) - allocate (tprw_vcd1_e(kts:kte)) - allocate (tprr_sml1(kts:kte)) - allocate (tprr_gml1(kts:kte)) - allocate (tprr_rcg1(kts:kte)) - allocate (tprr_rcs1(kts:kte)) - allocate (tprv_rev1(kts:kte)) - allocate (tten1(kts:kte)) - allocate (qvten1(kts:kte)) - allocate (qrten1(kts:kte)) - allocate (qsten1(kts:kte)) - allocate (qgten1(kts:kte)) - allocate (qiten1(kts:kte)) - allocate (niten1(kts:kte)) - allocate (nrten1(kts:kte)) - allocate (ncten1(kts:kte)) - allocate (qcten1(kts:kte)) - end if allocate_extended_diagnostics + end if test_only_once + + ! These must be alwyas allocated + !allocate (vtsk1(kts:kte)) + !allocate (txri1(kts:kte)) + !allocate (txrc1(kts:kte)) + allocate_extended_diagnostics: if (ext_diag) then + allocate (prw_vcdc1(kts:kte)) + allocate (prw_vcde1(kts:kte)) + allocate (tpri_inu1(kts:kte)) + allocate (tpri_ide1_d(kts:kte)) + allocate (tpri_ide1_s(kts:kte)) + allocate (tprs_ide1(kts:kte)) + allocate (tprs_sde1_d(kts:kte)) + allocate (tprs_sde1_s(kts:kte)) + allocate (tprg_gde1_d(kts:kte)) + allocate (tprg_gde1_s(kts:kte)) + allocate (tpri_iha1(kts:kte)) + allocate (tpri_wfz1(kts:kte)) + allocate (tpri_rfz1(kts:kte)) + allocate (tprg_rfz1(kts:kte)) + allocate (tprs_scw1(kts:kte)) + allocate (tprg_scw1(kts:kte)) + allocate (tprg_rcs1(kts:kte)) + allocate (tprs_rcs1(kts:kte)) + allocate (tprr_rci1(kts:kte)) + allocate (tprg_rcg1(kts:kte)) + allocate (tprw_vcd1_c(kts:kte)) + allocate (tprw_vcd1_e(kts:kte)) + allocate (tprr_sml1(kts:kte)) + allocate (tprr_gml1(kts:kte)) + allocate (tprr_rcg1(kts:kte)) + allocate (tprr_rcs1(kts:kte)) + allocate (tprv_rev1(kts:kte)) + allocate (tten1(kts:kte)) + allocate (qvten1(kts:kte)) + allocate (qrten1(kts:kte)) + allocate (qsten1(kts:kte)) + allocate (qgten1(kts:kte)) + allocate (qiten1(kts:kte)) + allocate (niten1(kts:kte)) + allocate (nrten1(kts:kte)) + allocate (ncten1(kts:kte)) + allocate (qcten1(kts:kte)) + end if allocate_extended_diagnostics !+---+ - i_start = its - j_start = jts - i_end = ite - j_end = jte + i_start = its + j_start = jts + i_end = ite + j_end = jte !..For idealized testing by developer. ! if ( (ide-ids+1).gt.4 .and. (jde-jds+1).lt.4 .and. & @@ -1253,66 +1250,66 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! endif ! dt = dt_in - RAINNC(:,:) = 0.0 - SNOWNC(:,:) = 0.0 - ICENC(:,:) = 0.0 - GRAUPELNC(:,:) = 0.0 - pcp_ra(:,:) = 0.0 - pcp_sn(:,:) = 0.0 - pcp_gr(:,:) = 0.0 - pcp_ic(:,:) = 0.0 - pfils(:,:,:) = 0.0 - pflls(:,:,:) = 0.0 - rand_pert_max = 0.0 - ndt = max(nint(dt_in/dt_inner),1) - dt = dt_in/ndt - if(dt_in .le. dt_inner) dt= dt_in + RAINNC(:,:) = 0.0 + SNOWNC(:,:) = 0.0 + ICENC(:,:) = 0.0 + GRAUPELNC(:,:) = 0.0 + pcp_ra(:,:) = 0.0 + pcp_sn(:,:) = 0.0 + pcp_gr(:,:) = 0.0 + pcp_ic(:,:) = 0.0 + pfils(:,:,:) = 0.0 + pflls(:,:,:) = 0.0 + rand_pert_max = 0.0 + ndt = max(nint(dt_in/dt_inner),1) + dt = dt_in/ndt + if(dt_in .le. dt_inner) dt= dt_in !Get the Thompson MP SPP magnitude and standard deviation cutoff, !then compute rand_pert_max - if (rand_perturb_on .ne. 0) then - do k =1,n_var_spp - select case (spp_var_list(k)) - case('mp') - rand_pert_max = spp_prt_list(k)*spp_stddev_cutoff(k) - end select - enddo - endif + if (rand_perturb_on .ne. 0) then + do k =1,n_var_spp + select case (spp_var_list(k)) + case('mp') + rand_pert_max = spp_prt_list(k)*spp_stddev_cutoff(k) + end select + enddo + endif do it = 1, ndt - qc_max = 0. - qr_max = 0. - qs_max = 0. - qi_max = 0. - qg_max = 0 - ni_max = 0. - nr_max = 0. - imax_qc = 0 - imax_qr = 0 - imax_qi = 0 - imax_qs = 0 - imax_qg = 0 - imax_ni = 0 - imax_nr = 0 - jmax_qc = 0 - jmax_qr = 0 - jmax_qi = 0 - jmax_qs = 0 - jmax_qg = 0 - jmax_ni = 0 - jmax_nr = 0 - kmax_qc = 0 - kmax_qr = 0 - kmax_qi = 0 - kmax_qs = 0 - kmax_qg = 0 - kmax_ni = 0 - kmax_nr = 0 - - j_loop: do j = j_start, j_end - i_loop: do i = i_start, i_end + qc_max = 0. + qr_max = 0. + qs_max = 0. + qi_max = 0. + qg_max = 0 + ni_max = 0. + nr_max = 0. + imax_qc = 0 + imax_qr = 0 + imax_qi = 0 + imax_qs = 0 + imax_qg = 0 + imax_ni = 0 + imax_nr = 0 + jmax_qc = 0 + jmax_qr = 0 + jmax_qi = 0 + jmax_qs = 0 + jmax_qg = 0 + jmax_ni = 0 + jmax_nr = 0 + kmax_qc = 0 + kmax_qr = 0 + kmax_qi = 0 + kmax_qs = 0 + kmax_qg = 0 + kmax_ni = 0 + kmax_nr = 0 + + j_loop: do j = j_start, j_end + i_loop: do i = i_start, i_end !+---+-----------------------------------------------------------------+ !..Introduce stochastic parameter perturbations by creating as many scalar rand1, rand2, ... @@ -1327,410 +1324,406 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! For now (22Mar2018), standard deviation should be up to 0.75 and cut-off at 3.0 ! stddev in order to constrain the various perturbations from being too extreme. !+---+-----------------------------------------------------------------+ - rand1 = 0.0 - rand2 = 0.0 - rand3 = 0.0 - if (rand_perturb_on .ne. 0) then - if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) - m = RSHIFT(ABS(rand_perturb_on),1) - if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. - m = RSHIFT(ABS(rand_perturb_on),2) - if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+rand_pert_max) - m = RSHIFT(ABS(rand_perturb_on),3) - endif -!+---+-----------------------------------------------------------------+ - - pptrain = 0. - pptsnow = 0. - pptgraul = 0. - pptice = 0. - RAINNCV(i,j) = 0. - IF ( PRESENT (snowncv) ) THEN - SNOWNCV(i,j) = 0. - ENDIF - IF ( PRESENT (icencv) ) THEN - ICENCV(i,j) = 0. - ENDIF - IF ( PRESENT (graupelncv) ) THEN - GRAUPELNCV(i,j) = 0. - ENDIF - SR(i,j) = 0. - - do k = kts, kte - if (present(tt)) then - t1d(k) = tt(i,k,j) - else - t1d(k) = th(i,k,j)*pii(i,k,j) - end if - p1d(k) = p(i,k,j) - w1d(k) = w(i,k,j) - dz1d(k) = dz(i,k,j) - qv1d(k) = qv(i,k,j) - qc1d(k) = qc(i,k,j) - qi1d(k) = qi(i,k,j) - qr1d(k) = qr(i,k,j) - qs1d(k) = qs(i,k,j) - qg1d(k) = qg(i,k,j) - ni1d(k) = ni(i,k,j) - nr1d(k) = nr(i,k,j) - rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + rand1 = 0.0 + rand2 = 0.0 + rand3 = 0.0 + if (rand_perturb_on .ne. 0) then + if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) + m = RSHIFT(ABS(rand_perturb_on),1) + if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. + m = RSHIFT(ABS(rand_perturb_on),2) + if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+rand_pert_max) + m = RSHIFT(ABS(rand_perturb_on),3) + endif + !+---+-----------------------------------------------------------------+ + + pptrain = 0. + pptsnow = 0. + pptgraul = 0. + pptice = 0. + RAINNCV(i,j) = 0. + IF ( PRESENT (snowncv) ) THEN + SNOWNCV(i,j) = 0. + ENDIF + IF ( PRESENT (icencv) ) THEN + ICENCV(i,j) = 0. + ENDIF + IF ( PRESENT (graupelncv) ) THEN + GRAUPELNCV(i,j) = 0. + ENDIF + SR(i,j) = 0. + + do k = kts, kte + if (present(tt)) then + t1d(k) = tt(i,k,j) + else + t1d(k) = th(i,k,j)*pii(i,k,j) + end if + p1d(k) = p(i,k,j) + w1d(k) = w(i,k,j) + dz1d(k) = dz(i,k,j) + qv1d(k) = qv(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qr1d(k) = qr(i,k,j) + qs1d(k) = qs(i,k,j) + qg1d(k) = qg(i,k,j) + ni1d(k) = ni(i,k,j) + nr1d(k) = nr(i,k,j) + rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) ! These arrays are always allocated and must be initialized !vtsk1(k) = 0. !txrc1(k) = 0. !txri1(k) = 0. - initialize_extended_diagnostics: if (ext_diag) then - prw_vcdc1(k) = 0. - prw_vcde1(k) = 0. - tpri_inu1(k) = 0. - tpri_ide1_d(k) = 0. - tpri_ide1_s(k) = 0. - tprs_ide1(k) = 0. - tprs_sde1_d(k) = 0. - tprs_sde1_s(k) = 0. - tprg_gde1_d(k) = 0. - tprg_gde1_s(k) = 0. - tpri_iha1(k) = 0. - tpri_wfz1(k) = 0. - tpri_rfz1(k) = 0. - tprg_rfz1(k) = 0. - tprs_scw1(k) = 0. - tprg_scw1(k) = 0. - tprg_rcs1(k) = 0. - tprs_rcs1(k) = 0. - tprr_rci1(k) = 0. - tprg_rcg1(k) = 0. - tprw_vcd1_c(k) = 0. - tprw_vcd1_e(k) = 0. - tprr_sml1(k) = 0. - tprr_gml1(k) = 0. - tprr_rcg1(k) = 0. - tprr_rcs1(k) = 0. - tprv_rev1(k) = 0. - tten1(k) = 0. - qvten1(k) = 0. - qrten1(k) = 0. - qsten1(k) = 0. - qgten1(k) = 0. - qiten1(k) = 0. - niten1(k) = 0. - nrten1(k) = 0. - ncten1(k) = 0. - qcten1(k) = 0. - endif initialize_extended_diagnostics - enddo - lsml = lsm(i,j) - if (is_aerosol_aware .or. merra2_aerosol_aware) then - do k = kts, kte - nc1d(k) = nc(i,k,j) - nwfa1d(k) = nwfa(i,k,j) - nifa1d(k) = nifa(i,k,j) - enddo - else - do k = kts, kte - if(lsml == 1) then - nc1d(k) = Nt_c_l/rho(k) + initialize_extended_diagnostics: if (ext_diag) then + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprs_scw1(k) = 0. + tprg_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. + tprv_rev1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. + endif initialize_extended_diagnostics + enddo + + lsml = lsm(i,j) + if (is_aerosol_aware .or. merra2_aerosol_aware) then + do k = kts, kte + nc1d(k) = nc(i,k,j) + nwfa1d(k) = nwfa(i,k,j) + nifa1d(k) = nifa(i,k,j) + enddo else - nc1d(k) = Nt_c_o/rho(k) + do k = kts, kte + if(lsml == 1) then + nc1d(k) = Nt_c_l/rho(k) + else + nc1d(k) = Nt_c_o/rho(k) + endif + nwfa1d(k) = 11.1E6 + nifa1d(k) = naIN1*0.01 + enddo endif - nwfa1d(k) = 11.1E6 - nifa1d(k) = naIN1*0.01 - enddo - endif !> - Call mp_thompson() - call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, & - lsml, pptrain, pptsnow, pptgraul, pptice, & + call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, & + lsml, pptrain, pptsnow, pptgraul, pptice, & #if ( WRF_CHEM == 1 ) - rainprod1d, evapprod1d, & + rainprod1d, evapprod1d, & #endif - rand1, rand2, rand3, & - kts, kte, dt, i, j, ext_diag, & - sedi_semi, decfl, & - !vtsk1, txri1, txrc1, & - prw_vcdc1, prw_vcde1, & - tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & - tprs_sde1_d, tprs_sde1_s, & - tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & - tprg_rcs1, tprs_rcs1, tprr_rci1, & - tprg_rcg1, tprw_vcd1_c, & - tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, & - tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, qcten1, & - pfil1, pfll1) - - pcp_ra(i,j) = pcp_ra(i,j) + pptrain - pcp_sn(i,j) = pcp_sn(i,j) + pptsnow - pcp_gr(i,j) = pcp_gr(i,j) + pptgraul - pcp_ic(i,j) = pcp_ic(i,j) + pptice - RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice - RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice - IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN - ! Add ice to snow if separate ice not present - IF ( .NOT.PRESENT(icencv) .OR. .NOT.PRESENT(icenc) ) THEN - SNOWNCV(i,j) = pptsnow + pptice - SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice - ELSE - SNOWNCV(i,j) = pptsnow - SNOWNC(i,j) = SNOWNC(i,j) + pptsnow - ENDIF - ENDIF - ! Use separate ice if present (as in FV3) - IF ( PRESENT(icencv) .AND. PRESENT(icenc) ) THEN - ICENCV(i,j) = pptice - ICENC(i,j) = ICENC(i,j) + pptice - ENDIF - IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN - GRAUPELNCV(i,j) = pptgraul - GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul - ENDIF - SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) - - + rand1, rand2, rand3, & + kts, kte, dt, i, j, ext_diag, & + sedi_semi, decfl, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, prw_vcde1, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, & + tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & + tprg_rcs1, tprs_rcs1, tprr_rci1, & + tprg_rcg1, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, & + tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, qcten1, & + pfil1, pfll1) + + pcp_ra(i,j) = pcp_ra(i,j) + pptrain + pcp_sn(i,j) = pcp_sn(i,j) + pptsnow + pcp_gr(i,j) = pcp_gr(i,j) + pptgraul + pcp_ic(i,j) = pcp_ic(i,j) + pptice + RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice + RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice + IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN + ! Add ice to snow if separate ice not present + IF ( .NOT.PRESENT(icencv) .OR. .NOT.PRESENT(icenc) ) THEN + SNOWNCV(i,j) = pptsnow + pptice + SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice + ELSE + SNOWNCV(i,j) = pptsnow + SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + ENDIF + ENDIF + ! Use separate ice if present (as in FV3) + IF ( PRESENT(icencv) .AND. PRESENT(icenc) ) THEN + ICENCV(i,j) = pptice + ICENC(i,j) = ICENC(i,j) + pptice + ENDIF + IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN + GRAUPELNCV(i,j) = pptgraul + GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul + ENDIF + SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) !..Reset lowest model level to initial state aerosols (fake sfc source). !.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol !.. number tendency (number per kg per second). - if (is_aerosol_aware) then - if ( PRESENT (aero_ind_fdb) ) then - if ( .not. aero_ind_fdb) then - nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt - nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt - endif - else - nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt - nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt - end if - - do k = kts, kte - nc(i,k,j) = nc1d(k) - nwfa(i,k,j) = nwfa1d(k) - nifa(i,k,j) = nifa1d(k) - enddo - endif + if (is_aerosol_aware) then + if ( PRESENT (aero_ind_fdb) ) then + if ( .not. aero_ind_fdb) then + nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt + nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt + endif + else + nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt + nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt + end if + + do k = kts, kte + nc(i,k,j) = nc1d(k) + nwfa(i,k,j) = nwfa1d(k) + nifa(i,k,j) = nifa1d(k) + enddo + endif - if (merra2_aerosol_aware) then - do k = kts, kte - nc(i,k,j) = nc1d(k) - nwfa(i,k,j) = nwfa1d(k) - nifa(i,k,j) = nifa1d(k) - enddo - endif + if (merra2_aerosol_aware) then + do k = kts, kte + nc(i,k,j) = nc1d(k) + nwfa(i,k,j) = nwfa1d(k) + nifa(i,k,j) = nifa1d(k) + enddo + endif - do k = kts, kte - qv(i,k,j) = qv1d(k) - qc(i,k,j) = qc1d(k) - qi(i,k,j) = qi1d(k) - qr(i,k,j) = qr1d(k) - qs(i,k,j) = qs1d(k) - qg(i,k,j) = qg1d(k) - ni(i,k,j) = ni1d(k) - nr(i,k,j) = nr1d(k) - pfils(i,k,j) = pfils(i,k,j) + pfil1(k) - pflls(i,k,j) = pflls(i,k,j) + pfll1(k) - if (present(tt)) then - tt(i,k,j) = t1d(k) - else - th(i,k,j) = t1d(k)/pii(i,k,j) - end if + do k = kts, kte + qv(i,k,j) = qv1d(k) + qc(i,k,j) = qc1d(k) + qi(i,k,j) = qi1d(k) + qr(i,k,j) = qr1d(k) + qs(i,k,j) = qs1d(k) + qg(i,k,j) = qg1d(k) + ni(i,k,j) = ni1d(k) + nr(i,k,j) = nr1d(k) + pfils(i,k,j) = pfils(i,k,j) + pfil1(k) + pflls(i,k,j) = pflls(i,k,j) + pfll1(k) + if (present(tt)) then + tt(i,k,j) = t1d(k) + else + th(i,k,j) = t1d(k)/pii(i,k,j) + endif #if ( WRF_CHEM == 1 ) rainprod(i,k,j) = rainprod1d(k) evapprod(i,k,j) = evapprod1d(k) #endif - if (qc1d(k) .gt. qc_max) then - imax_qc = i - jmax_qc = j - kmax_qc = k - qc_max = qc1d(k) - elseif (qc1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qc ', qc1d(k), & - ' at i,j,k=', i,j,k - endif - if (qr1d(k) .gt. qr_max) then - imax_qr = i - jmax_qr = j - kmax_qr = k - qr_max = qr1d(k) - elseif (qr1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qr ', qr1d(k), & - ' at i,j,k=', i,j,k - endif - if (nr1d(k) .gt. nr_max) then - imax_nr = i - jmax_nr = j - kmax_nr = k - nr_max = nr1d(k) - elseif (nr1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative nr ', nr1d(k), & - ' at i,j,k=', i,j,k - endif - if (qs1d(k) .gt. qs_max) then - imax_qs = i - jmax_qs = j - kmax_qs = k - qs_max = qs1d(k) - elseif (qs1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qs ', qs1d(k), & - ' at i,j,k=', i,j,k - endif - if (qi1d(k) .gt. qi_max) then - imax_qi = i - jmax_qi = j - kmax_qi = k - qi_max = qi1d(k) - elseif (qi1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qi ', qi1d(k), & - ' at i,j,k=', i,j,k - endif - if (qg1d(k) .gt. qg_max) then - imax_qg = i - jmax_qg = j - kmax_qg = k - qg_max = qg1d(k) - elseif (qg1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qg ', qg1d(k), & - ' at i,j,k=', i,j,k - endif - if (ni1d(k) .gt. ni_max) then - imax_ni = i - jmax_ni = j - kmax_ni = k - ni_max = ni1d(k) - elseif (ni1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative ni ', ni1d(k), & - ' at i,j,k=', i,j,k - endif - if (qv1d(k) .lt. 0.0) then - write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qv ', qv1d(k), & - ' at i,j,k=', i,j,k - if (k.lt.kte-2 .and. k.gt.kts+1) then - write(*,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j) - qv(i,k,j) = MAX(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) - else - qv(i,k,j) = 1.E-7 - endif - endif - enddo - - assign_extended_diagnostics: if (ext_diag) then - do k=kts,kte - !vts1(i,k,j) = vtsk1(k) - !txri(i,k,j) = txri(i,k,j) + txri1(k) - !txrc(i,k,j) = txrc(i,k,j) + txrc1(k) - prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) - prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) - tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) - tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k) - tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) - tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) - tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) - tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) - tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k) - tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) - tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) - tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) - tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) - tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) - tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) - tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) - tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) - tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) - tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) - tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) - tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) - tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) - tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) - tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) - tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) - tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) - tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) - tten3(i,k,j) = tten3(i,k,j) + tten1(k) - qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) - qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) - qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) - qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) - qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) - niten3(i,k,j) = niten3(i,k,j) + niten1(k) - nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) - ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) - qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) + if (qc1d(k) .gt. qc_max) then + imax_qc = i + jmax_qc = j + kmax_qc = k + qc_max = qc1d(k) + elseif (qc1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qc ', qc1d(k), & + ' at i,j,k=', i,j,k + endif + if (qr1d(k) .gt. qr_max) then + imax_qr = i + jmax_qr = j + kmax_qr = k + qr_max = qr1d(k) + elseif (qr1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qr ', qr1d(k), & + ' at i,j,k=', i,j,k + endif + if (nr1d(k) .gt. nr_max) then + imax_nr = i + jmax_nr = j + kmax_nr = k + nr_max = nr1d(k) + elseif (nr1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative nr ', nr1d(k), & + ' at i,j,k=', i,j,k + endif + if (qs1d(k) .gt. qs_max) then + imax_qs = i + jmax_qs = j + kmax_qs = k + qs_max = qs1d(k) + elseif (qs1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qs ', qs1d(k), & + ' at i,j,k=', i,j,k + endif + if (qi1d(k) .gt. qi_max) then + imax_qi = i + jmax_qi = j + kmax_qi = k + qi_max = qi1d(k) + elseif (qi1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qi ', qi1d(k), & + ' at i,j,k=', i,j,k + endif + if (qg1d(k) .gt. qg_max) then + imax_qg = i + jmax_qg = j + kmax_qg = k + qg_max = qg1d(k) + elseif (qg1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qg ', qg1d(k), & + ' at i,j,k=', i,j,k + endif + if (ni1d(k) .gt. ni_max) then + imax_ni = i + jmax_ni = j + kmax_ni = k + ni_max = ni1d(k) + elseif (ni1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative ni ', ni1d(k), & + ' at i,j,k=', i,j,k + endif + if (qv1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qv ', qv1d(k), & + ' at i,j,k=', i,j,k + if (k.lt.kte-2 .and. k.gt.kts+1) then + write(*,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j) + qv(i,k,j) = MAX(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) + else + qv(i,k,j) = 1.E-7 + endif + endif + enddo - enddo - endif assign_extended_diagnostics - - if (ndt>1 .and. it==ndt) then - - SR(i,j) = (pcp_sn(i,j) + pcp_gr(i,j) + pcp_ic(i,j))/(RAINNC(i,j)+1.e-12) - RAINNCV(i,j) = RAINNC(i,j) - IF ( PRESENT (snowncv) ) THEN - SNOWNCV(i,j) = SNOWNC(i,j) - ENDIF - IF ( PRESENT (icencv) ) THEN - ICENCV(i,j) = ICENC(i,j) - ENDIF - IF ( PRESENT (graupelncv) ) THEN - GRAUPELNCV(i,j) = GRAUPELNC(i,j) - ENDIF - endif + assign_extended_diagnostics: if (ext_diag) then + do k=kts,kte + !vts1(i,k,j) = vtsk1(k) + !txri(i,k,j) = txri(i,k,j) + txri1(k) + !txrc(i,k,j) = txrc(i,k,j) + txrc1(k) + prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) + prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) + tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) + tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k) + tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) + tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) + tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) + tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) + tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k) + tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) + tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) + tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) + tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) + tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) + tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) + tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) + tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) + tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) + tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) + tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) + tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) + tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) + tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) + tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) + tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) + tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) + tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) + tten3(i,k,j) = tten3(i,k,j) + tten1(k) + qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) + qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) + qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) + qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) + qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) + niten3(i,k,j) = niten3(i,k,j) + niten1(k) + nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) + ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) + qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) + enddo + endif assign_extended_diagnostics + + if (ndt>1 .and. it==ndt) then + SR(i,j) = (pcp_sn(i,j) + pcp_gr(i,j) + pcp_ic(i,j))/(RAINNC(i,j)+1.e-12) + RAINNCV(i,j) = RAINNC(i,j) + IF ( PRESENT (snowncv) ) THEN + SNOWNCV(i,j) = SNOWNC(i,j) + ENDIF + IF ( PRESENT (icencv) ) THEN + ICENCV(i,j) = ICENC(i,j) + ENDIF + IF ( PRESENT (graupelncv) ) THEN + GRAUPELNCV(i,j) = GRAUPELNC(i,j) + ENDIF + endif ! Diagnostic calculations only for last step ! if Thompson MP is called multiple times - last_step_only: IF ((ndt>1 .and. it==ndt) .or. & - (nsteps>1 .and. istep==nsteps) .or. & - (nsteps==1 .and. ndt==1)) THEN + last_step_only: IF ((ndt>1 .and. it==ndt) .or. & + (nsteps>1 .and. istep==nsteps) .or. & + (nsteps==1 .and. ndt==1)) THEN - max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d) + max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d) !> - Call calc_refl10cm() - diagflag_present: IF ( PRESENT (diagflag) ) THEN - if (diagflag .and. do_radar_ref == 1) then -! - ! Only set melti to true at the output times - if (fullradar_diag) then - melti=.true. - else - melti=.false. - endif -! - if (present(vt_dbz_wt)) then - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, i, j, & - melti, vt_dbz_wt(i,:,j), & - first_time_step) - else - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, i, j, & - melti) - end if - do k = kts, kte - refl_10cm(i,k,j) = MAX(-35., dBZ(k)) - enddo - endif - ENDIF diagflag_present - - IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN - do k = kts, kte - re_qc1d(k) = re_qc_min - re_qi1d(k) = re_qi_min - re_qs1d(k) = re_qs_min - enddo -!> - Call calc_effectrad() - call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & - re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte) - do k = kts, kte - re_cloud(i,k,j) = MAX(re_qc_min, MIN(re_qc1d(k), re_qc_max)) - re_ice(i,k,j) = MAX(re_qi_min, MIN(re_qi1d(k), re_qi_max)) - re_snow(i,k,j) = MAX(re_qs_min, MIN(re_qs1d(k), re_qs_max)) - enddo - ENDIF - ENDIF last_step_only - - enddo i_loop - enddo j_loop + diagflag_present: IF ( PRESENT (diagflag) ) THEN + if (diagflag .and. do_radar_ref == 1) then + ! + ! Only set melti to true at the output times + if (fullradar_diag) then + melti=.true. + else + melti=.false. + endif + ! + if (present(vt_dbz_wt)) then + call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, i, j, & + melti, vt_dbz_wt(i,:,j), & + first_time_step) + else + call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, i, j, & + melti) + endif + do k = kts, kte + refl_10cm(i,k,j) = MAX(-35., dBZ(k)) + enddo + endif + ENDIF diagflag_present + + IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN + do k = kts, kte + re_qc1d(k) = re_qc_min + re_qi1d(k) = re_qi_min + re_qs1d(k) = re_qs_min + enddo + !> - Call calc_effectrad() + call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & + re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte) + do k = kts, kte + re_cloud(i,k,j) = MAX(re_qc_min, MIN(re_qc1d(k), re_qc_max)) + re_ice(i,k,j) = MAX(re_qi_min, MIN(re_qi1d(k), re_qi_max)) + re_snow(i,k,j) = MAX(re_qs_min, MIN(re_qs1d(k), re_qs_max)) + enddo + ENDIF + ENDIF last_step_only + enddo i_loop + enddo j_loop ! DEBUG - GT ! write(*,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & @@ -1797,13 +1790,13 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & deallocate (qcten1) end if deallocate_extended_diagnostics - END SUBROUTINE mp_gt_driver + end subroutine mp_gt_driver !> @} !>\ingroup aathompson - SUBROUTINE thompson_finalize() + subroutine thompson_finalize() - IMPLICIT NONE + implicit none if (ALLOCATED(tcg_racg)) DEALLOCATE(tcg_racg) if (ALLOCATED(tmr_racg)) DEALLOCATE(tmr_racg) @@ -1846,7 +1839,7 @@ SUBROUTINE thompson_finalize() if (ALLOCATED(tnccn_act)) DEALLOCATE(tnccn_act) - END SUBROUTINE thompson_finalize + end subroutine thompson_finalize !+---+-----------------------------------------------------------------+ !ctrlL @@ -1861,53 +1854,54 @@ END SUBROUTINE thompson_finalize !! Thompson et al. (2004, 2008)\cite Thompson_2004 \cite Thompson_2008. !>\section gen_mp_thompson mp_thompson General Algorithm !> @{ - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & - lsml, pptrain, pptsnow, pptgraul, pptice, & + subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & + lsml, pptrain, pptsnow, pptgraul, pptice, & #if ( WRF_CHEM == 1 ) - rainprod, evapprod, & + rainprod, evapprod, & #endif - rand1, rand2, rand3, & - kts, kte, dt, ii, jj, & - ! Extended diagnostics, most arrays only - ! allocated if ext_diag flag is .true. - ext_diag, & - sedi_semi, decfl, & - !vtsk1, txri1, txrc1, & - prw_vcdc1, prw_vcde1, & - tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & - tprs_sde1_d, tprs_sde1_s, & - tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & - tprg_rcs1, tprs_rcs1, tprr_rci1, & - tprg_rcg1, tprw_vcd1_c, & - tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, & - tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, qcten1, & - pfil1, pfll1) + rand1, rand2, rand3, & + kts, kte, dt, ii, jj, & + ! Extended diagnostics, most arrays only + ! allocated if ext_diag flag is .true. + ext_diag, & + sedi_semi, decfl, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, prw_vcde1, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, & + tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & + tprg_rcs1, tprs_rcs1, tprr_rci1, & + tprg_rcg1, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, & + tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, qcten1, & + pfil1, pfll1) #ifdef MPI - use mpi + use mpi #endif + implicit none !..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(INOUT):: & + integer, intent(in):: kts, kte, ii, jj + real(kind_phys), dimension(kts:kte), intent(inout) :: & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d - REAL, DIMENSION(kts:kte), INTENT(OUT):: pfil1, pfll1 - REAL, DIMENSION(kts:kte), INTENT(IN):: p1d, w1d, dzq - REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice - REAL, INTENT(IN):: dt - INTEGER, INTENT(IN):: lsml - REAL, INTENT(IN):: rand1, rand2, rand3 + real(kind_phys), dimension(kts:kte), intent(out) :: pfil1, pfll1 + real(kind_phys), dimension(kts:kte), intent(in) :: p1d, w1d, dzq + real(kind_phys), intent(inout) :: pptrain, pptsnow, pptgraul, pptice + real(kind_phys), intent(in) :: dt + integer, intent(in) :: lsml + real(kind_phys), intent(in) :: rand1, rand2, rand3 ! Extended diagnostics, most arrays only allocated if ext_diag is true - LOGICAL, INTENT(IN) :: ext_diag - LOGICAL, INTENT(IN) :: sedi_semi - INTEGER, INTENT(IN) :: decfl - REAL, DIMENSION(:), INTENT(OUT):: & + logical, intent(in) :: ext_diag + logical, intent(in) :: sedi_semi + integer, intent(in) :: decfl + real(kind_phys), dimension(:), intent(out) :: & !vtsk1, txri1, txrc1, & prw_vcdc1, & prw_vcde1, tpri_inu1, tpri_ide1_d, & @@ -1924,98 +1918,98 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nrten1, ncten1, qcten1 #if ( WRF_CHEM == 1 ) - REAL, DIMENSION(kts:kte), INTENT(INOUT):: & + real(kind_phys), dimension(kts:kte), intent(inout) :: & rainprod, evapprod #endif !..Local variables - REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & + real(kind_phys), dimension(kts:kte) :: tten, qvten, qcten, qiten, & qrten, qsten, qgten, niten, nrten, ncten, nwfaten, nifaten - DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd + real(kind_dbl_prec), dimension(kts:kte) :: prw_vcd - DOUBLE PRECISION, DIMENSION(kts:kte):: pnc_wcd, pnc_wau, pnc_rcw, & + real(kind_dbl_prec), dimension(kts:kte) :: pnc_wcd, pnc_wau, pnc_rcw, & pnc_scw, pnc_gcw - DOUBLE PRECISION, DIMENSION(kts:kte):: pna_rca, pna_sca, pna_gca, & + real(kind_dbl_prec), dimension(kts:kte) :: pna_rca, pna_sca, pna_gca, & pnd_rcd, pnd_scd, pnd_gcd - DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, & + real(kind_dbl_prec), dimension(kts:kte) :: prr_wau, prr_rcw, prr_rcs, & prr_rcg, prr_sml, prr_gml, & prr_rci, prv_rev, & pnr_wau, pnr_rcs, pnr_rcg, & pnr_rci, pnr_sml, pnr_gml, & pnr_rev, pnr_rcr, pnr_rfz - DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, & + real(kind_dbl_prec), dimension(kts:kte) :: pri_inu, pni_inu, pri_ihm, & pni_ihm, pri_wfz, pni_wfz, & pri_rfz, pni_rfz, pri_ide, & pni_ide, pri_rci, pni_rci, & pni_sci, pni_iau, pri_iha, pni_iha - DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, & + real(kind_dbl_prec), dimension(kts:kte) :: prs_iau, prs_sci, prs_rcs, & prs_scw, prs_sde, prs_ihm, & prs_ide - DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, & + real(kind_dbl_prec), dimension(kts:kte) :: prg_scw, prg_rfz, prg_gde, & prg_gcw, prg_rci, prg_rcs, & prg_rcg, prg_ihm - DOUBLE PRECISION, PARAMETER:: zeroD0 = 0.0d0 - REAL :: dtcfl,rainsfc,graulsfc - INTEGER :: niter - - REAL, DIMENSION(kts:kte):: temp, pres, qv, pfll, pfil, pdummy - REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni, nr, nc, nwfa, nifa - REAL, DIMENSION(kts:kte):: rr_tmp, nr_tmp, rg_tmp - REAL, DIMENSION(kts:kte):: rho, rhof, rhof2 - REAL, DIMENSION(kts:kte):: qvs, qvsi, delQvs - REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati - REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, & + real(kind_dbl_prec), parameter:: zeroD0 = 0.0d0 + real(kind_phys) :: dtcfl, rainsfc, graulsfc + integer :: niter + + real(kind_phys), dimension(kts:kte) :: temp, pres, qv, pfll, pfil, pdummy + real(kind_phys), dimension(kts:kte) :: rc, ri, rr, rs, rg, ni, nr, nc, nwfa, nifa + real(kind_phys), dimension(kts:kte) :: rr_tmp, nr_tmp, rg_tmp + real(kind_phys), dimension(kts:kte) :: rho, rhof, rhof2 + real(kind_phys), dimension(kts:kte) :: qvs, qvsi, delQvs + real(kind_phys), dimension(kts:kte) :: satw, sati, ssatw, ssati + real(kind_phys), dimension(kts:kte) :: diffu, visco, vsc2, & tcond, lvap, ocp, lvt2 - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g - REAL, DIMENSION(kts:kte):: mvd_r, mvd_c - REAL, DIMENSION(kts:kte):: smob, smo2, smo1, smo0, & + real(kind_dbl_prec), dimension(kts:kte) :: ilamr, ilamg, N0_r, N0_g + real(kind_phys), dimension(kts:kte) :: mvd_r, mvd_c + real(kind_phys), dimension(kts:kte) :: smob, smo2, smo1, smo0, & smoc, smod, smoe, smof - REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n,sed_c - - REAL:: rgvm, delta_tp, orho, lfus2, orhodt - REAL, DIMENSION(5):: onstep - DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg - DOUBLE PRECISION:: lami, ilami, ilamc - REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m - DOUBLE PRECISION:: Dr_star, Dc_star - REAL:: zeta1, zeta, taud, tau - REAL:: stoke_r, stoke_s, stoke_g, stoke_i - REAL:: vti, vtr, vts, vtg, vtc - REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk, & + real(kind_phys), dimension(kts:kte) :: sed_r, sed_s, sed_g, sed_i, sed_n,sed_c + + real(kind_phys) :: rgvm, delta_tp, orho, lfus2, orhodt + real(kind_phys), dimension(5):: onstep + real(kind_dbl_prec) :: N0_exp, N0_min, lam_exp, lamc, lamr, lamg + real(kind_dbl_prec) :: lami, ilami, ilamc + real(kind_phys) :: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m + real(kind_dbl_prec) :: Dr_star, Dc_star + real(kind_phys) :: zeta1, zeta, taud, tau + real(kind_phys) :: stoke_r, stoke_s, stoke_g, stoke_i + real(kind_phys) :: vti, vtr, vts, vtg, vtc + real(kind_phys), dimension(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk, & vtck, vtnck - REAL, DIMENSION(kts:kte):: vts_boost - REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow - REAL:: a_, b_, loga_, A1, A2, tf - REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat - REAL:: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr - REAL:: xsat, rate_max, sump, ratio - REAL:: clap, fcd, dfcd - REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl - REAL:: r_frac, g_frac - REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr - REAL:: Ef_ra, Ef_sa, Ef_ga - REAL:: dtsave, odts, odt, odzq, hgt_agl, SR - REAL:: xslw1, ygra1, zans1, eva_factor - REAL:: av_i - INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq - INTEGER, DIMENSION(5):: ksed1 - INTEGER:: nir, nis, nig, nii, nic, niin - INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, & + real(kind_phys), dimension(kts:kte):: vts_boost + real(kind_phys) :: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow + real(kind_phys) :: a_, b_, loga_, A1, A2, tf + real(kind_phys) :: tempc, tc0, r_mvd1, r_mvd2, xkrat + real(kind_phys) :: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr + real(kind_phys) :: xsat, rate_max, sump, ratio + real(kind_phys) :: clap, fcd, dfcd + real(kind_phys) :: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl + real(kind_phys) :: r_frac, g_frac + real(kind_phys) :: Ef_rw, Ef_sw, Ef_gw, Ef_rr + real(kind_phys) :: Ef_ra, Ef_sa, Ef_ga + real(kind_phys) :: dtsave, odts, odt, odzq, hgt_agl, SR + real(kind_phys) :: xslw1, ygra1, zans1, eva_factor + real(kind_phys) av_i + integer :: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq + integer, dimension(5) :: ksed1 + integer :: nir, nis, nig, nii, nic, niin + integer :: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, & idx_i1, idx_i, idx_c, idx, idx_d, idx_n, idx_in - LOGICAL:: no_micro - LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg - LOGICAL:: debug_flag - INTEGER:: nu_c + logical :: no_micro + logical, dimension(kts:kte) :: L_qc, L_qi, L_qr, L_qs, L_qg + logical :: debug_flag + integer :: nu_c !+---+ @@ -2220,27 +2214,27 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) L_qc(k) = .true. if (nc(k).gt.10000.E6) then - nu_c = 2 + nu_c = 2 elseif (nc(k).lt.100.) then - nu_c = 15 + nu_c = 15 else - nu_c = NINT(1000.E6/nc(k)) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + nu_c = NINT(1000.E6/nc(k)) + 2 + nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) endif lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr xDc = (bm_r + nu_c + 1.) / lamc if (xDc.lt. D0c) then - lamc = cce(2,nu_c)/D0c + lamc = cce(2,nu_c)/D0c elseif (xDc.gt. D0r*2.) then - lamc = cce(2,nu_c)/(D0r*2.) + lamc = cce(2,nu_c)/(D0r*2.) endif nc(k) = MIN( DBLE(Nt_c_max), ccg(1,nu_c)*ocg2(nu_c)*rc(k) & / am_r*lamc**bm_r) if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then if (lsml == 1) then - nc(k) = Nt_c_l + nc(k) = Nt_c_l else - nc(k) = Nt_c_o + nc(k) = Nt_c_o endif endif else @@ -2264,11 +2258,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then - lami = cie(2)/5.E-6 - ni(k) = MIN(4999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + lami = cie(2)/5.E-6 + ni(k) = MIN(4999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i + lami = cie(2)/300.E-6 + ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i endif else qi1d(k) = 0.0 @@ -2382,94 +2376,93 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Calculate y-intercept, slope, and useful moments for snow. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then - do k = kts, kte - if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) - smob(k) = rs(k)*oams + do k = kts, kte + if (.not. L_qs(k)) CYCLE + tc0 = MIN(-0.1, temp(k)-273.15) + smob(k) = rs(k)*oams !> - All other moments based on reference, 2nd moment. If bm_s.ne.2, !! then we must compute actual 2nd moment and use as reference. - if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then - smo2(k) = smob(k) - else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - + sb(10)*bm_s*bm_s*bm_s - smo2(k) = (smob(k)/a_)**(1./b_) - endif + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2(k) = smob(k) + else + loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & + + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & + + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & + + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & + + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & + + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & + + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & + + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & + + sb(10)*bm_s*bm_s*bm_s + smo2(k) = (smob(k)/a_)**(1./b_) + endif !> - Calculate 0th moment. Represents snow number concentration. - loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0 - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0 - smo0(k) = a_ * smo2(k)**b_ + loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0 + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0 + smo0(k) = a_ * smo2(k)**b_ !> - Calculate 1st moment. Useful for depositional growth and melting. - loga_ = sa(1) + sa(2)*tc0 + sa(3) & - + sa(4)*tc0 + sa(5)*tc0*tc0 & - + sa(6) + sa(7)*tc0*tc0 & - + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 & - + sa(10) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 & - + sb(5)*tc0*tc0 + sb(6) & - + sb(7)*tc0*tc0 + sb(8)*tc0 & - + sb(9)*tc0*tc0*tc0 + sb(10) - smo1(k) = a_ * smo2(k)**b_ + loga_ = sa(1) + sa(2)*tc0 + sa(3) & + + sa(4)*tc0 + sa(5)*tc0*tc0 & + + sa(6) + sa(7)*tc0*tc0 & + + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 & + + sa(10) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 & + + sb(5)*tc0*tc0 + sb(6) & + + sb(7)*tc0*tc0 + sb(8)*tc0 & + + sb(9)*tc0*tc0*tc0 + sb(10) + smo1(k) = a_ * smo2(k)**b_ !> - Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) - smoc(k) = a_ * smo2(k)**b_ + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & + + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & + + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & + + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & + + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & + + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + smoc(k) = a_ * smo2(k)**b_ !> - Calculate bv_s+2 (th) moment. Useful for riming. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) & - + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 & - + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) & - + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(13)*cse(13)*cse(13) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) & - + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) & - + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13) - smoe(k) = a_ * smo2(k)**b_ + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) & + + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 & + + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) & + + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(13)*cse(13)*cse(13) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) & + + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) & + + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13) + smoe(k) = a_ * smo2(k)**b_ !> - Calculate 1+(bv_s+1)/2 (th) moment. Useful for depositional growth. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) & - + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 & - + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) & - + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(16)*cse(16)*cse(16) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) & - + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) & - + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16) - smof(k) = a_ * smo2(k)**b_ - - enddo + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) & + + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 & + + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) & + + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(16)*cse(16)*cse(16) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) & + + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) & + + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16) + smof(k) = a_ * smo2(k)**b_ + enddo !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -2491,395 +2484,378 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Rain self-collection follows Seifert, 1994 and drop break-up !! follows Verlinde and Cotton, 1993. Updated after Saleeby et al 2022. RAIN2M if (L_qr(k) .and. mvd_r(k).gt. D0r) then - Ef_rr = MAX(-0.1, 1.0 - EXP(2300.0*(mvd_r(k)-1950.0E-6))) - pnr_rcr(k) = Ef_rr * 2.0*nr(k)*rr(k) + Ef_rr = MAX(-0.1, 1.0 - EXP(2300.0*(mvd_r(k)-1950.0E-6))) + pnr_rcr(k) = Ef_rr * 2.0*nr(k)*rr(k) endif if (L_qc(k)) then - if (nc(k).gt.10000.E6) then - nu_c = 2 - elseif (nc(k).lt.100.) then - nu_c = 15 - else - nu_c = NINT(1000.E6/nc(k)) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) - endif - xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*nc(k)))**obmr) * 1.E6) - lamc = (nc(k)*am_r* ccg(2,nu_c) * ocg1(nu_c) / rc(k))**obmr - mvd_c(k) = (3.0+nu_c+0.672) / lamc - mvd_c(k) = MAX(D0c, MIN(mvd_c(k), D0r)) + if (nc(k).gt.10000.E6) then + nu_c = 2 + elseif (nc(k).lt.100.) then + nu_c = 15 + else + nu_c = NINT(1000.E6/nc(k)) + 2 + nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + endif + xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*nc(k)))**obmr) * 1.E6) + lamc = (nc(k)*am_r* ccg(2,nu_c) * ocg1(nu_c) / rc(k))**obmr + mvd_c(k) = (3.0+nu_c+0.672) / lamc + mvd_c(k) = MAX(D0c, MIN(mvd_c(k), D0r)) endif !> - Autoconversion follows Berry & Reinhardt (1974) with characteristic !! diameters correctly computed from gamma distrib of cloud droplets. if (rc(k).gt. 0.01e-3) then - Dc_g = ((ccg(3,nu_c)*ocg2(nu_c))**obmr / lamc) * 1.E6 - Dc_b = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) & - **(1./6.) - zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) & + Dc_g = ((ccg(3,nu_c)*ocg2(nu_c))**obmr / lamc) * 1.E6 + Dc_b = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) & + **(1./6.) + zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) & + abs(6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4)) - zeta = 0.027*rc(k)*zeta1 - taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1 - tau = 3.72/(rc(k)*taud) - prr_wau(k) = zeta/tau - prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) - pnr_wau(k) = prr_wau(k) / (am_r*nu_c*10.*D0r*D0r*D0r) ! RAIN2M - pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k) & + zeta = 0.027*rc(k)*zeta1 + taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1 + tau = 3.72/(rc(k)*taud) + prr_wau(k) = zeta/tau + prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) + pnr_wau(k) = prr_wau(k) / (am_r*nu_c*10.*D0r*D0r*D0r) ! RAIN2M + pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k) & / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) ! Qc2M endif !> - Rain collecting cloud water. In CE, assume Dc< - Rain collecting aerosols, wet scavenging. if (L_qr(k) .and. mvd_r(k).gt. D0r) then - Ef_ra = Eff_aero(mvd_r(k),0.04E-6,visco(k),rho(k),temp(k),'r') - lamr = 1./ilamr(k) - pna_rca(k) = rhof(k)*t1_qr_qc*Ef_ra*nwfa(k)*N0_r(k) & - *((lamr+fv_r)**(-cre(9))) - pna_rca(k) = MIN(DBLE(nwfa(k)*odts), pna_rca(k)) - - Ef_ra = Eff_aero(mvd_r(k),0.8E-6,visco(k),rho(k),temp(k),'r') - pnd_rcd(k) = rhof(k)*t1_qr_qc*Ef_ra*nifa(k)*N0_r(k) & - *((lamr+fv_r)**(-cre(9))) - pnd_rcd(k) = MIN(DBLE(nifa(k)*odts), pnd_rcd(k)) - endif + Ef_ra = Eff_aero(mvd_r(k),0.04E-6,visco(k),rho(k),temp(k),'r') + lamr = 1./ilamr(k) + pna_rca(k) = rhof(k)*t1_qr_qc*Ef_ra*nwfa(k)*N0_r(k) & + *((lamr+fv_r)**(-cre(9))) + pna_rca(k) = MIN(DBLE(nwfa(k)*odts), pna_rca(k)) + Ef_ra = Eff_aero(mvd_r(k),0.8E-6,visco(k),rho(k),temp(k),'r') + pnd_rcd(k) = rhof(k)*t1_qr_qc*Ef_ra*nifa(k)*N0_r(k) & + *((lamr+fv_r)**(-cre(9))) + pnd_rcd(k) = MIN(DBLE(nifa(k)*odts), pnd_rcd(k)) + endif + enddo !+---+-----------------------------------------------------------------+ !> - Compute all frozen hydrometeor species' process terms. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then - do k = kts, kte - vts_boost(k) = 1.0 - xDs = 0.0 - if (L_qs(k)) xDs = smoc(k) / smob(k) + do k = kts, kte + vts_boost(k) = 1.0 + xDs = 0.0 + if (L_qs(k)) xDs = smoc(k) / smob(k) !> - Temperature lookup table indexes. - tempc = temp(k) - 273.15 - idx_tc = MAX(1, MIN(NINT(-tempc), 45) ) - idx_t = INT( (tempc-2.5)/5. ) - 1 - idx_t = MAX(1, -idx_t) - idx_t = MIN(idx_t, ntb_t) - IT = MAX(1, MIN(NINT(-tempc), 31) ) + tempc = temp(k) - 273.15 + idx_tc = MAX(1, MIN(NINT(-tempc), 45) ) + idx_t = INT( (tempc-2.5)/5. ) - 1 + idx_t = MAX(1, -idx_t) + idx_t = MIN(idx_t, ntb_t) + IT = MAX(1, MIN(NINT(-tempc), 31) ) !> - Cloud water lookup table index. - if (rc(k).gt. r_c(1)) then - nic = NINT(ALOG10(rc(k))) - do nn = nic-1, nic+1 - n = nn - if ( (rc(k)/10.**nn).ge.1.0 .and. & - (rc(k)/10.**nn).lt.10.0) goto 141 - enddo - 141 continue - idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) - idx_c = MAX(1, MIN(idx_c, ntb_c)) - else - idx_c = 1 - endif + if (rc(k).gt. r_c(1)) then + nic = NINT(ALOG10(rc(k))) + do_loop_rc: do nn = nic-1, nic+1 + n = nn + if ( (rc(k)/10.**nn).ge.1.0 .and. (rc(k)/10.**nn).lt.10.0 ) exit do_loop_rc + enddo do_loop_rc + idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) + idx_c = MAX(1, MIN(idx_c, ntb_c)) + else + idx_c = 1 + endif !> - Cloud droplet number lookup table index. - idx_n = NINT(1.0 + FLOAT(nbc) * DLOG(nc(k)/t_Nc(1)) / nic1) - idx_n = MAX(1, MIN(idx_n, nbc)) + idx_n = NINT(1.0 + FLOAT(nbc) * DLOG(nc(k)/t_Nc(1)) / nic1) + idx_n = MAX(1, MIN(idx_n, nbc)) !> - Cloud ice lookup table indexes. - if (ri(k).gt. r_i(1)) then - nii = NINT(ALOG10(ri(k))) - do nn = nii-1, nii+1 - n = nn - if ( (ri(k)/10.**nn).ge.1.0 .and. & - (ri(k)/10.**nn).lt.10.0) goto 142 - enddo - 142 continue - idx_i = INT(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2) - idx_i = MAX(1, MIN(idx_i, ntb_i)) - else - idx_i = 1 - endif + if (ri(k).gt. r_i(1)) then + nii = NINT(ALOG10(ri(k))) + do_loop_ri: do nn = nii-1, nii+1 + n = nn + if ( (ri(k)/10.**nn).ge.1.0 .and. (ri(k)/10.**nn).lt.10.0 ) exit do_loop_ri + enddo do_loop_ri + idx_i = INT(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2) + idx_i = MAX(1, MIN(idx_i, ntb_i)) + else + idx_i = 1 + endif - if (ni(k).gt. Nt_i(1)) then - nii = NINT(ALOG10(ni(k))) - do nn = nii-1, nii+1 - n = nn - if ( (ni(k)/10.**nn).ge.1.0 .and. & - (ni(k)/10.**nn).lt.10.0) goto 143 - enddo - 143 continue - idx_i1 = INT(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3) - idx_i1 = MAX(1, MIN(idx_i1, ntb_i1)) - else - idx_i1 = 1 - endif + if (ni(k).gt. Nt_i(1)) then + nii = NINT(ALOG10(ni(k))) + do_loop_ni: do nn = nii-1, nii+1 + n = nn + if ( (ni(k)/10.**nn).ge.1.0 .and. (ni(k)/10.**nn).lt.10.0 ) exit do_loop_ni + enddo do_loop_ni + idx_i1 = INT(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3) + idx_i1 = MAX(1, MIN(idx_i1, ntb_i1)) + else + idx_i1 = 1 + endif !> - Rain lookup table indexes. - if (rr(k).gt. r_r(1)) then - nir = NINT(ALOG10(rr(k))) - do nn = nir-1, nir+1 - n = nn - if ( (rr(k)/10.**nn).ge.1.0 .and. & - (rr(k)/10.**nn).lt.10.0) goto 144 - enddo - 144 continue - idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) - idx_r = MAX(1, MIN(idx_r, ntb_r)) - - lamr = 1./ilamr(k) - lam_exp = lamr * (crg(3)*org2*org1)**bm_r - N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) - nir = NINT(DLOG10(N0_exp)) - do nn = nir-1, nir+1 - n = nn - if ( (N0_exp/10.**nn).ge.1.0 .and. & - (N0_exp/10.**nn).lt.10.0) goto 145 - enddo - 145 continue - idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) - idx_r1 = MAX(1, MIN(idx_r1, ntb_r1)) - else - idx_r = 1 - idx_r1 = ntb_r1 - endif + if (rr(k).gt. r_r(1)) then + nir = NINT(ALOG10(rr(k))) + do_loop_rr: do nn = nir-1, nir+1 + n = nn + if ( (rr(k)/10.**nn).ge.1.0 .and. (rr(k)/10.**nn).lt.10.0 ) exit do_loop_rr + enddo do_loop_rr + idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) + idx_r = MAX(1, MIN(idx_r, ntb_r)) + + lamr = 1./ilamr(k) + lam_exp = lamr * (crg(3)*org2*org1)**bm_r + N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) + nir = NINT(DLOG10(N0_exp)) + do_loop_nr: do nn = nir-1, nir+1 + n = nn + if ( (N0_exp/10.**nn).ge.1.0 .and. (N0_exp/10.**nn).lt.10.0 ) exit do_loop_nr + enddo do_loop_nr + idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) + idx_r1 = MAX(1, MIN(idx_r1, ntb_r1)) + else + idx_r = 1 + idx_r1 = ntb_r1 + endif !> - Snow lookup table index. - if (rs(k).gt. r_s(1)) then - nis = NINT(ALOG10(rs(k))) - do nn = nis-1, nis+1 - n = nn - if ( (rs(k)/10.**nn).ge.1.0 .and. & - (rs(k)/10.**nn).lt.10.0) goto 146 - enddo - 146 continue - idx_s = INT(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2) - idx_s = MAX(1, MIN(idx_s, ntb_s)) - else - idx_s = 1 - endif + if (rs(k).gt. r_s(1)) then + nis = NINT(ALOG10(rs(k))) + do_loop_rs: do nn = nis-1, nis+1 + n = nn + if ( (rs(k)/10.**nn).ge.1.0 .and. (rs(k)/10.**nn).lt.10.0 ) exit do_loop_rs + enddo do_loop_rs + idx_s = INT(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2) + idx_s = MAX(1, MIN(idx_s, ntb_s)) + else + idx_s = 1 + endif !> - Graupel lookup table index. - if (rg(k).gt. r_g(1)) then - nig = NINT(ALOG10(rg(k))) - do nn = nig-1, nig+1 - n = nn - if ( (rg(k)/10.**nn).ge.1.0 .and. & - (rg(k)/10.**nn).lt.10.0) goto 147 - enddo - 147 continue - idx_g = INT(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2) - idx_g = MAX(1, MIN(idx_g, ntb_g)) - - lamg = 1./ilamg(k) - lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g - N0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1) - nig = NINT(DLOG10(N0_exp)) - do nn = nig-1, nig+1 - n = nn - if ( (N0_exp/10.**nn).ge.1.0 .and. & - (N0_exp/10.**nn).lt.10.0) goto 148 - enddo - 148 continue - idx_g1 = INT(N0_exp/10.**n) + 10*(n-nig3) - (n-nig3) - idx_g1 = MAX(1, MIN(idx_g1, ntb_g1)) - else - idx_g = 1 - idx_g1 = ntb_g1 - endif + if (rg(k).gt. r_g(1)) then + nig = NINT(ALOG10(rg(k))) + do_loop_rg: do nn = nig-1, nig+1 + n = nn + if ( (rg(k)/10.**nn).ge.1.0 .and. (rg(k)/10.**nn).lt.10.0 ) exit do_loop_rg + enddo do_loop_rg + idx_g = INT(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2) + idx_g = MAX(1, MIN(idx_g, ntb_g)) + + lamg = 1./ilamg(k) + lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g + N0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1) + nig = NINT(DLOG10(N0_exp)) + do_loop_ng: do nn = nig-1, nig+1 + n = nn + if ( (N0_exp/10.**nn).ge.1.0 .and. (N0_exp/10.**nn).lt.10.0 ) exit do_loop_ng + enddo do_loop_ng + idx_g1 = INT(N0_exp/10.**n) + 10*(n-nig3) - (n-nig3) + idx_g1 = MAX(1, MIN(idx_g1, ntb_g1)) + else + idx_g = 1 + idx_g1 = ntb_g1 + endif !> - Deposition/sublimation prefactor (from Srivastava & Coen 1992). - otemp = 1./temp(k) - rvs = rho(k)*qvsi(k) - rvs_p = rvs*otemp*(lsub*otemp*oRv - 1.) - rvs_pp = rvs * ( otemp*(lsub*otemp*oRv - 1.) & - *otemp*(lsub*otemp*oRv - 1.) & - + (-2.*lsub*otemp*otemp*otemp*oRv) & - + otemp*otemp) - gamsc = lsub*diffu(k)/tcond(k) * rvs_p - alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & - * rvs_pp/rvs_p * rvs/rvs_p - alphsc = MAX(1.E-9, alphsc) - xsat = ssati(k) - if (abs(xsat).lt. 1.E-9) xsat=0. - t1_subl = 4.*PI*( 1.0 - alphsc*xsat & - + 2.*alphsc*alphsc*xsat*xsat & - - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & - / (1.+gamsc) + otemp = 1./temp(k) + rvs = rho(k)*qvsi(k) + rvs_p = rvs*otemp*(lsub*otemp*oRv - 1.) + rvs_pp = rvs * ( otemp*(lsub*otemp*oRv - 1.) & + *otemp*(lsub*otemp*oRv - 1.) & + + (-2.*lsub*otemp*otemp*otemp*oRv) & + + otemp*otemp) + gamsc = lsub*diffu(k)/tcond(k) * rvs_p + alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & + * rvs_pp/rvs_p * rvs/rvs_p + alphsc = MAX(1.E-9, alphsc) + xsat = ssati(k) + if (abs(xsat).lt. 1.E-9) xsat=0. + t1_subl = 4.*PI*( 1.0 - alphsc*xsat & + + 2.*alphsc*alphsc*xsat*xsat & + - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & + / (1.+gamsc) !> - Snow collecting cloud water. In CE, assume Dc< - Graupel collecting cloud water. In CE, assume Dc< - Snow and graupel collecting aerosols, wet scavenging. - if (rs(k) .gt. r_s(1)) then - Ef_sa = Eff_aero(xDs,0.04E-6,visco(k),rho(k),temp(k),'s') - pna_sca(k) = rhof(k)*t1_qs_qc*Ef_sa*nwfa(k)*smoe(k) - pna_sca(k) = MIN(DBLE(nwfa(k)*odts), pna_sca(k)) - - Ef_sa = Eff_aero(xDs,0.8E-6,visco(k),rho(k),temp(k),'s') - pnd_scd(k) = rhof(k)*t1_qs_qc*Ef_sa*nifa(k)*smoe(k) - pnd_scd(k) = MIN(DBLE(nifa(k)*odts), pnd_scd(k)) - endif - if (rg(k) .gt. r_g(1)) then - xDg = (bm_g + mu_g + 1.) * ilamg(k) - Ef_ga = Eff_aero(xDg,0.04E-6,visco(k),rho(k),temp(k),'g') - pna_gca(k) = rhof(k)*t1_qg_qc*Ef_ga*nwfa(k)*N0_g(k) & - *ilamg(k)**cge(9) - pna_gca(k) = MIN(DBLE(nwfa(k)*odts), pna_gca(k)) - - Ef_ga = Eff_aero(xDg,0.8E-6,visco(k),rho(k),temp(k),'g') - pnd_gcd(k) = rhof(k)*t1_qg_qc*Ef_ga*nifa(k)*N0_g(k) & - *ilamg(k)**cge(9) - pnd_gcd(k) = MIN(DBLE(nifa(k)*odts), pnd_gcd(k)) - endif + if (rs(k) .gt. r_s(1)) then + Ef_sa = Eff_aero(xDs,0.04E-6,visco(k),rho(k),temp(k),'s') + pna_sca(k) = rhof(k)*t1_qs_qc*Ef_sa*nwfa(k)*smoe(k) + pna_sca(k) = MIN(DBLE(nwfa(k)*odts), pna_sca(k)) + + Ef_sa = Eff_aero(xDs,0.8E-6,visco(k),rho(k),temp(k),'s') + pnd_scd(k) = rhof(k)*t1_qs_qc*Ef_sa*nifa(k)*smoe(k) + pnd_scd(k) = MIN(DBLE(nifa(k)*odts), pnd_scd(k)) + endif + if (rg(k) .gt. r_g(1)) then + xDg = (bm_g + mu_g + 1.) * ilamg(k) + Ef_ga = Eff_aero(xDg,0.04E-6,visco(k),rho(k),temp(k),'g') + pna_gca(k) = rhof(k)*t1_qg_qc*Ef_ga*nwfa(k)*N0_g(k) & + *ilamg(k)**cge(9) + pna_gca(k) = MIN(DBLE(nwfa(k)*odts), pna_gca(k)) + + Ef_ga = Eff_aero(xDg,0.8E-6,visco(k),rho(k),temp(k),'g') + pnd_gcd(k) = rhof(k)*t1_qg_qc*Ef_ga*nifa(k)*N0_g(k) & + *ilamg(k)**cge(9) + pnd_gcd(k) = MIN(DBLE(nifa(k)*odts), pnd_gcd(k)) + endif !> - Rain collecting snow. Cannot assume Wisner (1972) approximation !! or Mizuno (1990) approach so we solve the CE explicitly and store !! results in lookup table. - if (rr(k).ge. r_r(1)) then - if (rs(k).ge. r_s(1)) then - if (temp(k).lt.T_0) then - prr_rcs(k) = -(tmr_racs2(idx_s,idx_t,idx_r1,idx_r) & - + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) & - + tmr_racs1(idx_s,idx_t,idx_r1,idx_r) & - + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r)) - prs_rcs(k) = tmr_racs2(idx_s,idx_t,idx_r1,idx_r) & - + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) & - - tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & - - tms_sacr1(idx_s,idx_t,idx_r1,idx_r) - prg_rcs(k) = tmr_racs1(idx_s,idx_t,idx_r1,idx_r) & - + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r) & - + tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & - + tms_sacr1(idx_s,idx_t,idx_r1,idx_r) - prr_rcs(k) = MAX(DBLE(-rr(k)*odts), prr_rcs(k)) - prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k)) - prg_rcs(k) = MIN(DBLE((rr(k)+rs(k))*odts), prg_rcs(k)) - pnr_rcs(k) = tnr_racs1(idx_s,idx_t,idx_r1,idx_r) & ! RAIN2M - + tnr_racs2(idx_s,idx_t,idx_r1,idx_r) & - + tnr_sacr1(idx_s,idx_t,idx_r1,idx_r) & - + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r) - pnr_rcs(k) = MIN(DBLE(nr(k)*odts), pnr_rcs(k)) - else - prs_rcs(k) = -tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & - - tms_sacr1(idx_s,idx_t,idx_r1,idx_r) & - + tmr_racs2(idx_s,idx_t,idx_r1,idx_r) & - + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) - prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k)) - prr_rcs(k) = -prs_rcs(k) - endif - endif + if (rr(k).ge. r_r(1)) then + if (rs(k).ge. r_s(1)) then + if (temp(k).lt.T_0) then + prr_rcs(k) = -(tmr_racs2(idx_s,idx_t,idx_r1,idx_r) & + + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) & + + tmr_racs1(idx_s,idx_t,idx_r1,idx_r) & + + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r)) + prs_rcs(k) = tmr_racs2(idx_s,idx_t,idx_r1,idx_r) & + + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) & + - tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & + - tms_sacr1(idx_s,idx_t,idx_r1,idx_r) + prg_rcs(k) = tmr_racs1(idx_s,idx_t,idx_r1,idx_r) & + + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r) & + + tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & + + tms_sacr1(idx_s,idx_t,idx_r1,idx_r) + prr_rcs(k) = MAX(DBLE(-rr(k)*odts), prr_rcs(k)) + prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k)) + prg_rcs(k) = MIN(DBLE((rr(k)+rs(k))*odts), prg_rcs(k)) + pnr_rcs(k) = tnr_racs1(idx_s,idx_t,idx_r1,idx_r) & ! RAIN2M + + tnr_racs2(idx_s,idx_t,idx_r1,idx_r) & + + tnr_sacr1(idx_s,idx_t,idx_r1,idx_r) & + + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r) + pnr_rcs(k) = MIN(DBLE(nr(k)*odts), pnr_rcs(k)) + else + prs_rcs(k) = -tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & + - tms_sacr1(idx_s,idx_t,idx_r1,idx_r) & + + tmr_racs2(idx_s,idx_t,idx_r1,idx_r) & + + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) + prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k)) + prr_rcs(k) = -prs_rcs(k) + endif + endif !> - Rain collecting graupel. Cannot assume Wisner (1972) approximation !! or Mizuno (1990) approach so we solve the CE explicitly and store !! results in lookup table. - if (rg(k).ge. r_g(1)) then - if (temp(k).lt.T_0) then - prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) & - + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r) - prg_rcg(k) = MIN(DBLE(rr(k)*odts), prg_rcg(k)) - prr_rcg(k) = -prg_rcg(k) - pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r) & ! RAIN2M - + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) - pnr_rcg(k) = MIN(DBLE(nr(k)*odts), pnr_rcg(k)) - else - prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r) - prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k)) - prg_rcg(k) = -prr_rcg(k) + if (rg(k).ge. r_g(1)) then + if (temp(k).lt.T_0) then + prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) & + + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r) + prg_rcg(k) = MIN(DBLE(rr(k)*odts), prg_rcg(k)) + prr_rcg(k) = -prg_rcg(k) + pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r) & ! RAIN2M + + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) + pnr_rcg(k) = MIN(DBLE(nr(k)*odts), pnr_rcg(k)) + else + prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r) + prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k)) + prg_rcg(k) = -prr_rcg(k) !> - Put in explicit drop break-up due to collisions. - pnr_rcg(k) = -1.5*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M - endif - endif - endif + pnr_rcg(k) = -1.5*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M + endif + endif + endif - if (temp(k).lt.T_0) then - rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 + if (temp(k).lt.T_0) then + rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 !> - Deposition/sublimation of snow/graupel follows Srivastava & Coen (1992) - if (L_qs(k)) then - C_snow = C_sqrd + (tempc+1.5)*(C_cube-C_sqrd)/(-30.+1.5) - C_snow = MAX(C_sqrd, MIN(C_snow, C_cube)) - prs_sde(k) = C_snow*t1_subl*diffu(k)*ssati(k)*rvs & - * (t1_qs_sd*smo1(k) & - + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) - if (prs_sde(k).lt. 0.) then - prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k), DBLE(rate_max)) - else - prs_sde(k) = MIN(prs_sde(k), DBLE(rate_max)) - endif - endif + if (L_qs(k)) then + C_snow = C_sqrd + (tempc+1.5)*(C_cube-C_sqrd)/(-30.+1.5) + C_snow = MAX(C_sqrd, MIN(C_snow, C_cube)) + prs_sde(k) = C_snow*t1_subl*diffu(k)*ssati(k)*rvs & + * (t1_qs_sd*smo1(k) & + + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) + if (prs_sde(k).lt. 0.) then + prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k), DBLE(rate_max)) + else + prs_sde(k) = MIN(prs_sde(k), DBLE(rate_max)) + endif + endif - if (L_qg(k) .and. ssati(k).lt. -eps) then - prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & - * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & - + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) - if (prg_gde(k).lt. 0.) then - prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k), DBLE(rate_max)) - else - prg_gde(k) = MIN(prg_gde(k), DBLE(rate_max)) - endif - endif + if (L_qg(k) .and. ssati(k).lt. -eps) then + prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & + * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & + + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) + if (prg_gde(k).lt. 0.) then + prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k), DBLE(rate_max)) + else + prg_gde(k) = MIN(prg_gde(k), DBLE(rate_max)) + endif + endif !> - A portion of rimed snow converts to graupel but some remains snow. !! Interp from 15 to 95% as riming factor increases from 5.0 to 30.0 !! 0.028 came from (.75-.15)/(30.-5.). This remains ad-hoc and should !! be revisited. - if (prs_scw(k).gt.5.0*prs_sde(k) .and. & - prs_sde(k).gt.eps) then - r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k)) - g_frac = MIN(0.75, 0.15 + (r_frac-5.)*.028) - vts_boost(k) = MIN(1.5, 1.1 + (r_frac-5.)*.016) - prg_scw(k) = g_frac*prs_scw(k) - prs_scw(k) = (1. - g_frac)*prs_scw(k) - endif - - endif + if (prs_scw(k).gt.5.0*prs_sde(k) .and. & + prs_sde(k).gt.eps) then + r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k)) + g_frac = MIN(0.75, 0.15 + (r_frac-5.)*.028) + vts_boost(k) = MIN(1.5, 1.1 + (r_frac-5.)*.016) + prg_scw(k) = g_frac*prs_scw(k) + prs_scw(k) = (1. - g_frac)*prs_scw(k) + endif + endif !+---+-----------------------------------------------------------------+ !> - Next IF block handles only those processes below 0C. !+---+-----------------------------------------------------------------+ - if (temp(k).lt.T_0) then + if (temp(k).lt.T_0) then - rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 + rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 !+---+---------------- BEGIN NEW ICE NUCLEATION -----------------------+ !> - Freezing of supercooled water (rain or cloud) is influenced by dust @@ -2895,209 +2871,206 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! Implemented by T. Eidhammer and G. Thompson 2012Dec18 !+---+-----------------------------------------------------------------+ - if (dustyIce .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then - xni = iceDeMott(tempc,qvs(k),qvs(k),qvsi(k),rho(k),nifa(k)) - else - xni = 1.0 *1000. ! Default is 1.0 per Liter - endif + if (dustyIce .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then + xni = iceDeMott(tempc,qvs(k),qvs(k),qvsi(k),rho(k),nifa(k)) + else + xni = 1.0 *1000. ! Default is 1.0 per Liter + endif !> - Ice nuclei lookup table index. - if (xni.gt. Nt_IN(1)) then - niin = NINT(ALOG10(xni)) - do nn = niin-1, niin+1 - n = nn - if ( (xni/10.**nn).ge.1.0 .and. & - (xni/10.**nn).lt.10.0) goto 149 - enddo - 149 continue - idx_IN = INT(xni/10.**n) + 10*(n-niin2) - (n-niin2) - idx_IN = MAX(1, MIN(idx_IN, ntb_IN)) - else - idx_IN = 1 - endif + if (xni.gt. Nt_IN(1)) then + niin = NINT(ALOG10(xni)) + do_loop_xni: do nn = niin-1, niin+1 + n = nn + if ( (xni/10.**nn).ge.1.0 .and. (xni/10.**nn).lt.10.0 ) exit do_loop_xni + enddo do_loop_xni + idx_IN = INT(xni/10.**n) + 10*(n-niin2) - (n-niin2) + idx_IN = MAX(1, MIN(idx_IN, ntb_IN)) + else + idx_IN = 1 + endif !> - Freezing of water drops into graupel/cloud ice (Bigg 1953). - if (rr(k).gt. r_r(1)) then - prg_rfz(k) = tpg_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts - pri_rfz(k) = tpi_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts - pni_rfz(k) = tni_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts - pnr_rfz(k) = tnr_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts ! RAIN2M - pnr_rfz(k) = MIN(DBLE(nr(k)*odts), pnr_rfz(k)) - elseif (rr(k).gt. R1 .and. temp(k).lt.HGFR) then - pri_rfz(k) = rr(k)*odts - pni_rfz(k) = pnr_rfz(k) - endif + if (rr(k).gt. r_r(1)) then + prg_rfz(k) = tpg_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts + pri_rfz(k) = tpi_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts + pni_rfz(k) = tni_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts + pnr_rfz(k) = tnr_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts ! RAIN2M + pnr_rfz(k) = MIN(DBLE(nr(k)*odts), pnr_rfz(k)) + elseif (rr(k).gt. R1 .and. temp(k).lt.HGFR) then + pri_rfz(k) = rr(k)*odts + pni_rfz(k) = pnr_rfz(k) + endif - if (rc(k).gt. r_c(1)) then - pri_wfz(k) = tpi_qcfz(idx_c,idx_n,idx_tc,idx_IN)*odts - pri_wfz(k) = MIN(DBLE(rc(k)*odts), pri_wfz(k)) - pni_wfz(k) = tni_qcfz(idx_c,idx_n,idx_tc,idx_IN)*odts - pni_wfz(k) = MIN(DBLE(nc(k)*odts), pri_wfz(k)/(2.*xm0i), & - pni_wfz(k)) - elseif (rc(k).gt. R1 .and. temp(k).lt.HGFR) then - pri_wfz(k) = rc(k)*odts - pni_wfz(k) = nc(k)*odts - endif + if (rc(k).gt. r_c(1)) then + pri_wfz(k) = tpi_qcfz(idx_c,idx_n,idx_tc,idx_IN)*odts + pri_wfz(k) = MIN(DBLE(rc(k)*odts), pri_wfz(k)) + pni_wfz(k) = tni_qcfz(idx_c,idx_n,idx_tc,idx_IN)*odts + pni_wfz(k) = MIN(DBLE(nc(k)*odts), pri_wfz(k)/(2.*xm0i), & + pni_wfz(k)) + elseif (rc(k).gt. R1 .and. temp(k).lt.HGFR) then + pri_wfz(k) = rc(k)*odts + pni_wfz(k) = nc(k)*odts + endif !> - Deposition nucleation of dust/mineral from DeMott et al (2010) !! we may need to relax the temperature and ssati constraints. - if ( (ssati(k).ge. 0.15) .or. (ssatw(k).gt. eps & - .and. temp(k).lt.253.15) ) then - if (dustyIce .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then - xnc = iceDeMott(tempc,qv(k),qvs(k),qvsi(k),rho(k),nifa(k)) - xnc = xnc*(1.0 + 50.*rand3) - else - xnc = MIN(1000.E3, TNO*EXP(ATO*(T_0-temp(k)))) - endif - xni = ni(k) + (pni_rfz(k)+pni_wfz(k))*dtsave - pni_inu(k) = 0.5*(xnc-xni + abs(xnc-xni))*odts - pri_inu(k) = MIN(DBLE(rate_max), xm0i*pni_inu(k)) - pni_inu(k) = pri_inu(k)/xm0i - endif + if ( (ssati(k).ge. 0.15) .or. (ssatw(k).gt. eps & + .and. temp(k).lt.253.15) ) then + if (dustyIce .AND. (is_aerosol_aware .or. merra2_aerosol_aware)) then + xnc = iceDeMott(tempc,qv(k),qvs(k),qvsi(k),rho(k),nifa(k)) + xnc = xnc*(1.0 + 50.*rand3) + else + xnc = MIN(1000.E3, TNO*EXP(ATO*(T_0-temp(k)))) + endif + xni = ni(k) + (pni_rfz(k)+pni_wfz(k))*dtsave + pni_inu(k) = 0.5*(xnc-xni + abs(xnc-xni))*odts + pri_inu(k) = MIN(DBLE(rate_max), xm0i*pni_inu(k)) + pni_inu(k) = pri_inu(k)/xm0i + endif !> - Freezing of aqueous aerosols based on Koop et al (2001, Nature) - xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if ((is_aerosol_aware .or. merra2_aerosol_aware) .AND. homogIce .AND. (xni.le.4999.E3) & - & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then - xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) - pni_iha(k) = xnc*odts - pri_iha(k) = MIN(DBLE(rate_max), xm0i*0.1*pni_iha(k)) - pni_iha(k) = pri_iha(k)/(xm0i*0.1) - endif + xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave + if ((is_aerosol_aware .or. merra2_aerosol_aware) .AND. homogIce .AND. (xni.le.4999.E3) & + .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then + xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) + pni_iha(k) = xnc*odts + pri_iha(k) = MIN(DBLE(rate_max), xm0i*0.1*pni_iha(k)) + pni_iha(k) = pri_iha(k)/(xm0i*0.1) + endif !+---+------------------ END NEW ICE NUCLEATION -----------------------+ !> - Deposition/sublimation of cloud ice (Srivastava & Coen 1992). - if (L_qi(k)) then - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami) - xmi = am_i*xDi**bm_i - oxmi = 1./xmi - pri_ide(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & - *oig1*cig(5)*ni(k)*ilami - - if (pri_ide(k) .lt. 0.0) then - pri_ide(k) = MAX(DBLE(-ri(k)*odts), pri_ide(k), DBLE(rate_max)) - pni_ide(k) = pri_ide(k)*oxmi - pni_ide(k) = MAX(DBLE(-ni(k)*odts), pni_ide(k)) - else - pri_ide(k) = MIN(pri_ide(k), DBLE(rate_max)) - prs_ide(k) = (1.0D0-tpi_ide(idx_i,idx_i1))*pri_ide(k) - pri_ide(k) = tpi_ide(idx_i,idx_i1)*pri_ide(k) - endif + if (L_qi(k)) then + lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi + ilami = 1./lami + xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami) + xmi = am_i*xDi**bm_i + oxmi = 1./xmi + pri_ide(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & + *oig1*cig(5)*ni(k)*ilami + + if (pri_ide(k) .lt. 0.0) then + pri_ide(k) = MAX(DBLE(-ri(k)*odts), pri_ide(k), DBLE(rate_max)) + pni_ide(k) = pri_ide(k)*oxmi + pni_ide(k) = MAX(DBLE(-ni(k)*odts), pni_ide(k)) + else + pri_ide(k) = MIN(pri_ide(k), DBLE(rate_max)) + prs_ide(k) = (1.0D0-tpi_ide(idx_i,idx_i1))*pri_ide(k) + pri_ide(k) = tpi_ide(idx_i,idx_i1)*pri_ide(k) + endif !> - Some cloud ice needs to move into the snow category. Use lookup !! table that resulted from explicit bin representation of distrib. - if ( (idx_i.eq. ntb_i) .or. (xDi.gt. 5.0*D0s) ) then - prs_iau(k) = ri(k)*.99*odts - pni_iau(k) = ni(k)*.95*odts - elseif (xDi.lt. 0.1*D0s) then - prs_iau(k) = 0. - pni_iau(k) = 0. - else - prs_iau(k) = tps_iaus(idx_i,idx_i1)*odts - prs_iau(k) = MIN(DBLE(ri(k)*.99*odts), prs_iau(k)) - pni_iau(k) = tni_iaus(idx_i,idx_i1)*odts - pni_iau(k) = MIN(DBLE(ni(k)*.95*odts), pni_iau(k)) - endif - endif + if ( (idx_i.eq. ntb_i) .or. (xDi.gt. 5.0*D0s) ) then + prs_iau(k) = ri(k)*.99*odts + pni_iau(k) = ni(k)*.95*odts + elseif (xDi.lt. 0.1*D0s) then + prs_iau(k) = 0. + pni_iau(k) = 0. + else + prs_iau(k) = tps_iaus(idx_i,idx_i1)*odts + prs_iau(k) = MIN(DBLE(ri(k)*.99*odts), prs_iau(k)) + pni_iau(k) = tni_iaus(idx_i,idx_i1)*odts + pni_iau(k) = MIN(DBLE(ni(k)*.95*odts), pni_iau(k)) + endif + endif !> - Snow collecting cloud ice. In CE, assume Di< - Rain collecting cloud ice. In CE, assume Di< - Ice multiplication from rime-splinters (Hallet & Mossop 1974). - if (prg_gcw(k).gt. eps .and. tempc.gt.-8.0) then - tf = 0. - if (tempc.ge.-5.0 .and. tempc.lt.-3.0) then - tf = 0.5*(-3.0 - tempc) - elseif (tempc.gt.-8.0 .and. tempc.lt.-5.0) then - tf = 0.33333333*(8.0 + tempc) - endif - pni_ihm(k) = 3.5E8*tf*prg_gcw(k) - pri_ihm(k) = xm0i*pni_ihm(k) - prs_ihm(k) = prs_scw(k)/(prs_scw(k)+prg_gcw(k)) & - * pri_ihm(k) - prg_ihm(k) = prg_gcw(k)/(prs_scw(k)+prg_gcw(k)) & - * pri_ihm(k) - endif - - else + if (prg_gcw(k).gt. eps .and. tempc.gt.-8.0) then + tf = 0. + if (tempc.ge.-5.0 .and. tempc.lt.-3.0) then + tf = 0.5*(-3.0 - tempc) + elseif (tempc.gt.-8.0 .and. tempc.lt.-5.0) then + tf = 0.33333333*(8.0 + tempc) + endif + pni_ihm(k) = 3.5E8*tf*prg_gcw(k) + pri_ihm(k) = xm0i*pni_ihm(k) + prs_ihm(k) = prs_scw(k)/(prs_scw(k)+prg_gcw(k)) & + * pri_ihm(k) + prg_ihm(k) = prg_gcw(k)/(prs_scw(k)+prg_gcw(k)) & + * pri_ihm(k) + endif + + else !> - Melt snow and graupel and enhance from collisions with liquid. !! We also need to sublimate snow and graupel if subsaturated. - if (L_qs(k)) then - prr_sml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) & - * (t1_qs_me*smo1(k) + t2_qs_me*rhof2(k)*vsc2(k)*smof(k)) - if (prr_sml(k) .gt. 0.) then - prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & - * (prr_rcs(k)+prs_scw(k)) - prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k)) - pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M - pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) - elseif (ssati(k).lt. 0.) then - prr_sml(k) = 0.0 - prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & - * (t1_qs_sd*smo1(k) & - + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) - prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k)) - endif - endif + if (L_qs(k)) then + prr_sml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) & + * (t1_qs_me*smo1(k) + t2_qs_me*rhof2(k)*vsc2(k)*smof(k)) + if (prr_sml(k) .gt. 0.) then + prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & + * (prr_rcs(k)+prs_scw(k)) + prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k)) + pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M + pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) + elseif (ssati(k).lt. 0.) then + prr_sml(k) = 0.0 + prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & + * (t1_qs_sd*smo1(k) & + + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) + prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k)) + endif + endif - if (L_qg(k)) then - prr_gml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) & - * N0_g(k)*(t1_qg_me*ilamg(k)**cge(10) & - + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11)) - if (prr_gml(k) .gt. 0.) then - prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k)) - pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M - * prr_gml(k) * 10.0**(-0.5*tempc) - elseif (ssati(k).lt. 0.) then - prr_gml(k) = 0.0 - prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & - * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & - + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) - prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k)) - endif - endif + if (L_qg(k)) then + prr_gml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) & + * N0_g(k)*(t1_qg_me*ilamg(k)**cge(10) & + + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11)) + if (prr_gml(k) .gt. 0.) then + prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k)) + pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M + * prr_gml(k) * 10.0**(-0.5*tempc) + elseif (ssati(k).lt. 0.) then + prr_gml(k) = 0.0 + prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & + * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & + + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) + prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k)) + endif + endif !> - This change will be required if users run adaptive time step that !! results in delta-t that is generally too long to allow cloud water !! collection by snow/graupel above melting temperature. !! Credit to Bjorn-Egil Nygaard for discovering. - if (dt .gt. 120.) then - prr_rcw(k)=prr_rcw(k)+prs_scw(k)+prg_gcw(k) - prs_scw(k)=0. - prg_gcw(k)=0. - endif - - endif + if (dt .gt. 120.) then + prr_rcw(k)=prr_rcw(k)+prs_scw(k)+prg_gcw(k) + prs_scw(k)=0. + prg_gcw(k)=0. + endif + endif - enddo + enddo endif !+---+-----------------------------------------------------------------+ @@ -3114,14 +3087,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 if ( (sump.gt. eps .and. sump.gt. rate_max) .or. & (sump.lt. -eps .and. sump.lt. rate_max) ) then - ratio = rate_max/sump - pri_inu(k) = pri_inu(k) * ratio - pri_ide(k) = pri_ide(k) * ratio - pni_ide(k) = pni_ide(k) * ratio - prs_ide(k) = prs_ide(k) * ratio - prs_sde(k) = prs_sde(k) * ratio - prg_gde(k) = prg_gde(k) * ratio - pri_iha(k) = pri_iha(k) * ratio + ratio = rate_max/sump + pri_inu(k) = pri_inu(k) * ratio + pri_ide(k) = pri_ide(k) * ratio + pni_ide(k) = pni_ide(k) * ratio + prs_ide(k) = prs_ide(k) * ratio + prs_sde(k) = prs_sde(k) * ratio + prg_gde(k) = prg_gde(k) * ratio + pri_iha(k) = pri_iha(k) * ratio endif !> - Cloud water conservation. @@ -3129,13 +3102,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - prs_scw(k) - prg_scw(k) - prg_gcw(k) rate_max = -rc(k)*odts if (sump.lt. rate_max .and. L_qc(k)) then - ratio = rate_max/sump - prr_wau(k) = prr_wau(k) * ratio - pri_wfz(k) = pri_wfz(k) * ratio - prr_rcw(k) = prr_rcw(k) * ratio - prs_scw(k) = prs_scw(k) * ratio - prg_scw(k) = prg_scw(k) * ratio - prg_gcw(k) = prg_gcw(k) * ratio + ratio = rate_max/sump + prr_wau(k) = prr_wau(k) * ratio + pri_wfz(k) = pri_wfz(k) * ratio + prr_rcw(k) = prr_rcw(k) * ratio + prs_scw(k) = prs_scw(k) * ratio + prg_scw(k) = prg_scw(k) * ratio + prg_gcw(k) = prg_gcw(k) * ratio endif !> - Cloud ice conservation. @@ -3143,11 +3116,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - pri_rci(k) rate_max = -ri(k)*odts if (sump.lt. rate_max .and. L_qi(k)) then - ratio = rate_max/sump - pri_ide(k) = pri_ide(k) * ratio - prs_iau(k) = prs_iau(k) * ratio - prs_sci(k) = prs_sci(k) * ratio - pri_rci(k) = pri_rci(k) * ratio + ratio = rate_max/sump + pri_ide(k) = pri_ide(k) * ratio + prs_iau(k) = prs_iau(k) * ratio + prs_sci(k) = prs_sci(k) * ratio + pri_rci(k) = pri_rci(k) * ratio endif !> - Rain conservation. @@ -3155,12 +3128,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + prr_rcs(k) + prr_rcg(k) rate_max = -rr(k)*odts if (sump.lt. rate_max .and. L_qr(k)) then - ratio = rate_max/sump - prg_rfz(k) = prg_rfz(k) * ratio - pri_rfz(k) = pri_rfz(k) * ratio - prr_rci(k) = prr_rci(k) * ratio - prr_rcs(k) = prr_rcs(k) * ratio - prr_rcg(k) = prr_rcg(k) * ratio + ratio = rate_max/sump + prg_rfz(k) = prg_rfz(k) * ratio + pri_rfz(k) = pri_rfz(k) * ratio + prr_rci(k) = prr_rci(k) * ratio + prr_rcs(k) = prr_rcs(k) * ratio + prr_rcg(k) = prr_rcg(k) * ratio endif !> - Snow conservation. @@ -3168,11 +3141,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + prs_rcs(k) rate_max = -rs(k)*odts if (sump.lt. rate_max .and. L_qs(k)) then - ratio = rate_max/sump - prs_sde(k) = prs_sde(k) * ratio - prs_ihm(k) = prs_ihm(k) * ratio - prr_sml(k) = prr_sml(k) * ratio - prs_rcs(k) = prs_rcs(k) * ratio + ratio = rate_max/sump + prs_sde(k) = prs_sde(k) * ratio + prs_ihm(k) = prs_ihm(k) * ratio + prr_sml(k) = prr_sml(k) * ratio + prs_rcs(k) = prs_rcs(k) * ratio endif !> - Graupel conservation. @@ -3180,11 +3153,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + prg_rcg(k) rate_max = -rg(k)*odts if (sump.lt. rate_max .and. L_qg(k)) then - ratio = rate_max/sump - prg_gde(k) = prg_gde(k) * ratio - prg_ihm(k) = prg_ihm(k) * ratio - prr_gml(k) = prr_gml(k) * ratio - prg_rcg(k) = prg_rcg(k) * ratio + ratio = rate_max/sump + prg_gde(k) = prg_gde(k) * ratio + prg_ihm(k) = prg_ihm(k) * ratio + prr_gml(k) = prr_gml(k) * ratio + prg_rcg(k) = prg_rcg(k) * ratio endif !> - Re-enforce proper mass conservation for subsequent elements in case @@ -3243,27 +3216,27 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xrc=MAX(R1, (qc1d(k) + qcten(k)*dtsave)*rho(k)) xnc=MAX(2., (nc1d(k) + ncten(k)*dtsave)*rho(k)) if (xrc .gt. R1) then - if (xnc.gt.10000.E6) then - nu_c = 2 - elseif (xnc.lt.100.) then - nu_c = 15 - else - nu_c = NINT(1000.E6/xnc) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) - endif - lamc = (xnc*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr - xDc = (bm_r + nu_c + 1.) / lamc - if (xDc.lt. D0c) then - lamc = cce(2,nu_c)/D0c - xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r - ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho - elseif (xDc.gt. D0r*2.) then - lamc = cce(2,nu_c)/(D0r*2.) - xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r - ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho - endif + if (xnc.gt.10000.E6) then + nu_c = 2 + elseif (xnc.lt.100.) then + nu_c = 15 + else + nu_c = NINT(1000.E6/xnc) + 2 + nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + endif + lamc = (xnc*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr + xDc = (bm_r + nu_c + 1.) / lamc + if (xDc.lt. D0c) then + lamc = cce(2,nu_c)/D0c + xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r + ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho + elseif (xDc.gt. D0r*2.) then + lamc = cce(2,nu_c)/(D0r*2.) + xnc = ccg(1,nu_c)*ocg2(nu_c)*xrc/am_r*lamc**bm_r + ncten(k) = (xnc-nc1d(k)*rho(k))*odts*orho + endif else - ncten(k) = -nc1d(k)*odts + ncten(k) = -nc1d(k)*odts endif xnc=MAX(0.,(nc1d(k) + ncten(k)*dtsave)*rho(k)) if (xnc.gt.Nt_c_max) & @@ -3286,20 +3259,20 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xri=MAX(R1,(qi1d(k) + qiten(k)*dtsave)*rho(k)) xni=MAX(R2,(ni1d(k) + niten(k)*dtsave)*rho(k)) if (xri.gt. R1) then - lami = (am_i*cig(2)*oig1*xni/xri)**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 5.E-6) then - lami = cie(2)/5.E-6 - xni = MIN(4999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) - niten(k) = (xni-ni1d(k)*rho(k))*odts*orho - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - xni = cig(1)*oig2*xri/am_i*lami**bm_i - niten(k) = (xni-ni1d(k)*rho(k))*odts*orho - endif + lami = (am_i*cig(2)*oig1*xni/xri)**obmi + ilami = 1./lami + xDi = (bm_i + mu_i + 1.) * ilami + if (xDi.lt. 5.E-6) then + lami = cie(2)/5.E-6 + xni = MIN(4999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + niten(k) = (xni-ni1d(k)*rho(k))*odts*orho + elseif (xDi.gt. 300.E-6) then + lami = cie(2)/300.E-6 + xni = cig(1)*oig2*xri/am_i*lami**bm_i + niten(k) = (xni-ni1d(k)*rho(k))*odts*orho + endif else - niten(k) = -ni1d(k)*odts + niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) if (xni.gt.4999.E3) & @@ -3323,22 +3296,22 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xrr=MAX(R1,(qr1d(k) + qrten(k)*dtsave)*rho(k)) xnr=MAX(R2,(nr1d(k) + nrten(k)*dtsave)*rho(k)) if (xrr.gt. R1) then - lamr = (am_r*crg(3)*org2*xnr/xrr)**obmr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - if (mvd_r(k) .gt. 2.5E-3) then - mvd_r(k) = 2.5E-3 - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - xnr = crg(2)*org3*xrr*lamr**bm_r / am_r - nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho - elseif (mvd_r(k) .lt. D0r*0.75) then - mvd_r(k) = D0r*0.75 - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - xnr = crg(2)*org3*xrr*lamr**bm_r / am_r - nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho - endif + lamr = (am_r*crg(3)*org2*xnr/xrr)**obmr + mvd_r(k) = (3.0 + mu_r + 0.672) / lamr + if (mvd_r(k) .gt. 2.5E-3) then + mvd_r(k) = 2.5E-3 + lamr = (3.0 + mu_r + 0.672) / mvd_r(k) + xnr = crg(2)*org3*xrr*lamr**bm_r / am_r + nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho + elseif (mvd_r(k) .lt. D0r*0.75) then + mvd_r(k) = D0r*0.75 + lamr = (3.0 + mu_r + 0.672) / mvd_r(k) + xnr = crg(2)*org3*xrr*lamr**bm_r / am_r + nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho + endif else - qrten(k) = -qr1d(k)*odts - nrten(k) = -nr1d(k)*odts + qrten(k) = -qr1d(k)*odts + nrten(k) = -nr1d(k)*odts endif !> - Snow tendency @@ -3356,22 +3329,22 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Temperature tendency if (temp(k).lt.T_0) then - tten(k) = tten(k) & - + ( lsub*ocp(k)*(pri_inu(k) + pri_ide(k) & - + prs_ide(k) + prs_sde(k) & - + prg_gde(k) + pri_iha(k)) & - + lfus2*ocp(k)*(pri_wfz(k) + pri_rfz(k) & - + prg_rfz(k) + prs_scw(k) & - + prg_scw(k) + prg_gcw(k) & - + prg_rcs(k) + prs_rcs(k) & - + prr_rci(k) + prg_rcg(k)) & - )*orho * (1-IFDRY) + tten(k) = tten(k) & + + ( lsub*ocp(k)*(pri_inu(k) + pri_ide(k) & + + prs_ide(k) + prs_sde(k) & + + prg_gde(k) + pri_iha(k)) & + + lfus2*ocp(k)*(pri_wfz(k) + pri_rfz(k) & + + prg_rfz(k) + prs_scw(k) & + + prg_scw(k) + prg_gcw(k) & + + prg_rcs(k) + prs_rcs(k) & + + prr_rci(k) + prg_rcg(k)) & + )*orho * (1-IFDRY) else - tten(k) = tten(k) & - + ( lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) & - - prr_rcg(k) - prr_rcs(k)) & - + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) & - )*orho * (1-IFDRY) + tten(k) = tten(k) & + + ( lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) & + - prr_rcg(k) - prr_rcs(k)) & + + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) & + )*orho * (1-IFDRY) endif enddo @@ -3410,11 +3383,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rc(k) = (qc1d(k) + qcten(k)*DT)*rho(k) nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then - if(lsml == 1) then - nc(k) = Nt_c_l - else - nc(k) = Nt_c_o - endif + if(lsml == 1) then + nc(k) = Nt_c_l + else + nc(k) = Nt_c_o + endif endif L_qc(k) = .true. else @@ -3476,67 +3449,67 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! intercepts/slopes of graupel and rain. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then - do k = kts, kte - smo2(k) = 0. - smob(k) = 0. - smoc(k) = 0. - smod(k) = 0. - enddo - do k = kts, kte - if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) - smob(k) = rs(k)*oams - -!> - All other moments based on reference, 2nd moment. If bm_s.ne.2, -!! then we must compute actual 2nd moment and use as reference. - if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then - smo2(k) = smob(k) - else - loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & - + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & - + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & - + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & - + sa(10)*bm_s*bm_s*bm_s - a_ = 10.0**loga_ - b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & - + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & - + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & - + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & - + sb(10)*bm_s*bm_s*bm_s - smo2(k) = (smob(k)/a_)**(1./b_) - endif + do k = kts, kte + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smod(k) = 0. + enddo + do k = kts, kte + if (.not. L_qs(k)) CYCLE + tc0 = MIN(-0.1, temp(k)-273.15) + smob(k) = rs(k)*oams + + !> - All other moments based on reference, 2nd moment. If bm_s.ne.2, + !! then we must compute actual 2nd moment and use as reference. + if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then + smo2(k) = smob(k) + else + loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s & + + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 & + + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s & + + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 & + + sa(10)*bm_s*bm_s*bm_s + a_ = 10.0**loga_ + b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s & + + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 & + + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s & + + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 & + + sb(10)*bm_s*bm_s*bm_s + smo2(k) = (smob(k)/a_)**(1./b_) + endif !> - Calculate bm_s+1 (th) moment. Useful for diameter calcs. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & - + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & - + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & - + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(1)*cse(1)*cse(1) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & - + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & - + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) - smoc(k) = a_ * smo2(k)**b_ + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) & + + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 & + + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) & + + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(1)*cse(1)*cse(1) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) & + + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) & + + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) + smoc(k) = a_ * smo2(k)**b_ !> - Calculate bm_s+bv_s (th) moment. Useful for sedimentation. - loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(14) & - + sa(4)*tc0*cse(14) + sa(5)*tc0*tc0 & - + sa(6)*cse(14)*cse(14) + sa(7)*tc0*tc0*cse(14) & - + sa(8)*tc0*cse(14)*cse(14) + sa(9)*tc0*tc0*tc0 & - + sa(10)*cse(14)*cse(14)*cse(14) - a_ = 10.0**loga_ - b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(14) + sb(4)*tc0*cse(14) & - + sb(5)*tc0*tc0 + sb(6)*cse(14)*cse(14) & - + sb(7)*tc0*tc0*cse(14) + sb(8)*tc0*cse(14)*cse(14) & - + sb(9)*tc0*tc0*tc0 + sb(10)*cse(14)*cse(14)*cse(14) - smod(k) = a_ * smo2(k)**b_ - enddo + loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(14) & + + sa(4)*tc0*cse(14) + sa(5)*tc0*tc0 & + + sa(6)*cse(14)*cse(14) + sa(7)*tc0*tc0*cse(14) & + + sa(8)*tc0*cse(14)*cse(14) + sa(9)*tc0*tc0*tc0 & + + sa(10)*cse(14)*cse(14)*cse(14) + a_ = 10.0**loga_ + b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(14) + sb(4)*tc0*cse(14) & + + sb(5)*tc0*tc0 + sb(6)*cse(14)*cse(14) & + + sb(7)*tc0*tc0*cse(14) + sb(8)*tc0*cse(14)*cse(14) & + + sb(9)*tc0*tc0*tc0 + sb(10)*cse(14)*cse(14)*cse(14) + smod(k) = a_ * smo2(k)**b_ + enddo !+---+-----------------------------------------------------------------+ !> - Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) + call graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) endif !+---+-----------------------------------------------------------------+ @@ -3561,108 +3534,106 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & orho = 1./rho(k) if ( (ssatw(k).gt. eps) .or. (ssatw(k).lt. -eps .and. & L_qc(k)) ) then - clap = (qv(k)-qvs(k))/(1. + lvt2(k)*qvs(k)) - do n = 1, 3 - fcd = qvs(k)* EXP(lvt2(k)*clap) - qv(k) + clap - dfcd = qvs(k)*lvt2(k)* EXP(lvt2(k)*clap) + 1. - clap = clap - fcd/dfcd - enddo - xrc = rc(k) + clap*rho(k) - xnc = 0. - if (xrc.gt. R1) then - prw_vcd(k) = clap*odt -!+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION - if (clap .gt. eps) then - if (is_aerosol_aware .or. merra2_aerosol_aware) then - xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml)) - else - if(lsml == 1) then - xnc = Nt_c_l - else - xnc = Nt_c_o - endif - endif - pnc_wcd(k) = 0.5*(xnc-nc(k) + abs(xnc-nc(k)))*odts*orho - -!+---+-----------------------------------------------------------------+ ! EVAPORATION - elseif (clap .lt. -eps .AND. ssatw(k).lt.-1.E-6 .AND. & - (is_aerosol_aware .or. merra2_aerosol_aware)) then - tempc = temp(k) - 273.15 - otemp = 1./temp(k) - rvs = rho(k)*qvs(k) - rvs_p = rvs*otemp*(lvap(k)*otemp*oRv - 1.) - rvs_pp = rvs * ( otemp*(lvap(k)*otemp*oRv - 1.) & - *otemp*(lvap(k)*otemp*oRv - 1.) & - + (-2.*lvap(k)*otemp*otemp*otemp*oRv) & - + otemp*otemp) - gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p - alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & - * rvs_pp/rvs_p * rvs/rvs_p - alphsc = MAX(1.E-9, alphsc) - xsat = ssatw(k) - if (abs(xsat).lt. 1.E-9) xsat=0. - t1_evap = 2.*PI*( 1.0 - alphsc*xsat & - + 2.*alphsc*alphsc*xsat*xsat & - - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & - / (1.+gamsc) - - Dc_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) & - * 4.*diffu(k)*ssatw(k)*rvs/rho_w) - idx_d = MAX(1, MIN(INT(1.E6*Dc_star), nbc)) + clap = (qv(k)-qvs(k))/(1. + lvt2(k)*qvs(k)) + do n = 1, 3 + fcd = qvs(k)* EXP(lvt2(k)*clap) - qv(k) + clap + dfcd = qvs(k)*lvt2(k)* EXP(lvt2(k)*clap) + 1. + clap = clap - fcd/dfcd + enddo + xrc = rc(k) + clap*rho(k) + xnc = 0. + if (xrc.gt. R1) then + prw_vcd(k) = clap*odt + !+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION + if (clap .gt. eps) then + if (is_aerosol_aware .or. merra2_aerosol_aware) then + xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml)) + else + if(lsml == 1) then + xnc = Nt_c_l + else + xnc = Nt_c_o + endif + endif + pnc_wcd(k) = 0.5*(xnc-nc(k) + abs(xnc-nc(k)))*odts*orho + + !+---+-----------------------------------------------------------------+ ! EVAPORATION + elseif (clap .lt. -eps .AND. ssatw(k).lt.-1.E-6 .AND. & + (is_aerosol_aware .or. merra2_aerosol_aware)) then + tempc = temp(k) - 273.15 + otemp = 1./temp(k) + rvs = rho(k)*qvs(k) + rvs_p = rvs*otemp*(lvap(k)*otemp*oRv - 1.) + rvs_pp = rvs * ( otemp*(lvap(k)*otemp*oRv - 1.) & + *otemp*(lvap(k)*otemp*oRv - 1.) & + + (-2.*lvap(k)*otemp*otemp*otemp*oRv) & + + otemp*otemp) + gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p + alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & + * rvs_pp/rvs_p * rvs/rvs_p + alphsc = MAX(1.E-9, alphsc) + xsat = ssatw(k) + if (abs(xsat).lt. 1.E-9) xsat=0. + t1_evap = 2.*PI*( 1.0 - alphsc*xsat & + + 2.*alphsc*alphsc*xsat*xsat & + - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & + / (1.+gamsc) + + Dc_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) & + * 4.*diffu(k)*ssatw(k)*rvs/rho_w) + idx_d = MAX(1, MIN(INT(1.E6*Dc_star), nbc)) + + idx_n = NINT(1.0 + FLOAT(nbc) * DLOG(nc(k)/t_Nc(1)) / nic1) + idx_n = MAX(1, MIN(idx_n, nbc)) + + !> - Cloud water lookup table index. + if (rc(k).gt. r_c(1)) then + nic = NINT(ALOG10(rc(k))) + do_loop_rc_cond: do nn = nic-1, nic+1 + n = nn + if ( (rc(k)/10.**nn).ge.1.0 .and. (rc(k)/10.**nn).lt.10.0 ) exit do_loop_rc_cond + enddo do_loop_rc_cond + idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) + idx_c = MAX(1, MIN(idx_c, ntb_c)) + else + idx_c = 1 + endif - idx_n = NINT(1.0 + FLOAT(nbc) * DLOG(nc(k)/t_Nc(1)) / nic1) - idx_n = MAX(1, MIN(idx_n, nbc)) + !prw_vcd(k) = MAX(DBLE(-rc(k)*orho*odt), & + ! -tpc_wev(idx_d, idx_c, idx_n)*orho*odt) + prw_vcd(k) = MAX(DBLE(-rc(k)*0.99*orho*odt), prw_vcd(k)) + pnc_wcd(k) = MAX(DBLE(-nc(k)*0.99*orho*odt), & + -tnc_wev(idx_d, idx_c, idx_n)*orho*odt) -!> - Cloud water lookup table index. - if (rc(k).gt. r_c(1)) then - nic = NINT(ALOG10(rc(k))) - do nn = nic-1, nic+1 - n = nn - if ( (rc(k)/10.**nn).ge.1.0 .and. & - (rc(k)/10.**nn).lt.10.0) goto 159 - enddo - 159 continue - idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) - idx_c = MAX(1, MIN(idx_c, ntb_c)) + endif else - idx_c = 1 + prw_vcd(k) = -rc(k)*orho*odt + pnc_wcd(k) = -nc(k)*orho*odt endif - !prw_vcd(k) = MAX(DBLE(-rc(k)*orho*odt), & - ! -tpc_wev(idx_d, idx_c, idx_n)*orho*odt) - prw_vcd(k) = MAX(DBLE(-rc(k)*0.99*orho*odt), prw_vcd(k)) - pnc_wcd(k) = MAX(DBLE(-nc(k)*0.99*orho*odt), & - -tnc_wev(idx_d, idx_c, idx_n)*orho*odt) - - endif - else - prw_vcd(k) = -rc(k)*orho*odt - pnc_wcd(k) = -nc(k)*orho*odt - endif - !+---+-----------------------------------------------------------------+ - qvten(k) = qvten(k) - prw_vcd(k) - qcten(k) = qcten(k) + prw_vcd(k) - ncten(k) = ncten(k) + pnc_wcd(k) - if (is_aerosol_aware) & - nwfaten(k) = nwfaten(k) - pnc_wcd(k) - tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY) - rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k)) - if (rc(k).eq.R1) L_qc(k) = .false. - nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) - if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then - if(lsml == 1) then - nc(k) = Nt_c_l - else - nc(k) = Nt_c_o + qvten(k) = qvten(k) - prw_vcd(k) + qcten(k) = qcten(k) + prw_vcd(k) + ncten(k) = ncten(k) + pnc_wcd(k) + if (is_aerosol_aware) & + nwfaten(k) = nwfaten(k) - pnc_wcd(k) + tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY) + rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k)) + if (rc(k).eq.R1) L_qc(k) = .false. + nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) + if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then + if(lsml == 1) then + nc(k) = Nt_c_l + else + nc(k) = Nt_c_o + endif endif - endif - qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) - temp(k) = t1d(k) + DT*tten(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - qvs(k) = rslf(pres(k), temp(k)) - ssatw(k) = qv(k)/qvs(k) - 1. + qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) + temp(k) = t1d(k) + DT*tten(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + qvs(k) = rslf(pres(k), temp(k)) + ssatw(k) = qv(k)/qvs(k) - 1. endif enddo @@ -3673,48 +3644,48 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & do k = kts, kte if ( (ssatw(k).lt. -eps) .and. L_qr(k) & .and. (.not.(prw_vcd(k).gt. 0.)) ) then - tempc = temp(k) - 273.15 - otemp = 1./temp(k) - orho = 1./rho(k) - rhof(k) = SQRT(RHO_NOT*orho) - rhof2(k) = SQRT(rhof(k)) - diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k)) - if (tempc .ge. 0.0) then - visco(k) = (1.718+0.0049*tempc)*1.0E-5 - else - visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5 - endif - vsc2(k) = SQRT(rho(k)/visco(k)) - lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc - tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 - ocp(k) = 1./(Cp*(1.+0.887*qv(k))) - - rvs = rho(k)*qvs(k) - rvs_p = rvs*otemp*(lvap(k)*otemp*oRv - 1.) - rvs_pp = rvs * ( otemp*(lvap(k)*otemp*oRv - 1.) & - *otemp*(lvap(k)*otemp*oRv - 1.) & - + (-2.*lvap(k)*otemp*otemp*otemp*oRv) & - + otemp*otemp) - gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p - alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & - * rvs_pp/rvs_p * rvs/rvs_p - alphsc = MAX(1.E-9, alphsc) - xsat = MIN(-1.E-9, ssatw(k)) - t1_evap = 2.*PI*( 1.0 - alphsc*xsat & - + 2.*alphsc*alphsc*xsat*xsat & - - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & - / (1.+gamsc) - - lamr = 1./ilamr(k) + tempc = temp(k) - 273.15 + otemp = 1./temp(k) + orho = 1./rho(k) + rhof(k) = SQRT(RHO_NOT*orho) + rhof2(k) = SQRT(rhof(k)) + diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k)) + if (tempc .ge. 0.0) then + visco(k) = (1.718+0.0049*tempc)*1.0E-5 + else + visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5 + endif + vsc2(k) = SQRT(rho(k)/visco(k)) + lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc + tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936 + ocp(k) = 1./(Cp*(1.+0.887*qv(k))) + + rvs = rho(k)*qvs(k) + rvs_p = rvs*otemp*(lvap(k)*otemp*oRv - 1.) + rvs_pp = rvs * ( otemp*(lvap(k)*otemp*oRv - 1.) & + *otemp*(lvap(k)*otemp*oRv - 1.) & + + (-2.*lvap(k)*otemp*otemp*otemp*oRv) & + + otemp*otemp) + gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p + alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & + * rvs_pp/rvs_p * rvs/rvs_p + alphsc = MAX(1.E-9, alphsc) + xsat = MIN(-1.E-9, ssatw(k)) + t1_evap = 2.*PI*( 1.0 - alphsc*xsat & + + 2.*alphsc*alphsc*xsat*xsat & + - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & + / (1.+gamsc) + + lamr = 1./ilamr(k) !> - Rapidly eliminate near zero values when low humidity (<95%) - if (qv(k)/qvs(k) .lt. 0.95 .AND. rr(k)*orho.le.1.E-8) then - prv_rev(k) = rr(k)*orho*odts - else - prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*N0_r(k)*rvs & - * (t1_qr_ev*ilamr(k)**cre(10) & - + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11)))) - rate_max = MIN((rr(k)*orho*odts), (qvs(k)-qv(k))*odts) - prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)*orho) + if (qv(k)/qvs(k) .lt. 0.95 .AND. rr(k)*orho.le.1.E-8) then + prv_rev(k) = rr(k)*orho*odts + else + prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*N0_r(k)*rvs & + * (t1_qr_ev*ilamr(k)**cre(10) & + + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11)))) + rate_max = MIN((rr(k)*orho*odts), (qvs(k)-qv(k))*odts) + prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)*orho) !..TEST: G. Thompson 10 May 2013 !> - Reduce the rain evaporation in same places as melting graupel occurs. @@ -3723,27 +3694,27 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! at 0C. Also not much shedding of the water from the graupel so !! likely that the water-coated graupel evaporating much slower than !! if the water was immediately shed off. - IF (prr_gml(k).gt.0.0) THEN - eva_factor = MIN(1.0, 0.01+(0.99-0.01)*(tempc/20.0)) - prv_rev(k) = prv_rev(k)*eva_factor - ENDIF - endif + if (prr_gml(k).gt.0.0) then + eva_factor = MIN(1.0, 0.01+(0.99-0.01)*(tempc/20.0)) + prv_rev(k) = prv_rev(k)*eva_factor + endif + endif - pnr_rev(k) = MIN(DBLE(nr(k)*0.99*orho*odts), & ! RAIN2M - prv_rev(k) * nr(k)/rr(k)) - - qrten(k) = qrten(k) - prv_rev(k) - qvten(k) = qvten(k) + prv_rev(k) - nrten(k) = nrten(k) - pnr_rev(k) - if (is_aerosol_aware) & - nwfaten(k) = nwfaten(k) + pnr_rev(k) - tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY) - - rr(k) = MAX(R1, (qr1d(k) + DT*qrten(k))*rho(k)) - qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) - nr(k) = MAX(R2, (nr1d(k) + DT*nrten(k))*rho(k)) - temp(k) = t1d(k) + DT*tten(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + pnr_rev(k) = MIN(DBLE(nr(k)*0.99*orho*odts), & ! RAIN2M + prv_rev(k) * nr(k)/rr(k)) + + qrten(k) = qrten(k) - prv_rev(k) + qvten(k) = qvten(k) + prv_rev(k) + nrten(k) = nrten(k) - pnr_rev(k) + if (is_aerosol_aware) & + nwfaten(k) = nwfaten(k) + pnr_rev(k) + tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY) + + rr(k) = MAX(R1, (qr1d(k) + DT*qrten(k))*rho(k)) + qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) + nr(k) = MAX(R2, (nr1d(k) + DT*nrten(k))*rho(k)) + temp(k) = t1d(k) + DT*tten(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) endif enddo #if ( WRF_CHEM == 1 ) @@ -3780,176 +3751,175 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo if (ANY(L_qr .eqv. .true.)) then - do k = kte, kts, -1 - vtr = 0. - rhof(k) = SQRT(RHO_NOT/rho(k)) + do k = kte, kts, -1 + vtr = 0. + rhof(k) = SQRT(RHO_NOT/rho(k)) - if (rr(k).gt. R1) then - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) & - *((lamr+fv_r)**(-cre(6))) - vtrk(k) = vtr + if (rr(k).gt. R1) then + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) & + *((lamr+fv_r)**(-cre(6))) + vtrk(k) = vtr ! First below is technically correct: ! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) & ! *((lamr+fv_r)**(-cre(5))) ! Test: make number fall faster (but still slower than mass) ! Goal: less prominent size sorting - vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) & - *((lamr+fv_r)**(-cre(7))) - vtnrk(k) = vtr - else - vtrk(k) = vtrk(k+1) - vtnrk(k) = vtnrk(k+1) - endif + vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) & + *((lamr+fv_r)**(-cre(7))) + vtnrk(k) = vtr + else + vtrk(k) = vtrk(k+1) + vtnrk(k) = vtnrk(k+1) + endif - if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then - ksed1(1) = MAX(ksed1(1), k) - delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k))) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(1) .eq. kte) ksed1(1) = kte-1 - if (nstep .gt. 0) onstep(1) = 1./REAL(nstep) + if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then + ksed1(1) = MAX(ksed1(1), k) + delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k))) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(1) .eq. kte) ksed1(1) = kte-1 + if (nstep .gt. 0) onstep(1) = 1./REAL(nstep) endif !+---+-----------------------------------------------------------------+ if (ANY(L_qc .eqv. .true.)) then - hgt_agl = 0. - do k = kts, kte-1 - if (rc(k) .gt. R2) ksed1(5) = k - hgt_agl = hgt_agl + dzq(k) - if (hgt_agl .gt. 500.0) goto 151 - enddo - 151 continue - - do k = ksed1(5), kts, -1 - vtc = 0. - if (rc(k) .gt. R1 .and. w1d(k) .lt. 1.E-1) then - if (nc(k).gt.10000.E6) then - nu_c = 2 - elseif (nc(k).lt.100.) then - nu_c = 15 - else - nu_c = NINT(1000.E6/nc(k)) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) - endif - lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr - ilamc = 1./lamc - vtc = rhof(k)*av_c*ccg(5,nu_c)*ocg2(nu_c) * ilamc**bv_c - vtck(k) = vtc - vtc = rhof(k)*av_c*ccg(4,nu_c)*ocg1(nu_c) * ilamc**bv_c - vtnck(k) = vtc - endif - enddo + hgt_agl = 0. + do_loop_hgt_agl : do k = kts, kte-1 + if (rc(k) .gt. R2) ksed1(5) = k + hgt_agl = hgt_agl + dzq(k) + if (hgt_agl .gt. 500.0) exit do_loop_hgt_agl + enddo do_loop_hgt_agl + + do k = ksed1(5), kts, -1 + vtc = 0. + if (rc(k) .gt. R1 .and. w1d(k) .lt. 1.E-1) then + if (nc(k).gt.10000.E6) then + nu_c = 2 + elseif (nc(k).lt.100.) then + nu_c = 15 + else + nu_c = NINT(1000.E6/nc(k)) + 2 + nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + endif + lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr + ilamc = 1./lamc + vtc = rhof(k)*av_c*ccg(5,nu_c)*ocg2(nu_c) * ilamc**bv_c + vtck(k) = vtc + vtc = rhof(k)*av_c*ccg(4,nu_c)*ocg1(nu_c) * ilamc**bv_c + vtnck(k) = vtc + endif + enddo endif !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then - if (ANY(L_qi .eqv. .true.)) then - nstep = 0 - do k = kte, kts, -1 - vti = 0. - - if (ri(k).gt. R1) then - lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - ilami = 1./lami - vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i - vtik(k) = vti -! First below is technically correct: -! vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i -! Goal: less prominent size sorting - vti = rhof(k)*av_i*cig(6)/cig(7) * ilami**bv_i - vtnik(k) = vti - else - vtik(k) = vtik(k+1) - vtnik(k) = vtnik(k+1) - endif + if (ANY(L_qi .eqv. .true.)) then + nstep = 0 + do k = kte, kts, -1 + vti = 0. + + if (ri(k).gt. R1) then + lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi + ilami = 1./lami + vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i + vtik(k) = vti + ! First below is technically correct: + ! vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i + ! Goal: less prominent size sorting + vti = rhof(k)*av_i*cig(6)/cig(7) * ilami**bv_i + vtnik(k) = vti + else + vtik(k) = vtik(k+1) + vtnik(k) = vtnik(k+1) + endif - if (vtik(k) .gt. 1.E-3) then - ksed1(2) = MAX(ksed1(2), k) - delta_tp = dzq(k)/vtik(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(2) .eq. kte) ksed1(2) = kte-1 - if (nstep .gt. 0) onstep(2) = 1./REAL(nstep) - endif + if (vtik(k) .gt. 1.E-3) then + ksed1(2) = MAX(ksed1(2), k) + delta_tp = dzq(k)/vtik(k) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(2) .eq. kte) ksed1(2) = kte-1 + if (nstep .gt. 0) onstep(2) = 1./REAL(nstep) + endif !+---+-----------------------------------------------------------------+ if (ANY(L_qs .eqv. .true.)) then - nstep = 0 - do k = kte, kts, -1 - vts = 0. - !vtsk1(k)=0. - - if (rs(k).gt. R1) then - xDs = smoc(k) / smob(k) - Mrat = 1./xDs - ils1 = 1./(Mrat*Lam0 + fv_s) - ils2 = 1./(Mrat*Lam1 + fv_s) - t1_vts = Kap0*csg(4)*ils1**cse(4) - t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10) - ils1 = 1./(Mrat*Lam0) - ils2 = 1./(Mrat*Lam1) - t3_vts = Kap0*csg(1)*ils1**cse(1) - t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) - vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (prr_sml(k) .gt. 0.0) then -! vtsk(k) = MAX(vts*vts_boost(k), & -! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) - SR = rs(k)/(rs(k)+rr(k)) - vtsk(k) = vts*SR + (1.-SR)*vtrk(k) - !vtsk1(k)=vtsk(k) - else - vtsk(k) = vts*vts_boost(k) - !vtsk1(k)=vtsk(k) - endif - else - vtsk(k) = vtsk(k+1) - !vtsk1(k)=0 - endif + nstep = 0 + do k = kte, kts, -1 + vts = 0. + !vtsk1(k)=0. + + if (rs(k).gt. R1) then + xDs = smoc(k) / smob(k) + Mrat = 1./xDs + ils1 = 1./(Mrat*Lam0 + fv_s) + ils2 = 1./(Mrat*Lam1 + fv_s) + t1_vts = Kap0*csg(4)*ils1**cse(4) + t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10) + ils1 = 1./(Mrat*Lam0) + ils2 = 1./(Mrat*Lam1) + t3_vts = Kap0*csg(1)*ils1**cse(1) + t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) + vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) + if (prr_sml(k) .gt. 0.0) then + ! vtsk(k) = MAX(vts*vts_boost(k), & + ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) + SR = rs(k)/(rs(k)+rr(k)) + vtsk(k) = vts*SR + (1.-SR)*vtrk(k) + !vtsk1(k)=vtsk(k) + else + vtsk(k) = vts*vts_boost(k) + !vtsk1(k)=vtsk(k) + endif + else + vtsk(k) = vtsk(k+1) + !vtsk1(k)=0 + endif - if (vtsk(k) .gt. 1.E-3) then - ksed1(3) = MAX(ksed1(3), k) - delta_tp = dzq(k)/vtsk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(3) .eq. kte) ksed1(3) = kte-1 - if (nstep .gt. 0) onstep(3) = 1./REAL(nstep) + if (vtsk(k) .gt. 1.E-3) then + ksed1(3) = MAX(ksed1(3), k) + delta_tp = dzq(k)/vtsk(k) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(3) .eq. kte) ksed1(3) = kte-1 + if (nstep .gt. 0) onstep(3) = 1./REAL(nstep) endif !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then - nstep = 0 - do k = kte, kts, -1 - vtg = 0. - - if (rg(k).gt. R1) then - vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g - if (temp(k).gt. T_0) then - vtgk(k) = MAX(vtg, vtrk(k)) - else - vtgk(k) = vtg - endif - else - vtgk(k) = vtgk(k+1) - endif + nstep = 0 + do k = kte, kts, -1 + vtg = 0. - if (vtgk(k) .gt. 1.E-3) then - ksed1(4) = MAX(ksed1(4), k) - delta_tp = dzq(k)/vtgk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) - endif - enddo - if (ksed1(4) .eq. kte) ksed1(4) = kte-1 - if (nstep .gt. 0) onstep(4) = 1./REAL(nstep) - endif + if (rg(k).gt. R1) then + vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g + if (temp(k).gt. T_0) then + vtgk(k) = MAX(vtg, vtrk(k)) + else + vtgk(k) = vtg + endif + else + vtgk(k) = vtgk(k+1) + endif + + if (vtgk(k) .gt. 1.E-3) then + ksed1(4) = MAX(ksed1(4), k) + delta_tp = dzq(k)/vtgk(k) + nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + endif + enddo + if (ksed1(4) .eq. kte) ksed1(4) = kte-1 + if (nstep .gt. 0) onstep(4) = 1./REAL(nstep) + endif endif !+---+-----------------------------------------------------------------+ @@ -3959,230 +3929,234 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qr .eqv. .true.)) then - nstep = NINT(1./onstep(1)) + nstep = NINT(1./onstep(1)) - if(.not. sedi_semi) then - do n = 1, nstep - do k = kte, kts, -1 - sed_r(k) = vtrk(k)*rr(k) - sed_n(k) = vtnrk(k)*nr(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho - nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1)) - nr(k) = MAX(R2, nr(k) - sed_n(k)*odzq*DT*onstep(1)) - pfll1(k) = pfll1(k) + sed_r(k)*DT*onstep(1) - do k = ksed1(1), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*onstep(1)*orho - nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & - *odzq*DT*onstep(1)) - nr(k) = MAX(R2, nr(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*DT*onstep(1)) - pfll1(k) = pfll1(k) + sed_r(k)*DT*onstep(1) - enddo + if(.not. sedi_semi) then + do n = 1, nstep + do k = kte, kts, -1 + sed_r(k) = vtrk(k)*rr(k) + sed_n(k) = vtnrk(k)*nr(k) + enddo + k = kte + odzq = 1./dzq(k) + orho = 1./rho(k) + qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho + nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho + rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1)) + nr(k) = MAX(R2, nr(k) - sed_n(k)*odzq*DT*onstep(1)) + pfll1(k) = pfll1(k) + sed_r(k)*DT*onstep(1) + do k = ksed1(1), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) & + *odzq*onstep(1)*orho + nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*onstep(1)*orho + rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & + *odzq*DT*onstep(1)) + nr(k) = MAX(R2, nr(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*DT*onstep(1)) + pfll1(k) = pfll1(k) + sed_r(k)*DT*onstep(1) + enddo - if (rr(kts).gt.R1*1000.) & - pptrain = pptrain + sed_r(kts)*DT*onstep(1) - enddo - else !if(.not. sedi_semi) - niter = 1 - dtcfl = dt - niter = int(nstep/max(decfl,1)) + 1 - dtcfl = dt/niter - do n = 1, niter - rr_tmp(:) = rr(:) - nr_tmp(:) = nr(:) - call semi_lagrange_sedim(kte,dzq,vtrk,rr,rainsfc,pfll,dtcfl,R1) - call semi_lagrange_sedim(kte,dzq,vtnrk,nr,vtr,pdummy,dtcfl,R2) - do k = kts, kte - orhodt = 1./(rho(k)*dt) - qrten(k) = qrten(k) + (rr(k) - rr_tmp(k)) * orhodt - nrten(k) = nrten(k) + (nr(k) - nr_tmp(k)) * orhodt - pfll1(k) = pfll1(k) + pfll(k) - enddo - pptrain = pptrain + rainsfc + if (rr(kts).gt.R1*1000.) then + pptrain = pptrain + sed_r(kts)*DT*onstep(1) + endif + enddo + else !if(.not. sedi_semi) + niter = 1 + dtcfl = dt + niter = int(nstep/max(decfl,1)) + 1 + dtcfl = dt/niter + do n = 1, niter + rr_tmp(:) = rr(:) + nr_tmp(:) = nr(:) + call semi_lagrange_sedim(kte,dzq,vtrk,rr,rainsfc,pfll,dtcfl,R1) + call semi_lagrange_sedim(kte,dzq,vtnrk,nr,vtr,pdummy,dtcfl,R2) + do k = kts, kte + orhodt = 1./(rho(k)*dt) + qrten(k) = qrten(k) + (rr(k) - rr_tmp(k)) * orhodt + nrten(k) = nrten(k) + (nr(k) - nr_tmp(k)) * orhodt + pfll1(k) = pfll1(k) + pfll(k) + enddo + pptrain = pptrain + rainsfc - do k = kte+1, kts, -1 - vtrk(k) = 0. - vtnrk(k) = 0. - enddo - do k = kte, kts, -1 - vtr = 0. - if (rr(k).gt. R1) then - lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr - vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) & - *((lamr+fv_r)**(-cre(6))) - vtrk(k) = vtr - ! First below is technically correct: - ! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) & - ! *((lamr+fv_r)**(-cre(5))) - ! Test: make number fall faster (but still slower than mass) - ! Goal: less prominent size sorting - vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) & - *((lamr+fv_r)**(-cre(7))) - vtnrk(k) = vtr - endif - enddo - enddo - endif! if(.not. sedi_semi) + do k = kte+1, kts, -1 + vtrk(k) = 0. + vtnrk(k) = 0. + enddo + do k = kte, kts, -1 + vtr = 0. + if (rr(k).gt. R1) then + lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr + vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) & + *((lamr+fv_r)**(-cre(6))) + vtrk(k) = vtr + ! First below is technically correct: + ! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) & + ! *((lamr+fv_r)**(-cre(5))) + ! Test: make number fall faster (but still slower than mass) + ! Goal: less prominent size sorting + vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) & + *((lamr+fv_r)**(-cre(7))) + vtnrk(k) = vtr + endif + enddo + enddo + endif! if(.not. sedi_semi) endif !+---+-----------------------------------------------------------------+ if (ANY(L_qc .eqv. .true.)) then - do k = kte, kts, -1 - sed_c(k) = vtck(k)*rc(k) - sed_n(k) = vtnck(k)*nc(k) - enddo - do k = ksed1(5), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qcten(k) = qcten(k) + (sed_c(k+1)-sed_c(k)) *odzq*orho - ncten(k) = ncten(k) + (sed_n(k+1)-sed_n(k)) *odzq*orho - rc(k) = MAX(R1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*DT) - nc(k) = MAX(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*DT) - enddo + do k = kte, kts, -1 + sed_c(k) = vtck(k)*rc(k) + sed_n(k) = vtnck(k)*nc(k) + enddo + do k = ksed1(5), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qcten(k) = qcten(k) + (sed_c(k+1)-sed_c(k)) *odzq*orho + ncten(k) = ncten(k) + (sed_n(k+1)-sed_n(k)) *odzq*orho + rc(k) = MAX(R1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*DT) + nc(k) = MAX(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*DT) + enddo endif !+---+-----------------------------------------------------------------+ if (ANY(L_qi .eqv. .true.)) then - nstep = NINT(1./onstep(2)) - do n = 1, nstep - do k = kte, kts, -1 - sed_i(k) = vtik(k)*ri(k) - sed_n(k) = vtnik(k)*ni(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho - niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2)) - ni(k) = MAX(R2, ni(k) - sed_n(k)*odzq*DT*onstep(2)) - pfil1(k) = pfil1(k) + sed_i(k)*DT*onstep(2) - do k = ksed1(2), kts, -1 + nstep = NINT(1./onstep(2)) + do n = 1, nstep + do k = kte, kts, -1 + sed_i(k) = vtik(k)*ri(k) + sed_n(k) = vtnik(k)*ni(k) + enddo + k = kte odzq = 1./dzq(k) orho = 1./rho(k) - qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*onstep(2)*orho - niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & - *odzq*DT*onstep(2)) - ni(k) = MAX(R2, ni(k) + (sed_n(k+1)-sed_n(k)) & - *odzq*DT*onstep(2)) + qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho + niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho + ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2)) + ni(k) = MAX(R2, ni(k) - sed_n(k)*odzq*DT*onstep(2)) pfil1(k) = pfil1(k) + sed_i(k)*DT*onstep(2) - enddo + do k = ksed1(2), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) & + *odzq*onstep(2)*orho + niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*onstep(2)*orho + ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & + *odzq*DT*onstep(2)) + ni(k) = MAX(R2, ni(k) + (sed_n(k+1)-sed_n(k)) & + *odzq*DT*onstep(2)) + pfil1(k) = pfil1(k) + sed_i(k)*DT*onstep(2) + enddo - if (ri(kts).gt.R1*1000.) & - pptice = pptice + sed_i(kts)*DT*onstep(2) - enddo + if (ri(kts).gt.R1*1000.) then + pptice = pptice + sed_i(kts)*DT*onstep(2) + endif + enddo endif !+---+-----------------------------------------------------------------+ if (ANY(L_qs .eqv. .true.)) then - nstep = NINT(1./onstep(3)) - do n = 1, nstep - do k = kte, kts, -1 - sed_s(k) = vtsk(k)*rs(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3)) - pfil1(k) = pfil1(k) + sed_s(k)*DT*onstep(3) - do k = ksed1(3), kts, -1 + nstep = NINT(1./onstep(3)) + do n = 1, nstep + do k = kte, kts, -1 + sed_s(k) = vtsk(k)*rs(k) + enddo + k = kte odzq = 1./dzq(k) orho = 1./rho(k) - qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & - *odzq*DT*onstep(3)) + qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho + rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3)) pfil1(k) = pfil1(k) + sed_s(k)*DT*onstep(3) - enddo + do k = ksed1(3), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & + *odzq*onstep(3)*orho + rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & + *odzq*DT*onstep(3)) + pfil1(k) = pfil1(k) + sed_s(k)*DT*onstep(3) + enddo - if (rs(kts).gt.R1*1000.) & - pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) - enddo + if (rs(kts).gt.R1*1000.) then + pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) + endif + enddo endif !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then - nstep = NINT(1./onstep(4)) - if(.not. sedi_semi) then - do n = 1, nstep - do k = kte, kts, -1 - sed_g(k) = vtgk(k)*rg(k) - enddo - k = kte - odzq = 1./dzq(k) - orho = 1./rho(k) - qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4)) - pfil1(k) = pfil1(k) + sed_g(k)*DT*onstep(4) - do k = ksed1(4), kts, -1 - odzq = 1./dzq(k) - orho = 1./rho(k) - qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & - *odzq*DT*onstep(4)) - pfil1(k) = pfil1(k) + sed_g(k)*DT*onstep(4) - enddo + nstep = NINT(1./onstep(4)) + if(.not. sedi_semi) then + do n = 1, nstep + do k = kte, kts, -1 + sed_g(k) = vtgk(k)*rg(k) + enddo + k = kte + odzq = 1./dzq(k) + orho = 1./rho(k) + qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho + rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4)) + pfil1(k) = pfil1(k) + sed_g(k)*DT*onstep(4) + do k = ksed1(4), kts, -1 + odzq = 1./dzq(k) + orho = 1./rho(k) + qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & + *odzq*onstep(4)*orho + rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & + *odzq*DT*onstep(4)) + pfil1(k) = pfil1(k) + sed_g(k)*DT*onstep(4) + enddo - if (rg(kts).gt.R1*1000.) & - pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) - enddo - else ! if(.not. sedi_semi) then - niter = 1 - dtcfl = dt - niter = int(nstep/max(decfl,1)) + 1 - dtcfl = dt/niter - - do n = 1, niter - rg_tmp(:) = rg(:) - call semi_lagrange_sedim(kte,dzq,vtgk,rg,graulsfc,pfil,dtcfl,R1) - do k = kts, kte - orhodt = 1./(rho(k)*dt) - qgten(k) = qgten(k) + (rg(k) - rg_tmp(k))*orhodt - pfil1(k) = pfil1(k) + pfil(k) - enddo - pptgraul = pptgraul + graulsfc - do k = kte+1, kts, -1 - vtgk(k) = 0. - enddo - do k = kte, kts, -1 - vtg = 0. - if (rg(k).gt. R1) then - ygra1 = alog10(max(1.E-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 - N0_exp = 10.**(zans1) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - - vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g - if (temp(k).gt. T_0) then - vtgk(k) = MAX(vtg, vtrk(k)) - else - vtgk(k) = vtg - endif - endif - enddo - enddo - endif ! if(.not. sedi_semi) then + if (rg(kts).gt.R1*1000.) then + pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) + endif + enddo + else ! if(.not. sedi_semi) then + niter = 1 + dtcfl = dt + niter = int(nstep/max(decfl,1)) + 1 + dtcfl = dt/niter + + do n = 1, niter + rg_tmp(:) = rg(:) + call semi_lagrange_sedim(kte,dzq,vtgk,rg,graulsfc,pfil,dtcfl,R1) + do k = kts, kte + orhodt = 1./(rho(k)*dt) + qgten(k) = qgten(k) + (rg(k) - rg_tmp(k))*orhodt + pfil1(k) = pfil1(k) + pfil(k) + enddo + pptgraul = pptgraul + graulsfc + do k = kte+1, kts, -1 + vtgk(k) = 0. + enddo + do k = kte, kts, -1 + vtg = 0. + if (rg(k).gt. R1) then + ygra1 = alog10(max(1.E-9, rg(k))) + zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + N0_exp = 10.**(zans1) + N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + + vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g + if (temp(k).gt. T_0) then + vtgk(k) = MAX(vtg, vtrk(k)) + else + vtgk(k) = vtg + endif + endif + enddo + enddo + endif ! if(.not. sedi_semi) then endif !+---+-----------------------------------------------------------------+ @@ -4190,31 +4164,31 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! instantly freeze any cloud water found below HGFR. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then - do k = kts, kte - xri = MAX(0.0, qi1d(k) + qiten(k)*DT) - if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then - qcten(k) = qcten(k) + xri*odt - ncten(k) = ncten(k) + ni1d(k)*odt - qiten(k) = qiten(k) - xri*odt - niten(k) = -ni1d(k)*odt - tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) -!diag - !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) - endif + do k = kts, kte + xri = MAX(0.0, qi1d(k) + qiten(k)*DT) + if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then + qcten(k) = qcten(k) + xri*odt + ncten(k) = ncten(k) + ni1d(k)*odt + qiten(k) = qiten(k) - xri*odt + niten(k) = -ni1d(k)*odt + tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) + !diag + !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) + endif - xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) - if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then - lfus2 = lsub - lvap(k) - xnc = nc1d(k) + ncten(k)*DT - qiten(k) = qiten(k) + xrc*odt - niten(k) = niten(k) + xnc*odt - qcten(k) = qcten(k) - xrc*odt - ncten(k) = ncten(k) - xnc*odt - tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) -!diag - !txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT - endif - enddo + xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) + if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then + lfus2 = lsub - lvap(k) + xnc = nc1d(k) + ncten(k)*DT + qiten(k) = qiten(k) + xrc*odt + niten(k) = niten(k) + xnc*odt + qcten(k) = qcten(k) - xrc*odt + ncten(k) = ncten(k) - xnc*odt + tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) + !diag + !txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT + endif + enddo endif !+---+-----------------------------------------------------------------+ @@ -4226,66 +4200,66 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qc1d(k) = qc1d(k) + qcten(k)*DT nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) if (is_aerosol_aware) then - nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & - (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & - (nifa1d(k)+nifaten(k)*DT))) + nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & + (nwfa1d(k)+nwfaten(k)*DT))) + nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & + (nifa1d(k)+nifaten(k)*DT))) end if if (qc1d(k) .le. R1) then - qc1d(k) = 0.0 - nc1d(k) = 0.0 + qc1d(k) = 0.0 + nc1d(k) = 0.0 else - if (nc1d(k)*rho(k).gt.10000.E6) then - nu_c = 2 - elseif (nc1d(k)*rho(k).lt.100.) then - nu_c = 15 - else - nu_c = NINT(1000.E6/(nc1d(k)*rho(k))) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) - endif - lamc = (am_r*ccg(2,nu_c)*ocg1(nu_c)*nc1d(k)/qc1d(k))**obmr - xDc = (bm_r + nu_c + 1.) / lamc - if (xDc.lt. D0c) then - lamc = cce(2,nu_c)/D0c - elseif (xDc.gt. D0r*2.) then - lamc = cce(2,nu_c)/(D0r*2.) - endif - nc1d(k) = MIN(ccg(1,nu_c)*ocg2(nu_c)*qc1d(k)/am_r*lamc**bm_r,& - DBLE(Nt_c_max)/rho(k)) + if (nc1d(k)*rho(k).gt.10000.E6) then + nu_c = 2 + elseif (nc1d(k)*rho(k).lt.100.) then + nu_c = 15 + else + nu_c = NINT(1000.E6/(nc1d(k)*rho(k))) + 2 + nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + endif + lamc = (am_r*ccg(2,nu_c)*ocg1(nu_c)*nc1d(k)/qc1d(k))**obmr + xDc = (bm_r + nu_c + 1.) / lamc + if (xDc.lt. D0c) then + lamc = cce(2,nu_c)/D0c + elseif (xDc.gt. D0r*2.) then + lamc = cce(2,nu_c)/(D0r*2.) + endif + nc1d(k) = MIN(ccg(1,nu_c)*ocg2(nu_c)*qc1d(k)/am_r*lamc**bm_r,& + DBLE(Nt_c_max)/rho(k)) endif qi1d(k) = qi1d(k) + qiten(k)*DT ni1d(k) = MAX(R2/rho(k), ni1d(k) + niten(k)*DT) if (qi1d(k) .le. R1) then - qi1d(k) = 0.0 - ni1d(k) = 0.0 + qi1d(k) = 0.0 + ni1d(k) = 0.0 else - lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi - ilami = 1./lami - xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 5.E-6) then - lami = cie(2)/5.E-6 - elseif (xDi.gt. 300.E-6) then - lami = cie(2)/300.E-6 - endif - ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 4999.D3/rho(k)) + lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi + ilami = 1./lami + xDi = (bm_i + mu_i + 1.) * ilami + if (xDi.lt. 5.E-6) then + lami = cie(2)/5.E-6 + elseif (xDi.gt. 300.E-6) then + lami = cie(2)/300.E-6 + endif + ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & + 4999.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) if (qr1d(k) .le. R1) then - qr1d(k) = 0.0 - nr1d(k) = 0.0 + qr1d(k) = 0.0 + nr1d(k) = 0.0 else - lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr - mvd_r(k) = (3.0 + mu_r + 0.672) / lamr - if (mvd_r(k) .gt. 2.5E-3) then - mvd_r(k) = 2.5E-3 - elseif (mvd_r(k) .lt. D0r*0.75) then - mvd_r(k) = D0r*0.75 - endif - lamr = (3.0 + mu_r + 0.672) / mvd_r(k) - nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r + lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr + mvd_r(k) = (3.0 + mu_r + 0.672) / lamr + if (mvd_r(k) .gt. 2.5E-3) then + mvd_r(k) = 2.5E-3 + elseif (mvd_r(k) .lt. D0r*0.75) then + mvd_r(k) = D0r*0.75 + endif + lamr = (3.0 + mu_r + 0.672) / mvd_r(k) + nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r endif qs1d(k) = qs1d(k) + qsten(k)*DT if (qs1d(k) .le. R1) qs1d(k) = 0.0 @@ -4375,8 +4349,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qcten1(k) = qcten(k)*DT enddo endif calculate_extended_diagnostics - - end subroutine mp_thompson + + end subroutine mp_thompson !>@} !+---+-----------------------------------------------------------------+ @@ -4386,20 +4360,20 @@ end subroutine mp_thompson !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! Rain collecting graupel (and inverse). Explicit CE integration. - subroutine qr_acr_qg + subroutine qr_acr_qg implicit none !..Local variables - INTEGER:: i, j, k, m, n, n2 - INTEGER:: km, km_s, km_e - DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g - DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r - DOUBLE PRECISION:: N0_r, N0_g, lam_exp, lamg, lamr - DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2 - LOGICAL force_read_thompson, write_thompson_tables - LOGICAL lexist,lopen - INTEGER good,ierr + integer:: i, j, k, m, n, n2 + integer:: km, km_s, km_e + real(kind_dbl_prec), dimension(nbg):: vg, N_g + real(kind_dbl_prec), dimension(nbr):: vr, N_r + real(kind_dbl_prec) :: N0_r, N0_g, lam_exp, lamg, lamr + real(kind_dbl_prec) :: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2 + logical force_read_thompson, write_thompson_tables + logical lexist,lopen + integer good,ierr force_read_thompson = .false. write_thompson_tables = .false. @@ -4552,29 +4526,29 @@ subroutine qr_acr_qg ENDIF ENDIF - end subroutine qr_acr_qg + end subroutine qr_acr_qg !+---+-----------------------------------------------------------------+ !ctrlL !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !!Rain collecting snow (and inverse). Explicit CE integration. - subroutine qr_acr_qs + subroutine qr_acr_qs implicit none !..Local variables - INTEGER:: i, j, k, m, n, n2 - INTEGER:: km, km_s, km_e - DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r - DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s - DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 - DOUBLE PRECISION:: N0_r, lam_exp, lamr, slam1, slam2 - DOUBLE PRECISION:: dvs, dvr, masss, massr - DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4 - DOUBLE PRECISION:: y1, y2, y3, y4 - LOGICAL force_read_thompson, write_thompson_tables - LOGICAL lexist,lopen - INTEGER good,ierr + integer:: i, j, k, m, n, n2 + integer:: km, km_s, km_e + real(kind_dbl_prec), dimension(nbr):: vr, D1, N_r + real(kind_dbl_prec), dimension(nbs):: vs, N_s + real(kind_dbl_prec) :: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 + real(kind_dbl_prec) :: N0_r, lam_exp, lamr, slam1, slam2 + real(kind_dbl_prec) :: dvs, dvr, masss, massr + real(kind_dbl_prec) :: t1, t2, t3, t4, z1, z2, z3, z4 + real(kind_dbl_prec) :: y1, y2, y3, y4 + logical force_read_thompson, write_thompson_tables + logical lexist,lopen + integer good,ierr !+---+ @@ -4809,7 +4783,7 @@ subroutine qr_acr_qs ENDIF ENDIF - end subroutine qr_acr_qs + end subroutine qr_acr_qs !+---+-----------------------------------------------------------------+ !ctrlL !+---+-----------------------------------------------------------------+ @@ -4817,26 +4791,26 @@ end subroutine qr_acr_qs !! This is a literal adaptation of Bigg (1954) probability of drops of !! a particular volume freezing. Given this probability, simply freeze !! the proportion of drops summing their masses. - subroutine freezeH2O(threads) + subroutine freezeH2O(threads) implicit none !..Interface variables - INTEGER, INTENT(IN):: threads + integer, intent(in):: threads !..Local variables - INTEGER:: i, j, k, m, n, n2 - DOUBLE PRECISION:: N_r, N_c - DOUBLE PRECISION, DIMENSION(nbr):: massr - DOUBLE PRECISION, DIMENSION(nbc):: massc - DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & + integer:: i, j, k, m, n, n2 + real(kind_dbl_prec) :: N_r, N_c + real(kind_dbl_prec), dimension(nbr):: massr + real(kind_dbl_prec), dimension(nbc):: massc + real(kind_dbl_prec) :: sum1, sum2, sumn1, sumn2, & prob, vol, Texp, orho_w, & lam_exp, lamr, N0_r, lamc, N0_c, y - INTEGER:: nu_c + integer:: nu_c REAL:: T_adjust - LOGICAL force_read_thompson, write_thompson_tables - LOGICAL lexist,lopen - INTEGER good,ierr + logical force_read_thompson, write_thompson_tables + logical lexist,lopen + integer good,ierr !+---+ force_read_thompson = .false. @@ -4982,7 +4956,7 @@ subroutine freezeH2O(threads) ENDIF ENDIF - end subroutine freezeH2O + end subroutine freezeH2O !+---+-----------------------------------------------------------------+ !ctrlL @@ -4996,14 +4970,14 @@ end subroutine freezeH2O !! of ice depositional growth from diameter=0 to D0s. Amount of !! ice depositional growth is this portion of distrib while larger !! diameters contribute to snow growth (as in Harrington et al. 1995). - subroutine qi_aut_qs + subroutine qi_aut_qs implicit none !..Local variables - INTEGER:: i, j, n2 - DOUBLE PRECISION, DIMENSION(nbi):: N_i - DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2 + integer:: i, j, n2 + real(kind_dbl_prec), dimension(nbi):: N_i + real(kind_dbl_prec) :: N0_i, lami, Di_mean, t1, t2 REAL:: xlimit_intg !+---+ @@ -5039,21 +5013,21 @@ subroutine qi_aut_qs enddo enddo - end subroutine qi_aut_qs + end subroutine qi_aut_qs !ctrlL !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! Variable collision efficiency for rain collecting cloud water using !! method of Beard and Grover, 1974 if a/A less than 0.25; otherwise !! uses polynomials to get close match of Pruppacher & Klett Fig 14-9. - subroutine table_Efrw + subroutine table_Efrw implicit none !..Local variables - DOUBLE PRECISION:: vtr, stokes, reynolds, Ef_rw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0, X - INTEGER:: i, j + real(kind_dbl_prec) :: vtr, stokes, reynolds, Ef_rw + real(kind_dbl_prec) :: p, yc0, F, G, H, z, K0, X + integer:: i, j do j = 1, nbc do i = 1, nbr @@ -5102,21 +5076,21 @@ subroutine table_Efrw enddo enddo - end subroutine table_Efrw + end subroutine table_Efrw !ctrlL !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! Variable collision efficiency for snow collecting cloud water using !! method of Wang and Ji, 2000 except equate melted snow diameter to !! their "effective collision cross-section." - subroutine table_Efsw + subroutine table_Efsw implicit none !..Local variables - DOUBLE PRECISION:: Ds_m, vts, vtc, stokes, reynolds, Ef_sw - DOUBLE PRECISION:: p, yc0, F, G, H, z, K0 - INTEGER:: i, j + real(kind_dbl_prec) :: Ds_m, vts, vtc, stokes, reynolds, Ef_sw + real(kind_dbl_prec) :: p, yc0, F, G, H, z, K0 + integer:: i, j do j = 1, nbc vtc = 1.19D4 * (1.0D4*Dc(j)*Dc(j)*0.25D0) @@ -5145,21 +5119,21 @@ subroutine table_Efsw enddo enddo - end subroutine table_Efsw + end subroutine table_Efsw !ctrlL !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! Function to compute collision efficiency of collector species (rain, !! snow, graupel) of aerosols. Follows Wang et al, 2010, ACP, which !! follows Slinn (1983). - real function Eff_aero(D, Da, visc,rhoa,Temp,species) + real function Eff_aero(D, Da, visc,rhoa,Temp,species) implicit none real:: D, Da, visc, rhoa, Temp character(LEN=1):: species real:: aval, Cc, diff, Re, Sc, St, St2, vt, Eff - real, parameter:: boltzman = 1.3806503E-23 - real, parameter:: meanPath = 0.0256E-6 + real(kind_phys), parameter:: boltzman = 1.3806503E-23 + real(kind_phys), parameter:: meanPath = 0.0256E-6 vt = 1. if (species .eq. 'r') then @@ -5188,7 +5162,7 @@ real function Eff_aero(D, Da, visc,rhoa,Temp,species) if (St.gt.St2) Eff = Eff + ( (St-St2)/(St-St2+0.666667))**1.5 Eff_aero = MAX(1.E-5, MIN(Eff, 1.0)) - end function Eff_aero + end function Eff_aero !ctrlL !+---+-----------------------------------------------------------------+ @@ -5197,16 +5171,16 @@ end function Eff_aero !! number of drops smaller than D-star that evaporate in a single !! timestep. Drops larger than D-star dont evaporate entirely so do !! not affect number concentration. - subroutine table_dropEvap + subroutine table_dropEvap implicit none !..Local variables - INTEGER:: i, j, k, n - DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc - DOUBLE PRECISION:: summ, summ2, lamc, N0_c - INTEGER:: nu_c -! DOUBLE PRECISION:: Nt_r, N0, lam_exp, lam + integer:: i, j, k, n + real(kind_dbl_prec), dimension(nbc):: N_c, massc + real(kind_dbl_prec) :: summ, summ2, lamc, N0_c + integer:: nu_c +! real(kind_dbl_prec) :: Nt_r, N0, lam_exp, lam ! REAL:: xlimit_intg do n = 1, nbc @@ -5285,7 +5259,7 @@ subroutine table_dropEvap ! pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M ! * odts)) - end subroutine table_dropEvap + end subroutine table_dropEvap ! !ctrlL !+---+-----------------------------------------------------------------+ @@ -5295,17 +5269,17 @@ end subroutine table_dropEvap !! vertical velocity, temperature, lognormal mean aerosol radius, and !! hygroscopicity, kappa. The data are read from external file and !! contain activated fraction of CCN for given conditions. - subroutine table_ccnAct(errmess,errflag) + subroutine table_ccnAct(errmess,errflag) implicit none !..Error handling variables - CHARACTER(len=*), INTENT(INOUT) :: errmess - INTEGER, INTENT(INOUT) :: errflag + character(len=*), intent(inout) :: errmess + integer, intent(inout) :: errflag !..Local variables - INTEGER:: iunit_mp_th1, i - LOGICAL:: opened + integer:: iunit_mp_th1, i + logical:: opened iunit_mp_th1 = -1 DO i = 20,99 @@ -5340,7 +5314,7 @@ subroutine table_ccnAct(errmess,errflag) errflag = 1 RETURN - end subroutine table_ccnAct + end subroutine table_ccnAct !>\ingroup aathompson !! Retrieve fraction of CCN that gets activated given the model temp, @@ -5351,15 +5325,15 @@ end subroutine table_ccnAct ! TO_DO ITEM: For radiation cooling producing fog, in which case the !.. updraft velocity could easily be negative, we could use the temp !.. and its tendency to diagnose a pretend postive updraft velocity. - real function activ_ncloud(Tt, Ww, NCCN, lsm_in) + real function activ_ncloud(Tt, Ww, NCCN, lsm_in) implicit none - REAL, INTENT(IN):: Tt, Ww, NCCN - INTEGER, INTENT(IN):: lsm_in - REAL:: n_local, w_local - INTEGER:: i, j, k, l, m, n - REAL:: A, B, C, D, t, u, x1, x2, y1, y2, nx, wy, fraction - REAL:: lower_lim_nuc_frac + real(kind_phys), intent(in):: Tt, Ww, NCCN + integer, intent(in):: lsm_in + real(kind_phys):: n_local, w_local + integer:: i, j, k, l, m, n + real(kind_phys):: A, B, C, D, t, u, x1, x2, y1, y2, nx, wy, fraction + real(kind_phys):: lower_lim_nuc_frac ! ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) ntb_arc ! ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) ntb_arw @@ -5436,27 +5410,27 @@ real function activ_ncloud(Tt, Ww, NCCN, lsm_in) activ_ncloud = NCCN*fraction - end function activ_ncloud + end function activ_ncloud !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! Returns the incomplete gamma function q(a,x) evaluated by its !! continued fraction representation as gammcf. - SUBROUTINE GCF(GAMMCF,A,X,GLN) + SUBROUTINE GCF(GAMMCF,A,X,GLN) ! RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS ! CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS ! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY ! --- A MODIFIED LENTZ METHOD. ! --- USES GAMMLN IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, PARAMETER:: FPMIN=1.E-30 - REAL, INTENT(IN):: A, X - REAL:: GAMMCF,GLN - INTEGER:: I - REAL:: AN,B,C,D,DEL,H + integer, parameter:: ITMAX=100 + real(kind_phys), parameter:: gEPS=3.E-7 + real(kind_phys), parameter:: FPMIN=1.E-30 + real(kind_phys), intent(in):: A, X + real(kind_phys):: GAMMCF,GLN + integer:: I + real(kind_phys):: AN,B,C,D,DEL,H GLN=GAMMLN(A) B=X+1.-A C=1./FPMIN @@ -5476,24 +5450,24 @@ SUBROUTINE GCF(GAMMCF,A,X,GLN) 11 CONTINUE PRINT *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF' 1 GAMMCF=EXP(-X+A*LOG(X)-GLN)*H - END SUBROUTINE GCF + END SUBROUTINE GCF ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !>\ingroup aathompson !! Returns the incomplete gamma function p(a,x) evaluated by !! its series representation as gamser. - SUBROUTINE GSER(GAMSER,A,X,GLN) + SUBROUTINE GSER(GAMSER,A,X,GLN) ! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS ! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A)) ! --- AS GLN. ! --- USES GAMMLN IMPLICIT NONE - INTEGER, PARAMETER:: ITMAX=100 - REAL, PARAMETER:: gEPS=3.E-7 - REAL, INTENT(IN):: A, X - REAL:: GAMSER,GLN - INTEGER:: N - REAL:: AP,DEL,SUM + integer, parameter:: ITMAX=100 + real(kind_phys), parameter:: gEPS=3.E-7 + real(kind_phys), intent(in):: A, X + real(kind_phys):: GAMSER,GLN + integer:: N + real(kind_phys):: AP,DEL,SUM GLN=GAMMLN(A) IF(X.LE.0.)THEN IF(X.LT.0.) PRINT *, 'X < 0 IN GSER' @@ -5511,22 +5485,22 @@ SUBROUTINE GSER(GAMSER,A,X,GLN) 11 CONTINUE PRINT *,'A TOO LARGE, ITMAX TOO SMALL IN GSER' 1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN) - END SUBROUTINE GSER + END SUBROUTINE GSER ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !>\ingroup aathompson !! Returns the value ln(gamma(xx)) for xx > 0. - REAL FUNCTION GAMMLN(XX) + REAL FUNCTION GAMMLN(XX) ! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. IMPLICIT NONE - REAL, INTENT(IN):: XX - DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 - DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & + real(kind_phys), intent(in):: XX + real(kind_dbl_prec), parameter:: STP = 2.5066282746310005D0 + real(kind_dbl_prec), dimension(6), parameter:: & COF = (/76.18009172947146D0, -86.50532032941677D0, & 24.01409824083091D0, -1.231739572450155D0, & .1208650973866179D-2, -.5395239384953D-5/) - DOUBLE PRECISION:: SER,TMP,X,Y - INTEGER:: J + real(kind_dbl_prec) :: SER,TMP,X,Y + integer:: J X=XX Y=X @@ -5538,17 +5512,17 @@ REAL FUNCTION GAMMLN(XX) SER=SER+COF(J)/Y 11 CONTINUE GAMMLN=TMP+LOG(STP*SER/X) - END FUNCTION GAMMLN + END FUNCTION GAMMLN ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !>\ingroup aathompson - REAL FUNCTION GAMMP(A,X) + REAL FUNCTION GAMMP(A,X) ! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X) ! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 ! --- USES GCF,GSER IMPLICIT NONE - REAL, INTENT(IN):: A,X - REAL:: GAMMCF,GAMSER,GLN + real(kind_phys), intent(in):: A,X + real(kind_phys):: GAMMCF,GAMSER,GLN GAMMP = 0. IF((X.LT.0.) .OR. (A.LE.0.)) THEN PRINT *, 'BAD ARGUMENTS IN GAMMP' @@ -5560,36 +5534,36 @@ REAL FUNCTION GAMMP(A,X) CALL GCF(GAMMCF,A,X,GLN) GAMMP=1.-GAMMCF ENDIF - END FUNCTION GAMMP + END FUNCTION GAMMP ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !+---+-----------------------------------------------------------------+ !>\ingroup aathompson - REAL FUNCTION WGAMMA(y) + REAL FUNCTION WGAMMA(y) IMPLICIT NONE - REAL, INTENT(IN):: y + real(kind_phys), intent(in):: y WGAMMA = EXP(GAMMLN(y)) - END FUNCTION WGAMMA + END FUNCTION WGAMMA !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS !! A FUNCTION OF TEMPERATURE AND PRESSURE - REAL FUNCTION RSLF(P,T) + REAL FUNCTION RSLF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESL,X - REAL, PARAMETER:: C0= .611583699E03 - REAL, PARAMETER:: C1= .444606896E02 - REAL, PARAMETER:: C2= .143177157E01 - REAL, PARAMETER:: C3= .264224321E-1 - REAL, PARAMETER:: C4= .299291081E-3 - REAL, PARAMETER:: C5= .203154182E-5 - REAL, PARAMETER:: C6= .702620698E-8 - REAL, PARAMETER:: C7= .379534310E-11 - REAL, PARAMETER:: C8=-.321582393E-13 + real(kind_phys), intent(in):: P, T + real(kind_phys):: ESL,X + real(kind_phys), parameter:: C0= .611583699E03 + real(kind_phys), parameter:: C1= .444606896E02 + real(kind_phys), parameter:: C2= .143177157E01 + real(kind_phys), parameter:: C3= .264224321E-1 + real(kind_phys), parameter:: C4= .299291081E-3 + real(kind_phys), parameter:: C5= .203154182E-5 + real(kind_phys), parameter:: C6= .702620698E-8 + real(kind_phys), parameter:: C7= .379534310E-11 + real(kind_phys), parameter:: C8=-.321582393E-13 X=MAX(-80.,T-273.16) @@ -5606,25 +5580,25 @@ REAL FUNCTION RSLF(P,T) ! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 ! / T - 9.44523 * ALOG(T) + 0.014025 * T)) - END FUNCTION RSLF + END FUNCTION RSLF !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A !! FUNCTION OF TEMPERATURE AND PRESSURE - REAL FUNCTION RSIF(P,T) + REAL FUNCTION RSIF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T - REAL:: ESI,X - REAL, PARAMETER:: C0= .609868993E03 - REAL, PARAMETER:: C1= .499320233E02 - REAL, PARAMETER:: C2= .184672631E01 - REAL, PARAMETER:: C3= .402737184E-1 - REAL, PARAMETER:: C4= .565392987E-3 - REAL, PARAMETER:: C5= .521693933E-5 - REAL, PARAMETER:: C6= .307839583E-7 - REAL, PARAMETER:: C7= .105785160E-9 - REAL, PARAMETER:: C8= .161444444E-12 + real(kind_phys), intent(in):: P, T + real(kind_phys):: ESI,X + real(kind_phys), parameter:: C0= .609868993E03 + real(kind_phys), parameter:: C1= .499320233E02 + real(kind_phys), parameter:: C2= .184672631E01 + real(kind_phys), parameter:: C3= .402737184E-1 + real(kind_phys), parameter:: C4= .565392987E-3 + real(kind_phys), parameter:: C5= .521693933E-5 + real(kind_phys), parameter:: C6= .307839583E-7 + real(kind_phys), parameter:: C7= .105785160E-9 + real(kind_phys), parameter:: C8= .161444444E-12 X=MAX(-80.,T-273.16) ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) @@ -5637,33 +5611,33 @@ REAL FUNCTION RSIF(P,T) ! Meteorol. Soc (2005), 131, pp. 1539-1565. ! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T) - END FUNCTION RSIF + END FUNCTION RSIF !+---+-----------------------------------------------------------------+ !>\ingroup aathompson - real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) + real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) implicit none - REAL, INTENT(IN):: tempc, qv, qvs, qvsi, rho, nifa + real(kind_phys), intent(in):: tempc, qv, qvs, qvsi, rho, nifa !..Local vars - REAL:: satw, sati, siw, p_x, si0x, dtt, dsi, dsw, dab, fc, hx - REAL:: ntilde, n_in, nmax, nhat, mux, xni, nifa_cc - REAL, PARAMETER:: p_c1 = 1000. - REAL, PARAMETER:: p_rho_c = 0.76 - REAL, PARAMETER:: p_alpha = 1.0 - REAL, PARAMETER:: p_gam = 2. - REAL, PARAMETER:: delT = 5. - REAL, PARAMETER:: T0x = -40. - REAL, PARAMETER:: Sw0x = 0.97 - REAL, PARAMETER:: delSi = 0.1 - REAL, PARAMETER:: hdm = 0.15 - REAL, PARAMETER:: p_psi = 0.058707*p_gam/p_rho_c - REAL, PARAMETER:: aap = 1. - REAL, PARAMETER:: bbp = 0. - REAL, PARAMETER:: y1p = -35. - REAL, PARAMETER:: y2p = -25. - REAL, PARAMETER:: rho_not0 = 101325./(287.05*273.15) + real(kind_phys):: satw, sati, siw, p_x, si0x, dtt, dsi, dsw, dab, fc, hx + real(kind_phys):: ntilde, n_in, nmax, nhat, mux, xni, nifa_cc + real(kind_phys), parameter:: p_c1 = 1000. + real(kind_phys), parameter:: p_rho_c = 0.76 + real(kind_phys), parameter:: p_alpha = 1.0 + real(kind_phys), parameter:: p_gam = 2. + real(kind_phys), parameter:: delT = 5. + real(kind_phys), parameter:: T0x = -40. + real(kind_phys), parameter:: Sw0x = 0.97 + real(kind_phys), parameter:: delSi = 0.1 + real(kind_phys), parameter:: hdm = 0.15 + real(kind_phys), parameter:: p_psi = 0.058707*p_gam/p_rho_c + real(kind_phys), parameter:: aap = 1. + real(kind_phys), parameter:: bbp = 0. + real(kind_phys), parameter:: y1p = -35. + real(kind_phys), parameter:: y2p = -25. + real(kind_phys), parameter:: rho_not0 = 101325./(287.05*273.15) !+---+ @@ -5708,19 +5682,19 @@ real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) iceDeMott = MAX(0., xni) - end FUNCTION iceDeMott + end FUNCTION iceDeMott !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! Newer research since Koop et al (2001) suggests that the freezing !! rate should be lower than original paper, so J_rate is reduced !! by two orders of magnitude. - real function iceKoop(temp, qv, qvs, naero, dt) + real function iceKoop(temp, qv, qvs, naero, dt) implicit none - REAL, INTENT(IN):: temp, qv, qvs, naero, DT - REAL:: mu_diff, a_w_i, delta_aw, log_J_rate, J_rate, prob_h, satw - REAL:: xni + real(kind_phys), intent(in):: temp, qv, qvs, naero, DT + real(kind_phys):: mu_diff, a_w_i, delta_aw, log_J_rate, J_rate, prob_h, satw + real(kind_phys):: xni xni = 0.0 satw = qv/qvs @@ -5740,16 +5714,16 @@ real function iceKoop(temp, qv, qvs, naero, dt) iceKoop = MAX(0.0, xni) - end FUNCTION iceKoop + end FUNCTION iceKoop !+---+-----------------------------------------------------------------+ !>\ingroup aathompson !! Helper routine for Phillips et al (2008) ice nucleation. - REAL FUNCTION delta_p (yy, y1, y2, aa, bb) + REAL FUNCTION delta_p (yy, y1, y2, aa, bb) IMPLICIT NONE - REAL, INTENT(IN):: yy, y1, y2, aa, bb - REAL:: dab, A, B, a0, a1, a2, a3 + real(kind_phys), intent(in):: yy, y1, y2, aa, bb + real(kind_phys):: dab, A, B, a0, a1, a2, a3 A = 6.*(aa-bb)/((y2-y1)*(y2-y1)*(y2-y1)) B = aa+(A*y1*y1*y1/6.)-(A*y1*y1*y2*0.5) @@ -5774,7 +5748,7 @@ REAL FUNCTION delta_p (yy, y1, y2, aa, bb) endif delta_p = dab - END FUNCTION delta_p + END FUNCTION delta_p !+---+-----------------------------------------------------------------+ !ctrlL @@ -5788,26 +5762,26 @@ END FUNCTION delta_p !! radiation, compute from first portion of complicated Field number !! distribution, not the second part, which is the larger sizes. - subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & + subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte) IMPLICIT NONE !..Sub arguments - INTEGER, INTENT(IN):: kts, kte - REAL, DIMENSION(kts:kte), INTENT(IN):: & + integer, intent(in):: kts, kte + real(kind_phys), dimension(kts:kte), intent(in):: & & t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d - REAL, DIMENSION(kts:kte), INTENT(OUT):: re_qc1d, re_qi1d, re_qs1d + real(kind_phys), dimension(kts:kte), intent(out):: re_qc1d, re_qi1d, re_qs1d !..Local variables - INTEGER:: k - REAL, DIMENSION(kts:kte):: rho, rc, nc, ri, ni, rs - REAL:: smo2, smob, smoc - REAL:: tc0, loga_, a_, b_ - DOUBLE PRECISION:: lamc, lami - LOGICAL:: has_qc, has_qi, has_qs - INTEGER:: inu_c - INTEGER:: lsml - real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & + integer:: k + real(kind_phys), dimension(kts:kte):: rho, rc, nc, ri, ni, rs + real(kind_phys):: smo2, smob, smoc + real(kind_phys):: tc0, loga_, a_, b_ + real(kind_dbl_prec) :: lamc, lami + logical:: has_qc, has_qi, has_qs + integer:: inu_c + integer:: lsml + real(kind_phys), dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & & 504,720,990,1320,1716,2184,2730,3360,4080,4896/) has_qc = .false. @@ -5900,7 +5874,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & enddo endif - end subroutine calc_effectRad + end subroutine calc_effectRad !+---+-----------------------------------------------------------------+ !>\ingroup aathompson @@ -5911,47 +5885,47 @@ end subroutine calc_effectRad !! of frozen species remaining from what initially existed at the !! melting level interface. - subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & t1d, p1d, dBZ, rand1, kts, kte, ii, jj, melti, & vt_dBZ, first_time_step) IMPLICIT NONE !..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, INTENT(IN):: rand1 - REAL, DIMENSION(kts:kte), INTENT(IN):: & + integer, intent(in):: kts, kte, ii, jj + real(kind_phys), intent(in):: rand1 + real(kind_phys), dimension(kts:kte), intent(in):: & qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ - REAL, DIMENSION(kts:kte), OPTIONAL, INTENT(INOUT):: vt_dBZ - LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step + real(kind_phys), dimension(kts:kte), intent(inout):: dBZ + real(kind_phys), dimension(kts:kte), optional, intent(inout):: vt_dBZ + logical, optional, intent(in) :: first_time_step !..Local variables - LOGICAL :: do_vt_dBZ - LOGICAL :: allow_wet_graupel - LOGICAL :: allow_wet_snow - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho, rhof - REAL, DIMENSION(kts:kte):: rc, rr, nr, rs, rg + logical :: do_vt_dBZ + logical :: allow_wet_graupel + logical :: allow_wet_snow + real(kind_phys), dimension(kts:kte):: temp, pres, qv, rho, rhof + real(kind_phys), dimension(kts:kte):: rc, rr, nr, rs, rg - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g - REAL, DIMENSION(kts:kte):: mvd_r - REAL, DIMENSION(kts:kte):: smob, smo2, smoc, smoz - REAL:: oM3, M0, Mrat, slam1, slam2, xDs - REAL:: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts - REAL:: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt + real(kind_dbl_prec), dimension(kts:kte):: ilamr, ilamg, N0_r, N0_g + real(kind_phys), dimension(kts:kte):: mvd_r + real(kind_phys), dimension(kts:kte):: smob, smo2, smoc, smoz + real(kind_phys):: oM3, M0, Mrat, slam1, slam2, xDs + real(kind_phys):: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts + real(kind_phys):: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel + real(kind_phys), dimension(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamr, lamg - REAL:: a_, b_, loga_, tc0, SR - DOUBLE PRECISION:: fmelt_s, fmelt_g + real(kind_dbl_prec) :: N0_exp, N0_min, lam_exp, lamr, lamg + real(kind_phys):: a_, b_, loga_, tc0, SR + real(kind_dbl_prec) :: fmelt_s, fmelt_g - INTEGER:: i, k, k_0, kbot, n - LOGICAL, INTENT(IN):: melti - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg + integer:: i, k, k_0, kbot, n + logical, intent(in):: melti + logical, dimension(kts:kte):: L_qr, L_qs, L_qg - DOUBLE PRECISION:: cback, x, eta, f_d - REAL:: xslw1, ygra1, zans1 + real(kind_dbl_prec) :: cback, x, eta, f_d + real(kind_phys):: xslw1, ygra1, zans1 !+---+ if (present(vt_dBZ) .and. present(first_time_step)) then @@ -6221,10 +6195,10 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & enddo endif - end subroutine calc_refl10cm + end subroutine calc_refl10cm ! !------------------------------------------------------------------- - SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1) + SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1) !------------------------------------------------------------------- ! ! This routine is a semi-Lagrangain forward advection for hydrometeors @@ -6247,21 +6221,21 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1) implicit none integer, intent(in) :: km - real, intent(in) :: dt, R1 - real, intent(in) :: dzl(km),wwl(km) - real, intent(out) :: precip - real, intent(inout) :: rql(km) - real, intent(out) :: pfsan(km) - integer k,m,kk,kb,kt - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,con1,fa1,fa2 - real allold, decfl - real dz(km), ww(km), qq(km) - real wi(km+1), zi(km+1), za(km+2) - real qn(km) - real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) - real net_flx(km) + real(kind_phys), intent(in) :: dt, R1 + real(kind_phys), intent(in) :: dzl(km),wwl(km) + real(kind_phys), intent(out) :: precip + real(kind_phys), intent(inout) :: rql(km) + real(kind_phys), intent(out) :: pfsan(km) + integer :: k,m,kk,kb,kt + real(kind_phys) :: tl,tl2,qql,dql,qqd + real(kind_phys) :: th,th2,qqh,dqh + real(kind_phys) :: zsum,qsum,dim,dip,con1,fa1,fa2 + real(kind_phys) :: allold, decfl + real(kind_phys) :: dz(km), ww(km), qq(km) + real(kind_phys) :: wi(km+1), zi(km+1), za(km+2) + real(kind_phys) :: qn(km) + real(kind_phys) :: dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) + real(kind_phys) :: net_flx(km) ! precip = 0.0 qa(:) = 0.0 @@ -6455,7 +6429,7 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1) ! replace the new values rql(:) = max(qn(:),R1) - END SUBROUTINE semi_lagrange_sedim + END SUBROUTINE semi_lagrange_sedim !>\ingroup aathompson !! @brief Calculates graupel size distribution parameters @@ -6469,31 +6443,31 @@ END SUBROUTINE semi_lagrange_sedim !! @param[in] rg real array, size(kts:kte) for graupel mass concentration [kg m^3] !! @param[out] ilamg double array, size(kts:kte) for inverse graupel slope parameter [m] !! @param[out] N0_g double array, size(kts:kte) for graupel intercept paramter [m-4] -subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) + subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) - implicit none + implicit none - integer, intent(in) :: kts, kte - real, intent(in) :: rand1 - real, intent(in) :: rg(:) - double precision, intent(out) :: ilamg(:), N0_g(:) + integer, intent(in) :: kts, kte + real(kind_phys), intent(in) :: rand1 + real(kind_phys), intent(in) :: rg(:) + real(kind_dbl_prec), intent(out) :: ilamg(:), N0_g(:) - integer :: k - real :: ygra1, zans1 - double precision :: N0_exp, lam_exp, lamg + integer :: k + real(kind_phys) :: ygra1, zans1 + real(kind_dbl_prec) :: N0_exp, lam_exp, lamg - do k = kte, kts, -1 - ygra1 = alog10(max(1.e-9, rg(k))) - zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 - N0_exp = 10.**(zans1) - N0_exp = max(dble(gonv_min), min(N0_exp, dble(gonv_max))) - lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - ilamg(k) = 1./lamg - N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) - enddo + do k = kte, kts, -1 + ygra1 = alog10(max(1.e-9, rg(k))) + zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 + N0_exp = 10.**(zans1) + N0_exp = max(dble(gonv_min), min(N0_exp, dble(gonv_max))) + lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + ilamg(k) = 1./lamg + N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + enddo -end subroutine graupel_psd_parameters + end subroutine graupel_psd_parameters !>\ingroup aathompson !! @brief Calculates graupel/hail maximum diameter @@ -6508,38 +6482,38 @@ end subroutine graupel_psd_parameters !! @param[in] pressure double array, size(kts:kte) pressure [Pa] !! @param[in] qv real array, size(kts:kte) water vapor mixing ratio [kg kg^-1] !! @param[out] max_hail_diam real maximum hail diameter [m] -function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) result(max_hail_diam) + function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) result(max_hail_diam) - implicit none - - integer, intent(in) :: kts, kte - real, intent(in) :: qg(:), temperature(:), pressure(:), qv(:) - real :: max_hail_diam - - integer :: k - real :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte) - double precision :: ilamg(kts:kte), N0_g(kts:kte) - real, parameter :: random_number = 0. - - max_hail_column = 0. - rg = 0. - do k = kts, kte - rho(k) = 0.622*pressure(k)/(R*temperature(k)*(max(1.e-10, qv(k))+0.622)) - if (qg(k) .gt. R1) then - rg(k) = qg(k)*rho(k) - else - rg(k) = R1 - endif - enddo + implicit none + + integer, intent(in) :: kts, kte + real(kind_phys), intent(in) :: qg(:), temperature(:), pressure(:), qv(:) + real(kind_phys) :: max_hail_diam - call graupel_psd_parameters(kts, kte, random_number, rg, ilamg, N0_g) + integer :: k + real(kind_phys) :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte) + real(kind_dbl_prec) :: ilamg(kts:kte), N0_g(kts:kte) + real(kind_phys), parameter :: random_number = 0. - where(rg .gt. 1.e-9) max_hail_column = 10.05 * ilamg - max_hail_diam = max_hail_column(kts) - -end function hail_mass_99th_percentile + max_hail_column = 0. + rg = 0. + do k = kts, kte + rho(k) = 0.622*pressure(k)/(R*temperature(k)*(max(1.e-10, qv(k))+0.622)) + if (qg(k) .gt. R1) then + rg(k) = qg(k)*rho(k) + else + rg(k) = R1 + endif + enddo + + call graupel_psd_parameters(kts, kte, random_number, rg, ilamg, N0_g) + + where(rg .gt. 1.e-9) max_hail_column = 10.05 * ilamg + max_hail_diam = max_hail_column(kts) + + end function hail_mass_99th_percentile !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ -END MODULE module_mp_thompson +end module module_mp_thompson !+---+-----------------------------------------------------------------+ From a3e0d45f6849a3071adf6087301b4303c5e4cce1 Mon Sep 17 00:00:00 2001 From: Anders Jensen Date: Wed, 13 Dec 2023 12:59:52 -0700 Subject: [PATCH 002/154] Missing intentation --- physics/module_mp_thompson.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index b8c702883..91afd83a0 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1427,9 +1427,9 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & else do k = kts, kte if(lsml == 1) then - nc1d(k) = Nt_c_l/rho(k) + nc1d(k) = Nt_c_l/rho(k) else - nc1d(k) = Nt_c_o/rho(k) + nc1d(k) = Nt_c_o/rho(k) endif nwfa1d(k) = 11.1E6 nifa1d(k) = naIN1*0.01 From 10a17a94ebff57aa27c4f47abe03180ed1d3d169 Mon Sep 17 00:00:00 2001 From: Anders Jensen Date: Thu, 14 Dec 2023 11:32:50 -0700 Subject: [PATCH 003/154] Final formatted and CCN table sngl_prec --- physics/module_mp_thompson.F90 | 44 +++++++++++++++++----------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 91afd83a0..82080c5b9 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -59,7 +59,7 @@ module module_mp_thompson - use machine, only: kind_phys, kind_dbl_prec + use machine, only: kind_phys, kind_sngl_prec, kind_dbl_prec use module_mp_radar #ifdef MPI @@ -396,7 +396,7 @@ module module_mp_thompson real (kind_dbl_prec), allocatable, dimension(:,:,:) :: tnr_rev real (kind_dbl_prec), allocatable, dimension(:,:,:) :: & tpc_wev, tnc_wev - real (kind_phys), allocatable, dimension(:,:,:,:,:) :: tnccn_act + real (kind_sngl_prec), allocatable, dimension(:,:,:,:,:) :: tnccn_act !..Variables holding a bunch of exponents and gamma values (cloud water, !.. cloud ice, rain, snow, then graupel). @@ -5282,37 +5282,37 @@ subroutine table_ccnAct(errmess,errflag) logical:: opened iunit_mp_th1 = -1 - DO i = 20,99 - INQUIRE ( i , OPENED = opened ) - IF ( .NOT. opened ) THEN + do_loop_ccn : do i = 20, 99 + INQUIRE (i, OPENED=opened) + if (.not. opened) then iunit_mp_th1 = i - GOTO 2010 - ENDIF - ENDDO - 2010 CONTINUE - IF ( iunit_mp_th1 < 0 ) THEN - write(0,*) 'module_mp_thompson: table_ccnAct: '// & + exit do_loop_ccn + endif + enddo do_loop_ccn + + if (iunit_mp_th1 < 0) then + write(0,*) 'module_mp_thompson: table_ccnAct: '// & 'Can not find unused fortran unit to read in lookup table.' - return - ENDIF + return + endif - !WRITE(*, '(A,I2)') 'module_mp_thompson: opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1 - OPEN(iunit_mp_th1,FILE='CCN_ACTIVATE.BIN', & - FORM='UNFORMATTED',STATUS='OLD',CONVERT='BIG_ENDIAN',ERR=9009) + !WRITE(*, '(A,I2)') 'module_mp_thompson: opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1 + OPEN(iunit_mp_th1, FILE='CCN_ACTIVATE.BIN', & + FORM='UNFORMATTED', STATUS='OLD', CONVERT='BIG_ENDIAN', ERR=9009) !sms$serial begin - READ(iunit_mp_th1,ERR=9010) tnccn_act + READ(iunit_mp_th1, ERR=9010) tnccn_act !sms$serial end - RETURN + return 9009 CONTINUE - WRITE( errmess , '(A,I2)' ) 'module_mp_thompson: error opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1 + WRITE(errmess , '(A,I2)') 'module_mp_thompson: error opening CCN_ACTIVATE.BIN on unit ',iunit_mp_th1 errflag = 1 - RETURN + return 9010 CONTINUE - WRITE( errmess , '(A,I2)' ) 'module_mp_thompson: error reading CCN_ACTIVATE.BIN on unit ',iunit_mp_th1 + WRITE(errmess , '(A,I2)') 'module_mp_thompson: error reading CCN_ACTIVATE.BIN on unit ',iunit_mp_th1 errflag = 1 - RETURN + return end subroutine table_ccnAct From 72370a444a705b872be9daf5f44f41f5f5e0a4ec Mon Sep 17 00:00:00 2001 From: Anders Jensen Date: Thu, 21 Dec 2023 11:56:40 -0700 Subject: [PATCH 004/154] Changes from review 1 --- physics/module_mp_thompson.F90 | 909 +++++++++++++++++---------------- 1 file changed, 455 insertions(+), 454 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 82080c5b9..f0530e412 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -59,7 +59,7 @@ module module_mp_thompson - use machine, only: kind_phys, kind_sngl_prec, kind_dbl_prec + use machine, only: wp => kind_phys, sp => kind_sngl_prec, dp => kind_dbl_prec use module_mp_radar #ifdef MPI @@ -91,18 +91,18 @@ module module_mp_thompson !.. scheme. In 2-moment cloud water, Nt_c represents a maximum of !.. droplet concentration and nu_c is also variable depending on local !.. droplet number concentration. - !real(kind_phys), parameter :: Nt_c = 100.E6 - real(kind_phys), parameter :: Nt_c_o = 50.E6 - real(kind_phys), parameter :: Nt_c_l = 100.E6 - real(kind_phys), parameter, private :: Nt_c_max = 1999.E6 + !real(kind_phys), parameter :: Nt_c = 100.e6 + real(kind_phys), parameter :: Nt_c_o = 50.e6 + real(kind_phys), parameter :: Nt_c_l = 100.e6 + real(kind_phys), parameter, private :: Nt_c_max = 1999.e6 !..Declaration of constants for assumed CCN/IN aerosols when none in !.. the input data. Look inside the init routine for modifications !.. due to surface land-sea points or vegetation characteristics. - real(kind_phys), parameter :: naIN0 = 1.5E6 - real(kind_phys), parameter :: naIN1 = 0.5E6 - real(kind_phys), parameter :: naCCN0 = 300.0E6 - real(kind_phys), parameter :: naCCN1 = 50.0E6 + real(kind_phys), parameter :: naIN0 = 1.5e6 + real(kind_phys), parameter :: naIN1 = 0.5e6 + real(kind_phys), parameter :: naCCN0 = 300.0e6 + real(kind_phys), parameter :: naCCN1 = 50.0e6 !..Generalized gamma distributions for rain, graupel and cloud ice. !.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. @@ -172,8 +172,8 @@ module module_mp_thompson !.. R1 value, 1.E-12, cannot be set lower because of numerical !.. problems with Paul Field's moments and should not be set larger !.. because of truncation problems in snow/ice growth. - real(kind_phys), parameter, private :: R1 = 1.E-12 - real(kind_phys), parameter, private :: R2 = 1.E-6 + real(kind_phys), parameter, private :: R1 = 1.e-12 + real(kind_phys), parameter, private :: R2 = 1.e-6 real(kind_phys), parameter :: eps = 1.E-15 !..Constants in Cooper curve relation for cloud ice number. @@ -194,39 +194,40 @@ module module_mp_thompson real(kind_phys), parameter, private :: Rv = 461.5 real(kind_phys), parameter, private :: oRv = 1./Rv real(kind_phys), parameter, private :: R = 287.04 + real(kind_phys), parameter, private :: RoverRv = R*oRv real(kind_phys), parameter, private :: Cp = 1004.0 real(kind_phys), parameter, private :: R_uni = 8.314 !< J (mol K)-1 - real(kind_dbl_prec), parameter, private :: k_b = 1.38065E-23 !< Boltzmann constant [J/K] - real(kind_dbl_prec), parameter, private :: M_w = 18.01528E-3 !< molecular mass of water [kg/mol] - real(kind_dbl_prec), parameter, private :: M_a = 28.96E-3 !< molecular mass of air [kg/mol] - real(kind_dbl_prec), parameter, private :: N_avo = 6.022E23 !< Avogadro number [1/mol] + real(kind_dbl_prec), parameter, private :: k_b = 1.38065e-23 !< Boltzmann constant [J/K] + real(kind_dbl_prec), parameter, private :: M_w = 18.01528e-3 !< molecular mass of water [kg/mol] + real(kind_dbl_prec), parameter, private :: M_a = 28.96e-3 !< molecular mass of air [kg/mol] + real(kind_dbl_prec), parameter, private :: N_avo = 6.022e23 !< Avogadro number [1/mol] real(kind_dbl_prec), parameter, private :: ma_w = M_w / N_avo !< mass of water molecule [kg] real(kind_phys), parameter, private :: ar_volume = 4./3.*PI*(2.5e-6)**3 !< assume radius of 0.025 micrometer, 2.5e-6 cm !..Enthalpy of sublimation, vaporization, and fusion at 0C. - real(kind_phys), parameter, private :: lsub = 2.834E6 - real(kind_phys), parameter, private :: lvap0 = 2.5E6 + real(kind_phys), parameter, private :: lsub = 2.834e6 + real(kind_phys), parameter, private :: lvap0 = 2.5e6 real(kind_phys), parameter, private :: lfus = lsub - lvap0 real(kind_phys), parameter, private :: olfus = 1./lfus !..Ice initiates with this mass (kg), corresponding diameter calc. !..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). - real(kind_phys), parameter, private :: xm0i = 1.E-12 - real(kind_phys), parameter, private :: D0c = 1.E-6 - real(kind_phys), parameter, private :: D0r = 50.E-6 - real(kind_phys), parameter, private :: D0s = 300.E-6 - real(kind_phys), parameter, private :: D0g = 350.E-6 + real(kind_phys), parameter, private :: xm0i = R1 + real(kind_phys), parameter, private :: D0c = 1.e-6 + real(kind_phys), parameter, private :: D0r = 50.e-6 + real(kind_phys), parameter, private :: D0s = 300.e-6 + real(kind_phys), parameter, private :: D0g = 350.e-6 real(kind_phys), private :: D0i, xm0s, xm0g !..Min and max radiative effective radius of cloud water, cloud ice, and snow; !.. performed by subroutine calc_effectRad. On purpose, these should stay PUBLIC. - real(kind_phys), parameter :: re_qc_min = 2.50E-6 ! 2.5 microns - real(kind_phys), parameter :: re_qc_max = 50.0E-6 ! 50 microns - real(kind_phys), parameter :: re_qi_min = 2.50E-6 ! 2.5 microns - real(kind_phys), parameter :: re_qi_max = 125.0E-6 ! 125 microns - real(kind_phys), parameter :: re_qs_min = 5.00E-6 ! 5 microns - real(kind_phys), parameter :: re_qs_max = 999.0E-6 ! 999 microns (1 mm) + real(kind_phys), parameter :: re_qc_min = 2.50e-6 ! 2.5 microns + real(kind_phys), parameter :: re_qc_max = 50.0e-6 ! 50 microns + real(kind_phys), parameter :: re_qi_min = 2.50e-6 ! 2.5 microns + real(kind_phys), parameter :: re_qi_max = 125.0e-6 ! 125 microns + real(kind_phys), parameter :: re_qs_min = 5.00e-6 ! 5 microns + real(kind_phys), parameter :: re_qs_max = 999.0e-6 ! 999 microns (1 mm) !..Lookup table dimensions integer, parameter, private :: nbins = 100 @@ -452,7 +453,7 @@ subroutine thompson_init(is_aerosol_aware_in, & integer:: i, j, k, l, m, n logical:: micro_init - real :: stime, etime + real(kind_phys) :: stime, etime logical, parameter :: precomputed_tables = .FALSE. ! Set module variable is_aerosol_aware/merra2_aerosol_aware @@ -532,8 +533,8 @@ subroutine thompson_init(is_aerosol_aware_in, & !.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime !.. to 2 for really dirty air. This not used in 2-moment cloud water !.. scheme and nu_c used instead and varies from 2 to 15 (integer-only). - mu_c_l = MIN(15., (1000.E6/Nt_c_l + 2.)) - mu_c_o = MIN(15., (1000.E6/Nt_c_o + 2.)) + mu_c_l = min(15.0_wp, (1000.e6/Nt_c_l + 2.)) + mu_c_o = min(15.0_wp, (1000.e6/Nt_c_o + 2.)) !> - Compute Schmidt number to one-third used numerous times Sc3 = Sc**(1./3.) @@ -687,83 +688,83 @@ subroutine thompson_init(is_aerosol_aware_in, & t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) !> - Compute constants for helping find lookup table indexes - nic2 = NINT(ALOG10(r_c(1))) - nii2 = NINT(ALOG10(r_i(1))) - nii3 = NINT(ALOG10(Nt_i(1))) - nir2 = NINT(ALOG10(r_r(1))) - nir3 = NINT(ALOG10(N0r_exp(1))) - nis2 = NINT(ALOG10(r_s(1))) - nig2 = NINT(ALOG10(r_g(1))) - nig3 = NINT(ALOG10(N0g_exp(1))) - niIN2 = NINT(ALOG10(Nt_IN(1))) + nic2 = nint(log10(r_c(1))) + nii2 = nint(log10(r_i(1))) + nii3 = nint(log10(Nt_i(1))) + nir2 = nint(log10(r_r(1))) + nir3 = nint(log10(N0r_exp(1))) + nis2 = nint(log10(r_s(1))) + nig2 = nint(log10(r_g(1))) + nig3 = nint(log10(N0g_exp(1))) + niIN2 = nint(log10(Nt_IN(1))) !> - Create bins of cloud water (from min diameter up to 100 microns) - Dc(1) = D0c*1.0d0 - dtc(1) = D0c*1.0d0 + Dc(1) = D0c*1.0_dp + dtc(1) = D0c*1.0_dp do n = 2, nbc - Dc(n) = Dc(n-1) + 1.0D-6 + Dc(n) = Dc(n-1) + 1.e-6_dp dtc(n) = (Dc(n) - Dc(n-1)) enddo !> - Create bins of cloud ice (from min diameter up to 2x min snow size) - xDx(1) = D0i*1.0d0 - xDx(nbi+1) = 2.0d0*D0s + xDx(1) = D0i*1.0_dp + xDx(nbi+1) = D0s*2.0_dp do n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & - *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) + xDx(n) = exp(real(n-1, kind=dp)/real(nbi, kind=dp) & + *log(real(xDx(nbi+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) enddo do n = 1, nbi - Di(n) = DSQRT(xDx(n)*xDx(n+1)) + Di(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) dti(n) = xDx(n+1) - xDx(n) enddo !> - Create bins of rain (from min diameter up to 5 mm) - xDx(1) = D0r*1.0d0 - xDx(nbr+1) = 0.005d0 + xDx(1) = D0r*1.0_dp + xDx(nbr+1) = 0.005_dp do n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & - *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) + xDx(n) = exp(real(n-1, kind=dp)/real(nbr, kind=dp) & + *log(real(xDx(nbr+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) enddo do n = 1, nbr - Dr(n) = DSQRT(xDx(n)*xDx(n+1)) + Dr(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) dtr(n) = xDx(n+1) - xDx(n) enddo !> - Create bins of snow (from min diameter up to 2 cm) - xDx(1) = D0s*1.0d0 - xDx(nbs+1) = 0.02d0 + xDx(1) = D0s*1.0_dp + xDx(nbs+1) = 0.02_dp do n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & - *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) + xDx(n) = exp(real(n-1, kind=dp)/real(nbs, kind=dp) & + *log(real(xDx(nbs+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) enddo do n = 1, nbs - Ds(n) = DSQRT(xDx(n)*xDx(n+1)) + Ds(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) dts(n) = xDx(n+1) - xDx(n) enddo !> - Create bins of graupel (from min diameter up to 5 cm) - xDx(1) = D0g*1.0d0 - xDx(nbg+1) = 0.05d0 + xDx(1) = D0g*1.0_dp + xDx(nbg+1) = 0.05_dp do n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & - *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) + xDx(n) = exp(real(n-1, kind=dp)/real(nbg, kind=dp) & + *log(real(xDx(nbg+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) enddo do n = 1, nbg - Dg(n) = DSQRT(xDx(n)*xDx(n+1)) + Dg(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) dtg(n) = xDx(n+1) - xDx(n) enddo !> - Create bins of cloud droplet number concentration (1 to 3000 per cc) - xDx(1) = 1.0d0 - xDx(nbc+1) = 3000.0d0 + xDx(1) = 1.0_dp + xDx(nbc+1) = 3000.0_dp do n = 2, nbc - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbc) & - *DLOG(xDx(nbc+1)/xDx(1)) +DLOG(xDx(1))) + xDx(n) = exp(real(n-1, kind=dp)/real(nbc, kind=dp) & + *log(real(xDx(nbc+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) enddo do n = 1, nbc - t_Nc(n) = DSQRT(xDx(n)*xDx(n+1)) * 1.D6 + t_Nc(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) * 1.e6_dp enddo - nic1 = DLOG(t_Nc(nbc)/t_Nc(1)) + nic1 = log(real(t_Nc(nbc)/t_Nc(1), kind=dp)) !+---+-----------------------------------------------------------------+ !> - Create lookup tables for most costly calculations @@ -789,12 +790,12 @@ subroutine thompson_init(is_aerosol_aware_in, & do k = 1, ntb_r1 do j = 1, ntb_g do i = 1, ntb_g1 - tcg_racg(i,j,k,m) = 0.0d0 - tmr_racg(i,j,k,m) = 0.0d0 - tcr_gacr(i,j,k,m) = 0.0d0 - tmg_gacr(i,j,k,m) = 0.0d0 - tnr_racg(i,j,k,m) = 0.0d0 - tnr_gacr(i,j,k,m) = 0.0d0 + tcg_racg(i,j,k,m) = 0.0_dp + tmr_racg(i,j,k,m) = 0.0_dp + tcr_gacr(i,j,k,m) = 0.0_dp + tmg_gacr(i,j,k,m) = 0.0_dp + tnr_racg(i,j,k,m) = 0.0_dp + tnr_gacr(i,j,k,m) = 0.0_dp enddo enddo enddo @@ -804,18 +805,18 @@ subroutine thompson_init(is_aerosol_aware_in, & do k = 1, ntb_r1 do j = 1, ntb_t do i = 1, ntb_s - tcs_racs1(i,j,k,m) = 0.0d0 - tmr_racs1(i,j,k,m) = 0.0d0 - tcs_racs2(i,j,k,m) = 0.0d0 - tmr_racs2(i,j,k,m) = 0.0d0 - tcr_sacr1(i,j,k,m) = 0.0d0 - tms_sacr1(i,j,k,m) = 0.0d0 - tcr_sacr2(i,j,k,m) = 0.0d0 - tms_sacr2(i,j,k,m) = 0.0d0 - tnr_racs1(i,j,k,m) = 0.0d0 - tnr_racs2(i,j,k,m) = 0.0d0 - tnr_sacr1(i,j,k,m) = 0.0d0 - tnr_sacr2(i,j,k,m) = 0.0d0 + tcs_racs1(i,j,k,m) = 0.0_dp + tmr_racs1(i,j,k,m) = 0.0_dp + tcs_racs2(i,j,k,m) = 0.0_dp + tmr_racs2(i,j,k,m) = 0.0_dp + tcr_sacr1(i,j,k,m) = 0.0_dp + tms_sacr1(i,j,k,m) = 0.0_dp + tcr_sacr2(i,j,k,m) = 0.0_dp + tms_sacr2(i,j,k,m) = 0.0_dp + tnr_racs1(i,j,k,m) = 0.0_dp + tnr_racs2(i,j,k,m) = 0.0_dp + tnr_sacr1(i,j,k,m) = 0.0_dp + tnr_sacr2(i,j,k,m) = 0.0_dp enddo enddo enddo @@ -825,16 +826,16 @@ subroutine thompson_init(is_aerosol_aware_in, & do k = 1, 45 do j = 1, ntb_r1 do i = 1, ntb_r - tpi_qrfz(i,j,k,m) = 0.0d0 - tni_qrfz(i,j,k,m) = 0.0d0 - tpg_qrfz(i,j,k,m) = 0.0d0 - tnr_qrfz(i,j,k,m) = 0.0d0 + tpi_qrfz(i,j,k,m) = 0.0_dp + tni_qrfz(i,j,k,m) = 0.0_dp + tpg_qrfz(i,j,k,m) = 0.0_dp + tnr_qrfz(i,j,k,m) = 0.0_dp enddo enddo do j = 1, nbc do i = 1, ntb_c - tpi_qcfz(i,j,k,m) = 0.0d0 - tni_qcfz(i,j,k,m) = 0.0d0 + tpi_qcfz(i,j,k,m) = 0.0_dp + tni_qcfz(i,j,k,m) = 0.0_dp enddo enddo enddo @@ -842,9 +843,9 @@ subroutine thompson_init(is_aerosol_aware_in, & do j = 1, ntb_i1 do i = 1, ntb_i - tps_iaus(i,j) = 0.0d0 - tni_iaus(i,j) = 0.0d0 - tpi_ide(i,j) = 0.0d0 + tps_iaus(i,j) = 0.0_dp + tni_iaus(i,j) = 0.0_dp + tpi_ide(i,j) = 0.0_dp enddo enddo @@ -860,7 +861,7 @@ subroutine thompson_init(is_aerosol_aware_in, & do k = 1, ntb_r do j = 1, ntb_r1 do i = 1, nbr - tnr_rev(i,j,k) = 0.0d0 + tnr_rev(i,j,k) = 0.0_dp enddo enddo enddo @@ -868,8 +869,8 @@ subroutine thompson_init(is_aerosol_aware_in, & do k = 1, nbc do j = 1, ntb_c do i = 1, nbc - tpc_wev(i,j,k) = 0.0d0 - tnc_wev(i,j,k) = 0.0d0 + tpc_wev(i,j,k) = 0.0_dp + tnc_wev(i,j,k) = 0.0_dp enddo enddo enddo @@ -1370,7 +1371,7 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qg1d(k) = qg(i,k,j) ni1d(k) = ni(i,k,j) nr1d(k) = nr(i,k,j) - rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + rho(k) = RoverRv*p1d(k) / (R*t1d(k)*(qv1d(k)+RoverRv)) ! These arrays are always allocated and must be initialized !vtsk1(k) = 0. @@ -1485,7 +1486,7 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & GRAUPELNCV(i,j) = pptgraul GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul ENDIF - SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) + SR(i,j) = (pptsnow + pptgraul + pptice) / (RAINNCV(i,j)+R1) !..Reset lowest model level to initial state aerosols (fake sfc source). !.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol @@ -1604,7 +1605,7 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ' at i,j,k=', i,j,k if (k.lt.kte-2 .and. k.gt.kts+1) then write(*,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j) - qv(i,k,j) = MAX(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) + qv(i,k,j) = max(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) else qv(i,k,j) = 1.E-7 endif @@ -1657,7 +1658,7 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & endif assign_extended_diagnostics if (ndt>1 .and. it==ndt) then - SR(i,j) = (pcp_sn(i,j) + pcp_gr(i,j) + pcp_ic(i,j))/(RAINNC(i,j)+1.e-12) + SR(i,j) = (pcp_sn(i,j) + pcp_gr(i,j) + pcp_ic(i,j)) / (RAINNC(i,j)+R1) RAINNCV(i,j) = RAINNC(i,j) IF ( PRESENT (snowncv) ) THEN SNOWNCV(i,j) = SNOWNC(i,j) @@ -1701,7 +1702,7 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & melti) endif do k = kts, kte - refl_10cm(i,k,j) = MAX(-35., dBZ(k)) + refl_10cm(i,k,j) = max(-35., dBZ(k)) enddo endif ENDIF diagflag_present @@ -1716,9 +1717,9 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & re_qc1d, re_qi1d, re_qs1d, lsml, kts, kte) do k = kts, kte - re_cloud(i,k,j) = MAX(re_qc_min, MIN(re_qc1d(k), re_qc_max)) - re_ice(i,k,j) = MAX(re_qi_min, MIN(re_qi1d(k), re_qi_max)) - re_snow(i,k,j) = MAX(re_qs_min, MIN(re_qs1d(k), re_qs_max)) + re_cloud(i,k,j) = max(re_qc_min, min(re_qc1d(k), re_qc_max)) + re_ice(i,k,j) = max(re_qi_min, min(re_qi1d(k), re_qi_max)) + re_snow(i,k,j) = max(re_qs_min, min(re_qs1d(k), re_qs_max)) enddo ENDIF ENDIF last_step_only @@ -1955,7 +1956,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prg_gcw, prg_rci, prg_rcs, & prg_rcg, prg_ihm - real(kind_dbl_prec), parameter:: zeroD0 = 0.0d0 + real(kind_dbl_prec), parameter:: zeroD0 = 0.0 real(kind_phys) :: dtcfl, rainsfc, graulsfc integer :: niter @@ -2200,26 +2201,26 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ do k = kts, kte temp(k) = t1d(k) - qv(k) = MAX(1.E-10, qv1d(k)) + qv(k) = max(1.E-10, qv1d(k)) pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - nwfa(k) = MAX(11.1E6*rho(k), MIN(9999.E6*rho(k), nwfa1d(k)*rho(k))) - nifa(k) = MAX(naIN1*0.01*rho(k), MIN(9999.E6*rho(k), nifa1d(k)*rho(k))) + rho(k) = RoverRv*pres(k) / (R*temp(k)*(qv(k)+RoverRv)) + nwfa(k) = max(11.1E6*rho(k), min(9999.E6*rho(k), nwfa1d(k)*rho(k))) + nifa(k) = max(naIN1*0.01*rho(k), min(9999.E6*rho(k), nifa1d(k)*rho(k))) mvd_r(k) = D0r mvd_c(k) = D0c if (qc1d(k) .gt. R1) then no_micro = .false. rc(k) = qc1d(k)*rho(k) - nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) + nc(k) = max(2., min(nc1d(k)*rho(k), Nt_c_max)) L_qc(k) = .true. if (nc(k).gt.10000.E6) then nu_c = 2 elseif (nc(k).lt.100.) then nu_c = 15 else - nu_c = NINT(1000.E6/nc(k)) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + nu_c = nint(1000.E6/nc(k)) + 2 + nu_c = max(2, min(nu_c+nint(rand2), 15)) endif lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr xDc = (bm_r + nu_c + 1.) / lamc @@ -2228,7 +2229,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & elseif (xDc.gt. D0r*2.) then lamc = cce(2,nu_c)/(D0r*2.) endif - nc(k) = MIN( DBLE(Nt_c_max), ccg(1,nu_c)*ocg2(nu_c)*rc(k) & + nc(k) = min(real(Nt_c_max, kind=dp), ccg(1,nu_c)*ocg2(nu_c)*rc(k) & / am_r*lamc**bm_r) if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then if (lsml == 1) then @@ -2248,10 +2249,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (qi1d(k) .gt. R1) then no_micro = .false. ri(k) = qi1d(k)*rho(k) - ni(k) = MAX(R2, ni1d(k)*rho(k)) + ni(k) = max(R2, ni1d(k)*rho(k)) if (ni(k).le. R2) then lami = cie(2)/5.E-6 - ni(k) = MIN(4999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = min(4999.e3_dp, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif L_qi(k) = .true. lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi @@ -2259,7 +2260,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - ni(k) = MIN(4999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = min(4999.e3_dp, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -2275,7 +2276,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (qr1d(k) .gt. R1) then no_micro = .false. rr(k) = qr1d(k)*rho(k) - nr(k) = MAX(R2, nr1d(k)*rho(k)) + nr(k) = max(R2, nr1d(k)*rho(k)) if (nr(k).le. R2) then mvd_r(k) = 1.0E-3 lamr = (3.0 + mu_r + 0.672) / mvd_r(k) @@ -2340,7 +2341,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rhof(k) = SQRT(RHO_NOT/rho(k)) rhof2(k) = SQRT(rhof(k)) qvs(k) = rslf(pres(k), temp(k)) - delQvs(k) = MAX(0.0, rslf(pres(k), 273.15)-qv(k)) + delQvs(k) = max(0.0, rslf(pres(k), 273.15)-qv(k)) if (tempc .le. 0.0) then qvsi(k) = rsif(pres(k), temp(k)) else @@ -2378,7 +2379,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (.not. iiwarm) then do k = kts, kte if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) + tc0 = min(-0.1, temp(k)-273.15) smob(k) = rs(k)*oams !> - All other moments based on reference, 2nd moment. If bm_s.ne.2, @@ -2484,23 +2485,23 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Rain self-collection follows Seifert, 1994 and drop break-up !! follows Verlinde and Cotton, 1993. Updated after Saleeby et al 2022. RAIN2M if (L_qr(k) .and. mvd_r(k).gt. D0r) then - Ef_rr = MAX(-0.1, 1.0 - EXP(2300.0*(mvd_r(k)-1950.0E-6))) + Ef_rr = max(-0.1, 1.0 - exp(2300.0*(mvd_r(k)-1950.0e-6))) pnr_rcr(k) = Ef_rr * 2.0*nr(k)*rr(k) endif if (L_qc(k)) then - if (nc(k).gt.10000.E6) then + if (nc(k).gt.10000.e6) then nu_c = 2 elseif (nc(k).lt.100.) then nu_c = 15 else - nu_c = NINT(1000.E6/nc(k)) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + nu_c = nint(1000.e6/nc(k)) + 2 + nu_c = max(2, min(nu_c+nint(rand2), 15)) endif - xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*nc(k)))**obmr) * 1.E6) + xDc = max(D0c*1.e6, ((rc(k)/(am_r*nc(k)))**obmr) * 1.e6) lamc = (nc(k)*am_r* ccg(2,nu_c) * ocg1(nu_c) / rc(k))**obmr mvd_c(k) = (3.0+nu_c+0.672) / lamc - mvd_c(k) = MAX(D0c, MIN(mvd_c(k), D0r)) + mvd_c(k) = max(D0c, min(mvd_c(k), D0r)) endif !> - Autoconversion follows Berry & Reinhardt (1974) with characteristic @@ -2515,24 +2516,24 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1 tau = 3.72/(rc(k)*taud) prr_wau(k) = zeta/tau - prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) + prr_wau(k) = min(real(rc(k)*odts, kind=dp), prr_wau(k)) pnr_wau(k) = prr_wau(k) / (am_r*nu_c*10.*D0r*D0r*D0r) ! RAIN2M - pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k) & + pnc_wau(k) = min(real(nc(k)*odts, kind=dp), prr_wau(k) & / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) ! Qc2M endif !> - Rain collecting cloud water. In CE, assume Dc< - Rain collecting aerosols, wet scavenging. @@ -2541,12 +2542,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lamr = 1./ilamr(k) pna_rca(k) = rhof(k)*t1_qr_qc*Ef_ra*nwfa(k)*N0_r(k) & *((lamr+fv_r)**(-cre(9))) - pna_rca(k) = MIN(DBLE(nwfa(k)*odts), pna_rca(k)) + pna_rca(k) = min(real(nwfa(k)*odts, kind=dp), pna_rca(k)) Ef_ra = Eff_aero(mvd_r(k),0.8E-6,visco(k),rho(k),temp(k),'r') pnd_rcd(k) = rhof(k)*t1_qr_qc*Ef_ra*nifa(k)*N0_r(k) & *((lamr+fv_r)**(-cre(9))) - pnd_rcd(k) = MIN(DBLE(nifa(k)*odts), pnd_rcd(k)) + pnd_rcd(k) = min(real(nifa(k)*odts, kind=dp), pnd_rcd(k)) endif enddo @@ -2562,74 +2563,74 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Temperature lookup table indexes. tempc = temp(k) - 273.15 - idx_tc = MAX(1, MIN(NINT(-tempc), 45) ) - idx_t = INT( (tempc-2.5)/5. ) - 1 - idx_t = MAX(1, -idx_t) - idx_t = MIN(idx_t, ntb_t) - IT = MAX(1, MIN(NINT(-tempc), 31) ) + idx_tc = max(1, min(nint(-tempc), 45) ) + idx_t = int( (tempc-2.5)/5. ) - 1 + idx_t = max(1, -idx_t) + idx_t = min(idx_t, ntb_t) + IT = max(1, min(nint(-tempc), 31) ) !> - Cloud water lookup table index. if (rc(k).gt. r_c(1)) then - nic = NINT(ALOG10(rc(k))) + nic = nint(log10(rc(k))) do_loop_rc: do nn = nic-1, nic+1 n = nn if ( (rc(k)/10.**nn).ge.1.0 .and. (rc(k)/10.**nn).lt.10.0 ) exit do_loop_rc enddo do_loop_rc - idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) - idx_c = MAX(1, MIN(idx_c, ntb_c)) + idx_c = int(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) + idx_c = max(1, min(idx_c, ntb_c)) else idx_c = 1 endif !> - Cloud droplet number lookup table index. - idx_n = NINT(1.0 + FLOAT(nbc) * DLOG(nc(k)/t_Nc(1)) / nic1) - idx_n = MAX(1, MIN(idx_n, nbc)) + idx_n = nint(1.0 + real(nbc, kind=wp) * log(real(nc(k)/t_Nc(1), kind=dp)) / nic1) + idx_n = max(1, min(idx_n, nbc)) !> - Cloud ice lookup table indexes. if (ri(k).gt. r_i(1)) then - nii = NINT(ALOG10(ri(k))) + nii = nint(log10(ri(k))) do_loop_ri: do nn = nii-1, nii+1 n = nn if ( (ri(k)/10.**nn).ge.1.0 .and. (ri(k)/10.**nn).lt.10.0 ) exit do_loop_ri enddo do_loop_ri - idx_i = INT(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2) - idx_i = MAX(1, MIN(idx_i, ntb_i)) + idx_i = int(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2) + idx_i = max(1, min(idx_i, ntb_i)) else idx_i = 1 endif if (ni(k).gt. Nt_i(1)) then - nii = NINT(ALOG10(ni(k))) + nii = nint(log10(ni(k))) do_loop_ni: do nn = nii-1, nii+1 n = nn if ( (ni(k)/10.**nn).ge.1.0 .and. (ni(k)/10.**nn).lt.10.0 ) exit do_loop_ni enddo do_loop_ni - idx_i1 = INT(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3) - idx_i1 = MAX(1, MIN(idx_i1, ntb_i1)) + idx_i1 = int(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3) + idx_i1 = max(1, min(idx_i1, ntb_i1)) else idx_i1 = 1 endif !> - Rain lookup table indexes. if (rr(k).gt. r_r(1)) then - nir = NINT(ALOG10(rr(k))) + nir = nint(log10(rr(k))) do_loop_rr: do nn = nir-1, nir+1 n = nn if ( (rr(k)/10.**nn).ge.1.0 .and. (rr(k)/10.**nn).lt.10.0 ) exit do_loop_rr enddo do_loop_rr - idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) - idx_r = MAX(1, MIN(idx_r, ntb_r)) + idx_r = int(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) + idx_r = max(1, min(idx_r, ntb_r)) lamr = 1./ilamr(k) lam_exp = lamr * (crg(3)*org2*org1)**bm_r N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) - nir = NINT(DLOG10(N0_exp)) + nir = nint(log10(real(N0_exp, kind=dp))) do_loop_nr: do nn = nir-1, nir+1 n = nn if ( (N0_exp/10.**nn).ge.1.0 .and. (N0_exp/10.**nn).lt.10.0 ) exit do_loop_nr enddo do_loop_nr - idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) - idx_r1 = MAX(1, MIN(idx_r1, ntb_r1)) + idx_r1 = int(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) + idx_r1 = max(1, min(idx_r1, ntb_r1)) else idx_r = 1 idx_r1 = ntb_r1 @@ -2637,37 +2638,37 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Snow lookup table index. if (rs(k).gt. r_s(1)) then - nis = NINT(ALOG10(rs(k))) + nis = nint(log10(rs(k))) do_loop_rs: do nn = nis-1, nis+1 n = nn if ( (rs(k)/10.**nn).ge.1.0 .and. (rs(k)/10.**nn).lt.10.0 ) exit do_loop_rs enddo do_loop_rs - idx_s = INT(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2) - idx_s = MAX(1, MIN(idx_s, ntb_s)) + idx_s = int(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2) + idx_s = max(1, min(idx_s, ntb_s)) else idx_s = 1 endif !> - Graupel lookup table index. if (rg(k).gt. r_g(1)) then - nig = NINT(ALOG10(rg(k))) + nig = nint(log10(rg(k))) do_loop_rg: do nn = nig-1, nig+1 n = nn if ( (rg(k)/10.**nn).ge.1.0 .and. (rg(k)/10.**nn).lt.10.0 ) exit do_loop_rg enddo do_loop_rg - idx_g = INT(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2) - idx_g = MAX(1, MIN(idx_g, ntb_g)) + idx_g = int(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2) + idx_g = max(1, min(idx_g, ntb_g)) lamg = 1./ilamg(k) lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g N0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1) - nig = NINT(DLOG10(N0_exp)) + nig = nint(log10(real(N0_exp, kind=dp))) do_loop_ng: do nn = nig-1, nig+1 n = nn if ( (N0_exp/10.**nn).ge.1.0 .and. (N0_exp/10.**nn).lt.10.0 ) exit do_loop_ng enddo do_loop_ng - idx_g1 = INT(N0_exp/10.**n) + 10*(n-nig3) - (n-nig3) - idx_g1 = MAX(1, MIN(idx_g1, ntb_g1)) + idx_g1 = int(N0_exp/10.**n) + 10*(n-nig3) - (n-nig3) + idx_g1 = max(1, min(idx_g1, ntb_g1)) else idx_g = 1 idx_g1 = ntb_g1 @@ -2684,7 +2685,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & gamsc = lsub*diffu(k)/tcond(k) * rvs_p alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & * rvs_pp/rvs_p * rvs/rvs_p - alphsc = MAX(1.E-9, alphsc) + alphsc = max(1.E-9, alphsc) xsat = ssati(k) if (abs(xsat).lt. 1.E-9) xsat=0. t1_subl = 4.*PI*( 1.0 - alphsc*xsat & @@ -2695,13 +2696,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Snow collecting cloud water. In CE, assume Dc< - Graupel collecting cloud water. In CE, assume Dc< - Rain collecting snow. Cannot assume Wisner (1972) approximation @@ -2767,20 +2768,20 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r) & + tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & + tms_sacr1(idx_s,idx_t,idx_r1,idx_r) - prr_rcs(k) = MAX(DBLE(-rr(k)*odts), prr_rcs(k)) - prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k)) - prg_rcs(k) = MIN(DBLE((rr(k)+rs(k))*odts), prg_rcs(k)) + prr_rcs(k) = max(real(-rr(k)*odts, kind=dp), prr_rcs(k)) + prs_rcs(k) = max(real(-rs(k)*odts, kind=dp), prs_rcs(k)) + prg_rcs(k) = min(real((rr(k)+rs(k))*odts, kind=dp), prg_rcs(k)) pnr_rcs(k) = tnr_racs1(idx_s,idx_t,idx_r1,idx_r) & ! RAIN2M + tnr_racs2(idx_s,idx_t,idx_r1,idx_r) & + tnr_sacr1(idx_s,idx_t,idx_r1,idx_r) & + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r) - pnr_rcs(k) = MIN(DBLE(nr(k)*odts), pnr_rcs(k)) + pnr_rcs(k) = min(real(nr(k)*odts, kind=dp), pnr_rcs(k)) else prs_rcs(k) = -tcs_racs1(idx_s,idx_t,idx_r1,idx_r) & - tms_sacr1(idx_s,idx_t,idx_r1,idx_r) & + tmr_racs2(idx_s,idx_t,idx_r1,idx_r) & + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) - prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k)) + prs_rcs(k) = max(real(-rs(k)*odts, kind=dp), prs_rcs(k)) prr_rcs(k) = -prs_rcs(k) endif endif @@ -2792,14 +2793,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (temp(k).lt.T_0) then prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) & + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r) - prg_rcg(k) = MIN(DBLE(rr(k)*odts), prg_rcg(k)) + prg_rcg(k) = min(real(rr(k)*odts, kind=dp), prg_rcg(k)) prr_rcg(k) = -prg_rcg(k) pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r) & ! RAIN2M + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) - pnr_rcg(k) = MIN(DBLE(nr(k)*odts), pnr_rcg(k)) + pnr_rcg(k) = min(real(nr(k)*odts, kind=dp), pnr_rcg(k)) else prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r) - prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k)) + prr_rcg(k) = min(real(rg(k)*odts, kind=dp), prr_rcg(k)) prg_rcg(k) = -prr_rcg(k) !> - Put in explicit drop break-up due to collisions. pnr_rcg(k) = -1.5*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M @@ -2813,14 +2814,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Deposition/sublimation of snow/graupel follows Srivastava & Coen (1992) if (L_qs(k)) then C_snow = C_sqrd + (tempc+1.5)*(C_cube-C_sqrd)/(-30.+1.5) - C_snow = MAX(C_sqrd, MIN(C_snow, C_cube)) + C_snow = max(C_sqrd, min(C_snow, C_cube)) prs_sde(k) = C_snow*t1_subl*diffu(k)*ssati(k)*rvs & * (t1_qs_sd*smo1(k) & + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) if (prs_sde(k).lt. 0.) then - prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k), DBLE(rate_max)) + prs_sde(k) = max(real(-rs(k)*odts, kind=dp), prs_sde(k), real(rate_max, kind=dp)) else - prs_sde(k) = MIN(prs_sde(k), DBLE(rate_max)) + prs_sde(k) = min(prs_sde(k), real(rate_max, kind=dp)) endif endif @@ -2829,9 +2830,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) if (prg_gde(k).lt. 0.) then - prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k), DBLE(rate_max)) + prg_gde(k) = max(real(-rg(k)*odts, kind=dp), prg_gde(k), real(rate_max, kind=dp)) else - prg_gde(k) = MIN(prg_gde(k), DBLE(rate_max)) + prg_gde(k) = min(prg_gde(k), real(rate_max, kind=dp)) endif endif @@ -2841,9 +2842,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! be revisited. if (prs_scw(k).gt.5.0*prs_sde(k) .and. & prs_sde(k).gt.eps) then - r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k)) - g_frac = MIN(0.75, 0.15 + (r_frac-5.)*.028) - vts_boost(k) = MIN(1.5, 1.1 + (r_frac-5.)*.016) + r_frac = min(30.0_dp, prs_scw(k)/prs_sde(k)) + g_frac = min(0.75, 0.15 + (r_frac-5.)*.028) + vts_boost(k) = min(1.5, 1.1 + (r_frac-5.)*.016) prg_scw(k) = g_frac*prs_scw(k) prs_scw(k) = (1. - g_frac)*prs_scw(k) endif @@ -2879,13 +2880,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Ice nuclei lookup table index. if (xni.gt. Nt_IN(1)) then - niin = NINT(ALOG10(xni)) + niin = nint(log10(xni)) do_loop_xni: do nn = niin-1, niin+1 n = nn if ( (xni/10.**nn).ge.1.0 .and. (xni/10.**nn).lt.10.0 ) exit do_loop_xni enddo do_loop_xni - idx_IN = INT(xni/10.**n) + 10*(n-niin2) - (n-niin2) - idx_IN = MAX(1, MIN(idx_IN, ntb_IN)) + idx_IN = int(xni/10.**n) + 10*(n-niin2) - (n-niin2) + idx_IN = max(1, min(idx_IN, ntb_IN)) else idx_IN = 1 endif @@ -2896,7 +2897,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pri_rfz(k) = tpi_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts pni_rfz(k) = tni_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts pnr_rfz(k) = tnr_qrfz(idx_r,idx_r1,idx_tc,idx_IN)*odts ! RAIN2M - pnr_rfz(k) = MIN(DBLE(nr(k)*odts), pnr_rfz(k)) + pnr_rfz(k) = min(real(nr(k)*odts, kind=dp), pnr_rfz(k)) elseif (rr(k).gt. R1 .and. temp(k).lt.HGFR) then pri_rfz(k) = rr(k)*odts pni_rfz(k) = pnr_rfz(k) @@ -2904,9 +2905,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (rc(k).gt. r_c(1)) then pri_wfz(k) = tpi_qcfz(idx_c,idx_n,idx_tc,idx_IN)*odts - pri_wfz(k) = MIN(DBLE(rc(k)*odts), pri_wfz(k)) + pri_wfz(k) = min(real(rc(k)*odts, kind=dp), pri_wfz(k)) pni_wfz(k) = tni_qcfz(idx_c,idx_n,idx_tc,idx_IN)*odts - pni_wfz(k) = MIN(DBLE(nc(k)*odts), pri_wfz(k)/(2.*xm0i), & + pni_wfz(k) = min(real(nc(k)*odts, kind=dp), pri_wfz(k)/(2.0_dp*xm0i), & pni_wfz(k)) elseif (rc(k).gt. R1 .and. temp(k).lt.HGFR) then pri_wfz(k) = rc(k)*odts @@ -2921,11 +2922,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xnc = iceDeMott(tempc,qv(k),qvs(k),qvsi(k),rho(k),nifa(k)) xnc = xnc*(1.0 + 50.*rand3) else - xnc = MIN(1000.E3, TNO*EXP(ATO*(T_0-temp(k)))) + xnc = min(1000.E3, TNO*EXP(ATO*(T_0-temp(k)))) endif xni = ni(k) + (pni_rfz(k)+pni_wfz(k))*dtsave pni_inu(k) = 0.5*(xnc-xni + abs(xnc-xni))*odts - pri_inu(k) = MIN(DBLE(rate_max), xm0i*pni_inu(k)) + pri_inu(k) = min(real(rate_max, kind=dp), xm0i*pni_inu(k)) pni_inu(k) = pri_inu(k)/xm0i endif @@ -2935,7 +2936,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts - pri_iha(k) = MIN(DBLE(rate_max), xm0i*0.1*pni_iha(k)) + pri_iha(k) = min(real(rate_max, kind=dp), xm0i*0.1*pni_iha(k)) pni_iha(k) = pri_iha(k)/(xm0i*0.1) endif !+---+------------------ END NEW ICE NUCLEATION -----------------------+ @@ -2945,19 +2946,19 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (L_qi(k)) then lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi ilami = 1./lami - xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami) + xDi = max(real(D0i, kind=dp), (bm_i + mu_i + 1.) * ilami) xmi = am_i*xDi**bm_i oxmi = 1./xmi pri_ide(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & *oig1*cig(5)*ni(k)*ilami if (pri_ide(k) .lt. 0.0) then - pri_ide(k) = MAX(DBLE(-ri(k)*odts), pri_ide(k), DBLE(rate_max)) + pri_ide(k) = max(real(-ri(k)*odts, kind=dp), pri_ide(k), real(rate_max, kind=dp)) pni_ide(k) = pri_ide(k)*oxmi - pni_ide(k) = MAX(DBLE(-ni(k)*odts), pni_ide(k)) + pni_ide(k) = max(real(-ni(k)*odts, kind=dp), pni_ide(k)) else - pri_ide(k) = MIN(pri_ide(k), DBLE(rate_max)) - prs_ide(k) = (1.0D0-tpi_ide(idx_i,idx_i1))*pri_ide(k) + pri_ide(k) = min(pri_ide(k), real(rate_max, kind=dp)) + prs_ide(k) = (1.0_dp-tpi_ide(idx_i,idx_i1))*pri_ide(k) pri_ide(k) = tpi_ide(idx_i,idx_i1)*pri_ide(k) endif @@ -2971,9 +2972,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pni_iau(k) = 0. else prs_iau(k) = tps_iaus(idx_i,idx_i1)*odts - prs_iau(k) = MIN(DBLE(ri(k)*.99*odts), prs_iau(k)) + prs_iau(k) = min(real(ri(k)*.99*odts, kind=dp), prs_iau(k)) pni_iau(k) = tni_iaus(idx_i,idx_i1)*odts - pni_iau(k) = MIN(DBLE(ni(k)*.95*odts), pni_iau(k)) + pni_iau(k) = min(real(ni(k)*.95*odts, kind=dp), pni_iau(k)) endif endif @@ -2981,7 +2982,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (L_qi(k)) then lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi ilami = 1./lami - xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami) + xDi = max(real(D0i, kind=dp), (bm_i + mu_i + 1.) * ilami) xmi = am_i*xDi**bm_i oxmi = 1./xmi if (rs(k).ge. r_s(1)) then @@ -2999,7 +3000,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pni_rci(k) = pri_rci(k) * oxmi prr_rci(k) = rhof(k)*t2_qr_qi*Ef_ri*ni(k)*N0_r(k) & *((lamr+fv_r)**(-cre(8))) - prr_rci(k) = MIN(DBLE(rr(k)*odts), prr_rci(k)) + prr_rci(k) = min(real(rr(k)*odts, kind=dp), prr_rci(k)) prg_rci(k) = pri_rci(k) + prr_rci(k) endif endif @@ -3030,15 +3031,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (prr_sml(k) .gt. 0.) then prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & * (prr_rcs(k)+prs_scw(k)) - prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k)) + prr_sml(k) = min(real(rs(k)*odts, kind=dp), prr_sml(k)) pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M - pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) + pnr_sml(k) = min(real(smo0(k)*odts, kind=dp), pnr_sml(k)) elseif (ssati(k).lt. 0.) then prr_sml(k) = 0.0 prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & * (t1_qs_sd*smo1(k) & + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k)) - prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k)) + prs_sde(k) = max(real(-rs(k)*odts, kind=dp), prs_sde(k)) endif endif @@ -3047,7 +3048,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & * N0_g(k)*(t1_qg_me*ilamg(k)**cge(10) & + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11)) if (prr_gml(k) .gt. 0.) then - prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k)) + prr_gml(k) = min(real(rg(k)*odts, kind=dp), prr_gml(k)) pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M * prr_gml(k) * 10.0**(-0.5*tempc) elseif (ssati(k).lt. 0.) then @@ -3055,7 +3056,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) & + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11)) - prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k)) + prg_gde(k) = max(real(-rg(k)*odts, kind=dp), prg_gde(k)) endif endif @@ -3163,11 +3164,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Re-enforce proper mass conservation for subsequent elements in case !! any of the above terms were altered. Thanks P. Blossey. 2009Sep28 pri_ihm(k) = prs_ihm(k) + prg_ihm(k) - ratio = MIN( ABS(prr_rcg(k)), ABS(prg_rcg(k)) ) + ratio = min( ABS(prr_rcg(k)), ABS(prg_rcg(k)) ) prr_rcg(k) = ratio * SIGN(1.0, SNGL(prr_rcg(k))) prg_rcg(k) = -prr_rcg(k) if (temp(k).gt.T_0) then - ratio = MIN( ABS(prr_rcs(k)), ABS(prs_rcs(k)) ) + ratio = min( ABS(prr_rcs(k)), ABS(prs_rcs(k)) ) prr_rcs(k) = ratio * SIGN(1.0, SNGL(prr_rcs(k))) prs_rcs(k) = -prr_rcs(k) endif @@ -3213,16 +3214,16 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Cloud water mass/number balance; keep mass-wt mean size between !! 1 and 50 microns. Also no more than Nt_c_max drops total. - xrc=MAX(R1, (qc1d(k) + qcten(k)*dtsave)*rho(k)) - xnc=MAX(2., (nc1d(k) + ncten(k)*dtsave)*rho(k)) + xrc=max(R1, (qc1d(k) + qcten(k)*dtsave)*rho(k)) + xnc=max(2., (nc1d(k) + ncten(k)*dtsave)*rho(k)) if (xrc .gt. R1) then if (xnc.gt.10000.E6) then nu_c = 2 elseif (xnc.lt.100.) then nu_c = 15 else - nu_c = NINT(1000.E6/xnc) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + nu_c = nint(1000.E6/xnc) + 2 + nu_c = max(2, min(nu_c+nint(rand2), 15)) endif lamc = (xnc*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr xDc = (bm_r + nu_c + 1.) / lamc @@ -3238,7 +3239,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & else ncten(k) = -nc1d(k)*odts endif - xnc=MAX(0.,(nc1d(k) + ncten(k)*dtsave)*rho(k)) + xnc=max(0.,(nc1d(k) + ncten(k)*dtsave)*rho(k)) if (xnc.gt.Nt_c_max) & ncten(k) = (Nt_c_max-nc1d(k)*rho(k))*odts*orho @@ -3256,15 +3257,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Cloud ice mass/number balance; keep mass-wt mean size between !! 5 and 300 microns. Also no more than 500 xtals per liter. - xri=MAX(R1,(qi1d(k) + qiten(k)*dtsave)*rho(k)) - xni=MAX(R2,(ni1d(k) + niten(k)*dtsave)*rho(k)) + xri=max(R1,(qi1d(k) + qiten(k)*dtsave)*rho(k)) + xni=max(R2,(ni1d(k) + niten(k)*dtsave)*rho(k)) if (xri.gt. R1) then lami = (am_i*cig(2)*oig1*xni/xri)**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(4999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = min(4999.e3_dp, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -3274,7 +3275,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & else niten(k) = -ni1d(k)*odts endif - xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) + xni=max(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) if (xni.gt.4999.E3) & niten(k) = (4999.E3-ni1d(k)*rho(k))*odts*orho @@ -3293,8 +3294,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Rain mass/number balance; keep median volume diameter between !! 37 microns (D0r*0.75) and 2.5 mm. - xrr=MAX(R1,(qr1d(k) + qrten(k)*dtsave)*rho(k)) - xnr=MAX(R2,(nr1d(k) + nrten(k)*dtsave)*rho(k)) + xrr=max(R1,(qr1d(k) + qrten(k)*dtsave)*rho(k)) + xnr=max(R2,(nr1d(k) + nrten(k)*dtsave)*rho(k)) if (xrr.gt. R1) then lamr = (am_r*crg(3)*org2*xnr/xrr)**obmr mvd_r(k) = (3.0 + mu_r + 0.672) / lamr @@ -3356,8 +3357,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & temp(k) = t1d(k) + DT*tten(k) otemp = 1./temp(k) tempc = temp(k) - 273.15 - qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + qv(k) = max(1.E-10, qv1d(k) + DT*qvten(k)) + rho(k) = RoverRv*pres(k) / (R*temp(k)*(qv(k)+RoverRv)) rhof(k) = SQRT(RHO_NOT/rho(k)) rhof2(k) = SQRT(rhof(k)) qvs(k) = rslf(pres(k), temp(k)) @@ -3375,13 +3376,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ocp(k) = 1./(Cp*(1.+0.887*qv(k))) lvt2(k)=lvap(k)*lvap(k)*ocp(k)*oRv*otemp*otemp if (is_aerosol_aware) & - nwfa(k) = MAX(11.1E6*rho(k), (nwfa1d(k) + nwfaten(k)*DT)*rho(k)) + nwfa(k) = max(11.1E6*rho(k), (nwfa1d(k) + nwfaten(k)*DT)*rho(k)) enddo do k = kts, kte if ((qc1d(k) + qcten(k)*DT) .gt. R1) then rc(k) = (qc1d(k) + qcten(k)*DT)*rho(k) - nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) + nc(k) = max(2., min((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then if(lsml == 1) then nc(k) = Nt_c_l @@ -3398,7 +3399,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if ((qi1d(k) + qiten(k)*DT) .gt. R1) then ri(k) = (qi1d(k) + qiten(k)*DT)*rho(k) - ni(k) = MAX(R2, (ni1d(k) + niten(k)*DT)*rho(k)) + ni(k) = max(R2, (ni1d(k) + niten(k)*DT)*rho(k)) L_qi(k) = .true. else ri(k) = R1 @@ -3408,7 +3409,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if ((qr1d(k) + qrten(k)*DT) .gt. R1) then rr(k) = (qr1d(k) + qrten(k)*DT)*rho(k) - nr(k) = MAX(R2, (nr1d(k) + nrten(k)*DT)*rho(k)) + nr(k) = max(R2, (nr1d(k) + nrten(k)*DT)*rho(k)) L_qr(k) = .true. lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr mvd_r(k) = (3.0 + mu_r + 0.672) / lamr @@ -3457,7 +3458,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo do k = kts, kte if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) + tc0 = min(-0.1, temp(k)-273.15) smob(k) = rs(k)*oams !> - All other moments based on reference, 2nd moment. If bm_s.ne.2, @@ -3547,7 +3548,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ ! DROPLET NUCLEATION if (clap .gt. eps) then if (is_aerosol_aware .or. merra2_aerosol_aware) then - xnc = MAX(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml)) + xnc = max(2., activ_ncloud(temp(k), w1d(k)+rand3, nwfa(k), lsml)) else if(lsml == 1) then xnc = Nt_c_l @@ -3571,7 +3572,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & * rvs_pp/rvs_p * rvs/rvs_p - alphsc = MAX(1.E-9, alphsc) + alphsc = max(1.E-9, alphsc) xsat = ssatw(k) if (abs(xsat).lt. 1.E-9) xsat=0. t1_evap = 2.*PI*( 1.0 - alphsc*xsat & @@ -3579,30 +3580,30 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & / (1.+gamsc) - Dc_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) & + Dc_star = sqrt(-2.0_dp*DT * t1_evap/(2.*PI) & * 4.*diffu(k)*ssatw(k)*rvs/rho_w) - idx_d = MAX(1, MIN(INT(1.E6*Dc_star), nbc)) + idx_d = max(1, min(int(1.E6*Dc_star), nbc)) - idx_n = NINT(1.0 + FLOAT(nbc) * DLOG(nc(k)/t_Nc(1)) / nic1) - idx_n = MAX(1, MIN(idx_n, nbc)) + idx_n = nint(1.0 + real(nbc, kind=wp) * log(real(nc(k)/t_Nc(1), kind=dp)) / nic1) + idx_n = max(1, min(idx_n, nbc)) !> - Cloud water lookup table index. if (rc(k).gt. r_c(1)) then - nic = NINT(ALOG10(rc(k))) + nic = nint(log10(rc(k))) do_loop_rc_cond: do nn = nic-1, nic+1 n = nn if ( (rc(k)/10.**nn).ge.1.0 .and. (rc(k)/10.**nn).lt.10.0 ) exit do_loop_rc_cond enddo do_loop_rc_cond - idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) - idx_c = MAX(1, MIN(idx_c, ntb_c)) + idx_c = int(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2) + idx_c = max(1, min(idx_c, ntb_c)) else idx_c = 1 endif - !prw_vcd(k) = MAX(DBLE(-rc(k)*orho*odt), & + !prw_vcd(k) = max(real(-rc(k)*orho*odt, kind=dp), & ! -tpc_wev(idx_d, idx_c, idx_n)*orho*odt) - prw_vcd(k) = MAX(DBLE(-rc(k)*0.99*orho*odt), prw_vcd(k)) - pnc_wcd(k) = MAX(DBLE(-nc(k)*0.99*orho*odt), & + prw_vcd(k) = max(real(-rc(k)*0.99*orho*odt, kind=dp), prw_vcd(k)) + pnc_wcd(k) = max(real(-nc(k)*0.99*orho*odt, kind=dp), & -tnc_wev(idx_d, idx_c, idx_n)*orho*odt) endif @@ -3619,9 +3620,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (is_aerosol_aware) & nwfaten(k) = nwfaten(k) - pnc_wcd(k) tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY) - rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k)) + rc(k) = max(R1, (qc1d(k) + DT*qcten(k))*rho(k)) if (rc(k).eq.R1) L_qc(k) = .false. - nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) + nc(k) = max(2., min((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then if(lsml == 1) then nc(k) = Nt_c_l @@ -3629,9 +3630,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nc(k) = Nt_c_o endif endif - qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) + qv(k) = max(1.E-10, qv1d(k) + DT*qvten(k)) temp(k) = t1d(k) + DT*tten(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + rho(k) = RoverRv*pres(k) / (R*temp(k)*(qv(k)+RoverRv)) qvs(k) = rslf(pres(k), temp(k)) ssatw(k) = qv(k)/qvs(k) - 1. endif @@ -3669,8 +3670,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) & * rvs_pp/rvs_p * rvs/rvs_p - alphsc = MAX(1.E-9, alphsc) - xsat = MIN(-1.E-9, ssatw(k)) + alphsc = max(1.E-9, alphsc) + xsat = min(-1.E-9, ssatw(k)) t1_evap = 2.*PI*( 1.0 - alphsc*xsat & + 2.*alphsc*alphsc*xsat*xsat & - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) & @@ -3684,8 +3685,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*N0_r(k)*rvs & * (t1_qr_ev*ilamr(k)**cre(10) & + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11)))) - rate_max = MIN((rr(k)*orho*odts), (qvs(k)-qv(k))*odts) - prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)*orho) + rate_max = min((rr(k)*orho*odts), (qvs(k)-qv(k))*odts) + prv_rev(k) = min(real(rate_max, kind=dp), prv_rev(k)*orho) !..TEST: G. Thompson 10 May 2013 !> - Reduce the rain evaporation in same places as melting graupel occurs. @@ -3695,12 +3696,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! likely that the water-coated graupel evaporating much slower than !! if the water was immediately shed off. if (prr_gml(k).gt.0.0) then - eva_factor = MIN(1.0, 0.01+(0.99-0.01)*(tempc/20.0)) + eva_factor = min(1.0, 0.01+(0.99-0.01)*(tempc/20.0)) prv_rev(k) = prv_rev(k)*eva_factor endif endif - pnr_rev(k) = MIN(DBLE(nr(k)*0.99*orho*odts), & ! RAIN2M + pnr_rev(k) = min(real(nr(k)*0.99*orho*odts, kind=dp), & ! RAIN2M prv_rev(k) * nr(k)/rr(k)) qrten(k) = qrten(k) - prv_rev(k) @@ -3710,11 +3711,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nwfaten(k) = nwfaten(k) + pnr_rev(k) tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY) - rr(k) = MAX(R1, (qr1d(k) + DT*qrten(k))*rho(k)) - qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) - nr(k) = MAX(R2, (nr1d(k) + DT*nrten(k))*rho(k)) + rr(k) = max(R1, (qr1d(k) + DT*qrten(k))*rho(k)) + qv(k) = max(1.E-10, qv1d(k) + DT*qvten(k)) + nr(k) = max(R2, (nr1d(k) + DT*nrten(k))*rho(k)) temp(k) = t1d(k) + DT*tten(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + rho(k) = RoverRv*pres(k) / (R*temp(k)*(qv(k)+RoverRv)) endif enddo #if ( WRF_CHEM == 1 ) @@ -3773,14 +3774,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtnrk(k) = vtnrk(k+1) endif - if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then - ksed1(1) = MAX(ksed1(1), k) - delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k))) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + if (max(vtrk(k),vtnrk(k)) .gt. 1.E-3) then + ksed1(1) = max(ksed1(1), k) + delta_tp = dzq(k)/(max(vtrk(k),vtnrk(k))) + nstep = max(nstep, int(DT/delta_tp + 1.)) endif enddo if (ksed1(1) .eq. kte) ksed1(1) = kte-1 - if (nstep .gt. 0) onstep(1) = 1./REAL(nstep) + if (nstep .gt. 0) onstep(1) = 1./real(nstep, kind=wp) endif !+---+-----------------------------------------------------------------+ @@ -3801,8 +3802,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & elseif (nc(k).lt.100.) then nu_c = 15 else - nu_c = NINT(1000.E6/nc(k)) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + nu_c = nint(1000.E6/nc(k)) + 2 + nu_c = max(2, min(nu_c+nint(rand2), 15)) endif lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr ilamc = 1./lamc @@ -3839,13 +3840,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & endif if (vtik(k) .gt. 1.E-3) then - ksed1(2) = MAX(ksed1(2), k) + ksed1(2) = max(ksed1(2), k) delta_tp = dzq(k)/vtik(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + nstep = max(nstep, int(DT/delta_tp + 1.)) endif enddo if (ksed1(2) .eq. kte) ksed1(2) = kte-1 - if (nstep .gt. 0) onstep(2) = 1./REAL(nstep) + if (nstep .gt. 0) onstep(2) = 1./real(nstep, kind=wp) endif !+---+-----------------------------------------------------------------+ @@ -3869,7 +3870,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) if (prr_sml(k) .gt. 0.0) then - ! vtsk(k) = MAX(vts*vts_boost(k), & + ! vtsk(k) = max(vts*vts_boost(k), & ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) SR = rs(k)/(rs(k)+rr(k)) vtsk(k) = vts*SR + (1.-SR)*vtrk(k) @@ -3884,13 +3885,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & endif if (vtsk(k) .gt. 1.E-3) then - ksed1(3) = MAX(ksed1(3), k) + ksed1(3) = max(ksed1(3), k) delta_tp = dzq(k)/vtsk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + nstep = max(nstep, int(DT/delta_tp + 1.)) endif enddo if (ksed1(3) .eq. kte) ksed1(3) = kte-1 - if (nstep .gt. 0) onstep(3) = 1./REAL(nstep) + if (nstep .gt. 0) onstep(3) = 1./real(nstep, kind=wp) endif !+---+-----------------------------------------------------------------+ @@ -3903,7 +3904,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (rg(k).gt. R1) then vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g if (temp(k).gt. T_0) then - vtgk(k) = MAX(vtg, vtrk(k)) + vtgk(k) = max(vtg, vtrk(k)) else vtgk(k) = vtg endif @@ -3912,13 +3913,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & endif if (vtgk(k) .gt. 1.E-3) then - ksed1(4) = MAX(ksed1(4), k) + ksed1(4) = max(ksed1(4), k) delta_tp = dzq(k)/vtgk(k) - nstep = MAX(nstep, INT(DT/delta_tp + 1.)) + nstep = max(nstep, int(DT/delta_tp + 1.)) endif enddo if (ksed1(4) .eq. kte) ksed1(4) = kte-1 - if (nstep .gt. 0) onstep(4) = 1./REAL(nstep) + if (nstep .gt. 0) onstep(4) = 1./real(nstep, kind=wp) endif endif @@ -3929,7 +3930,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qr .eqv. .true.)) then - nstep = NINT(1./onstep(1)) + nstep = nint(1./onstep(1)) if(.not. sedi_semi) then do n = 1, nstep @@ -3942,8 +3943,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & orho = 1./rho(k) qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1)) - nr(k) = MAX(R2, nr(k) - sed_n(k)*odzq*DT*onstep(1)) + rr(k) = max(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1)) + nr(k) = max(R2, nr(k) - sed_n(k)*odzq*DT*onstep(1)) pfll1(k) = pfll1(k) + sed_r(k)*DT*onstep(1) do k = ksed1(1), kts, -1 odzq = 1./dzq(k) @@ -3952,9 +3953,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*onstep(1)*orho nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) & *odzq*onstep(1)*orho - rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & + rr(k) = max(R1, rr(k) + (sed_r(k+1)-sed_r(k)) & *odzq*DT*onstep(1)) - nr(k) = MAX(R2, nr(k) + (sed_n(k+1)-sed_n(k)) & + nr(k) = max(R2, nr(k) + (sed_n(k+1)-sed_n(k)) & *odzq*DT*onstep(1)) pfll1(k) = pfll1(k) + sed_r(k)*DT*onstep(1) enddo @@ -4018,15 +4019,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & orho = 1./rho(k) qcten(k) = qcten(k) + (sed_c(k+1)-sed_c(k)) *odzq*orho ncten(k) = ncten(k) + (sed_n(k+1)-sed_n(k)) *odzq*orho - rc(k) = MAX(R1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*DT) - nc(k) = MAX(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*DT) + rc(k) = max(R1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*DT) + nc(k) = max(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*DT) enddo endif !+---+-----------------------------------------------------------------+ if (ANY(L_qi .eqv. .true.)) then - nstep = NINT(1./onstep(2)) + nstep = nint(1./onstep(2)) do n = 1, nstep do k = kte, kts, -1 sed_i(k) = vtik(k)*ri(k) @@ -4037,8 +4038,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & orho = 1./rho(k) qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2)) - ni(k) = MAX(R2, ni(k) - sed_n(k)*odzq*DT*onstep(2)) + ri(k) = max(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2)) + ni(k) = max(R2, ni(k) - sed_n(k)*odzq*DT*onstep(2)) pfil1(k) = pfil1(k) + sed_i(k)*DT*onstep(2) do k = ksed1(2), kts, -1 odzq = 1./dzq(k) @@ -4047,9 +4048,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*onstep(2)*orho niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) & *odzq*onstep(2)*orho - ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & + ri(k) = max(R1, ri(k) + (sed_i(k+1)-sed_i(k)) & *odzq*DT*onstep(2)) - ni(k) = MAX(R2, ni(k) + (sed_n(k+1)-sed_n(k)) & + ni(k) = max(R2, ni(k) + (sed_n(k+1)-sed_n(k)) & *odzq*DT*onstep(2)) pfil1(k) = pfil1(k) + sed_i(k)*DT*onstep(2) enddo @@ -4063,7 +4064,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qs .eqv. .true.)) then - nstep = NINT(1./onstep(3)) + nstep = nint(1./onstep(3)) do n = 1, nstep do k = kte, kts, -1 sed_s(k) = vtsk(k)*rs(k) @@ -4072,14 +4073,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & odzq = 1./dzq(k) orho = 1./rho(k) qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3)) + rs(k) = max(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3)) pfil1(k) = pfil1(k) + sed_s(k)*DT*onstep(3) do k = ksed1(3), kts, -1 odzq = 1./dzq(k) orho = 1./rho(k) qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) & *odzq*onstep(3)*orho - rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & + rs(k) = max(R1, rs(k) + (sed_s(k+1)-sed_s(k)) & *odzq*DT*onstep(3)) pfil1(k) = pfil1(k) + sed_s(k)*DT*onstep(3) enddo @@ -4093,7 +4094,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ if (ANY(L_qg .eqv. .true.)) then - nstep = NINT(1./onstep(4)) + nstep = nint(1./onstep(4)) if(.not. sedi_semi) then do n = 1, nstep do k = kte, kts, -1 @@ -4103,14 +4104,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & odzq = 1./dzq(k) orho = 1./rho(k) qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4)) + rg(k) = max(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4)) pfil1(k) = pfil1(k) + sed_g(k)*DT*onstep(4) do k = ksed1(4), kts, -1 odzq = 1./dzq(k) orho = 1./rho(k) qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) & *odzq*onstep(4)*orho - rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & + rg(k) = max(R1, rg(k) + (sed_g(k+1)-sed_g(k)) & *odzq*DT*onstep(4)) pfil1(k) = pfil1(k) + sed_g(k)*DT*onstep(4) enddo @@ -4140,16 +4141,16 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & do k = kte, kts, -1 vtg = 0. if (rg(k).gt. R1) then - ygra1 = alog10(max(1.E-9, rg(k))) + ygra1 = log10(max(1.e-9_wp, rg(k))) zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) - N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) + N0_exp = max(real(gonv_min, kind=dp), min(N0_exp, real(gonv_max, kind=dp))) lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg vtg = rhof(k)*av_g*cgg(6)*ogg3 * (1./lamg)**bv_g if (temp(k).gt. T_0) then - vtgk(k) = MAX(vtg, vtrk(k)) + vtgk(k) = max(vtg, vtrk(k)) else vtgk(k) = vtg endif @@ -4165,7 +4166,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then do k = kts, kte - xri = MAX(0.0, qi1d(k) + qiten(k)*DT) + xri = max(0.0, qi1d(k) + qiten(k)*DT) if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then qcten(k) = qcten(k) + xri*odt ncten(k) = ncten(k) + ni1d(k)*odt @@ -4176,7 +4177,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) endif - xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) + xrc = max(0.0, qc1d(k) + qcten(k)*DT) if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then lfus2 = lsub - lvap(k) xnc = nc1d(k) + ncten(k)*DT @@ -4196,13 +4197,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !+---+-----------------------------------------------------------------+ do k = kts, kte t1d(k) = t1d(k) + tten(k)*DT - qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) + qv1d(k) = max(1.E-10, qv1d(k) + qvten(k)*DT) qc1d(k) = qc1d(k) + qcten(k)*DT - nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) + nc1d(k) = max(2./rho(k), min(nc1d(k) + ncten(k)*DT, Nt_c_max)) if (is_aerosol_aware) then - nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & + nwfa1d(k) = max(11.1E6, min(9999.E6, & (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & + nifa1d(k) = max(naIN1*0.01, min(9999.E6, & (nifa1d(k)+nifaten(k)*DT))) end if if (qc1d(k) .le. R1) then @@ -4214,8 +4215,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & elseif (nc1d(k)*rho(k).lt.100.) then nu_c = 15 else - nu_c = NINT(1000.E6/(nc1d(k)*rho(k))) + 2 - nu_c = MAX(2, MIN(nu_c+NINT(rand2), 15)) + nu_c = nint(1000.E6/(nc1d(k)*rho(k))) + 2 + nu_c = max(2, min(nu_c+nint(rand2), 15)) endif lamc = (am_r*ccg(2,nu_c)*ocg1(nu_c)*nc1d(k)/qc1d(k))**obmr xDc = (bm_r + nu_c + 1.) / lamc @@ -4224,12 +4225,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & elseif (xDc.gt. D0r*2.) then lamc = cce(2,nu_c)/(D0r*2.) endif - nc1d(k) = MIN(ccg(1,nu_c)*ocg2(nu_c)*qc1d(k)/am_r*lamc**bm_r,& - DBLE(Nt_c_max)/rho(k)) + nc1d(k) = min(ccg(1,nu_c)*ocg2(nu_c)*qc1d(k)/am_r*lamc**bm_r,& + real(Nt_c_max, kind=dp)/rho(k)) endif qi1d(k) = qi1d(k) + qiten(k)*DT - ni1d(k) = MAX(R2/rho(k), ni1d(k) + niten(k)*DT) + ni1d(k) = max(R2/rho(k), ni1d(k) + niten(k)*DT) if (qi1d(k) .le. R1) then qi1d(k) = 0.0 ni1d(k) = 0.0 @@ -4242,11 +4243,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 endif - ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 4999.D3/rho(k)) + ni1d(k) = min(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & + 4999.e3_dp/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT - nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) + nr1d(k) = max(R2/rho(k), nr1d(k) + nrten(k)*DT) if (qr1d(k) .le. R1) then qr1d(k) = 0.0 nr1d(k) = 0.0 @@ -4430,7 +4431,7 @@ subroutine qr_acr_qg write(0,*) "ThompMP: computing qr_acr_qg" endif do n2 = 1, nbr -! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) +! vr(n2) = av_r*Dr(n2)**bv_r * exp(real(-fv_r*Dr(n2), kind=dp)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) @@ -4457,7 +4458,7 @@ subroutine qr_acr_qg lamr = lam_exp * (crg(3)*org2*org1)**obmr N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2) + N_r(n2) = N0_r*Dr(n2)**mu_r *exp(real(-lamr*Dr(n2), kind=dp))*dtr(n2) enddo do j = 1, ntb_g @@ -4466,22 +4467,22 @@ subroutine qr_acr_qg lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg N0_g = N0g_exp(i)/(cgg(2)*lam_exp) * lamg**cge(2) do n = 1, nbg - N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n) + N_g(n) = N0_g*Dg(n)**mu_g * exp(real(-lamg*Dg(n), kind=dp))*dtg(n) enddo - t1 = 0.0d0 - t2 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - y1 = 0.0d0 - y2 = 0.0d0 + t1 = 0.0_dp + t2 = 0.0_dp + z1 = 0.0_dp + z2 = 0.0_dp + y1 = 0.0_dp + y2 = 0.0_dp do n2 = 1, nbr massr = am_r * Dr(n2)**bm_r do n = 1, nbg massg = am_g * Dg(n)**bm_g - dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n))) - dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2))) + dvg = 0.5d0*((vr(n2) - vg(n)) + abs(real(vr(n2)-vg(n), kind=dp))) + dvr = 0.5d0*((vg(n) - vr(n2)) + abs(real(vg(n)-vr(n2), kind=dp))) t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & *dvg*massg * N_g(n)* N_r(n2) @@ -4500,9 +4501,9 @@ subroutine qr_acr_qg 97 continue enddo tcg_racg(i,j,k,m) = t1 - tmr_racg(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) + tmr_racg(i,j,k,m) = min(z1, r_r(m)*1.0_dp) tcr_gacr(i,j,k,m) = t2 - tmg_gacr(i,j,k,m) = DMIN1(z2, r_g(j)*1.0d0) + tmg_gacr(i,j,k,m) = min(z2, r_g(j)*1.0_dp) tnr_racg(i,j,k,m) = y1 tnr_gacr(i,j,k,m) = y2 enddo @@ -4612,14 +4613,14 @@ subroutine qr_acr_qs write(0,*) "ThompMP: computing qr_acr_qs" endif do n2 = 1, nbr -! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) +! vr(n2) = av_r*Dr(n2)**bv_r * exp(real(-fv_r*Dr(n2), kind=dp)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) D1(n2) = (vr(n2)/av_s)**(1./bv_s) enddo do n = 1, nbs - vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n)) + vs(n) = 1.5*av_s*Ds(n)**bv_s * exp(real(-fv_s*Ds(n), kind=dp)) enddo !..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for @@ -4640,7 +4641,7 @@ subroutine qr_acr_qs lamr = lam_exp * (crg(3)*org2*org1)**obmr N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r * DEXP(-lamr*Dr(n2))*dtr(n2) + N_r(n2) = N0_r*Dr(n2)**mu_r * exp(real(-lamr*Dr(n2), kind=dp))*dtr(n2) enddo do j = 1, ntb_t @@ -4650,7 +4651,7 @@ subroutine qr_acr_qs !.. using bm_s=2, then we must transform to the pure 2nd moment !.. (variable called "second") and then to the bm_s+1 moment. - M2 = r_s(i)*oams *1.0d0 + M2 = r_s(i)*oams*1.0_dp if (bm_s.gt.2.0-1.E-3 .and. bm_s.lt.2.0+1.E-3) then loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*bm_s & + sa(4)*Tc(j)*bm_s + sa(5)*Tc(j)*Tc(j) & @@ -4687,22 +4688,22 @@ subroutine qr_acr_qs slam2 = M2 * oM3 * Lam1 do n = 1, nbs - N_s(n) = Mrat*(Kap0*DEXP(-slam1*Ds(n)) & - + Kap1*M0*Ds(n)**mu_s * DEXP(-slam2*Ds(n)))*dts(n) + N_s(n) = Mrat*(Kap0*exp(real(-slam1*Ds(n), kind=dp)) & + + Kap1*M0*Ds(n)**mu_s * exp(real(-slam2*Ds(n), kind=dp)))*dts(n) enddo - t1 = 0.0d0 - t2 = 0.0d0 - t3 = 0.0d0 - t4 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - z3 = 0.0d0 - z4 = 0.0d0 - y1 = 0.0d0 - y2 = 0.0d0 - y3 = 0.0d0 - y4 = 0.0d0 + t1 = 0.0_dp + t2 = 0.0_dp + t3 = 0.0_dp + t4 = 0.0_dp + z1 = 0.0_dp + z2 = 0.0_dp + z3 = 0.0_dp + z4 = 0.0_dp + y1 = 0.0_dp + y2 = 0.0_dp + y3 = 0.0_dp + y4 = 0.0_dp do n2 = 1, nbr massr = am_r * Dr(n2)**bm_r do n = 1, nbs @@ -4746,7 +4747,7 @@ subroutine qr_acr_qs enddo enddo tcs_racs1(i,j,k,m) = t1 - tmr_racs1(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) + tmr_racs1(i,j,k,m) = min(z1, r_r(m)*1.0_dp) tcs_racs2(i,j,k,m) = t3 tmr_racs2(i,j,k,m) = z3 tcr_sacr1(i,j,k,m) = t2 @@ -4806,8 +4807,8 @@ subroutine freezeH2O(threads) real(kind_dbl_prec) :: sum1, sum2, sumn1, sumn2, & prob, vol, Texp, orho_w, & lam_exp, lamr, N0_r, lamc, N0_c, y - integer:: nu_c - REAL:: T_adjust + integer :: nu_c + real(kind_phys) :: T_adjust logical force_read_thompson, write_thompson_tables logical lexist,lopen integer good,ierr @@ -4878,10 +4879,10 @@ subroutine freezeH2O(threads) !..Freeze water (smallest drops become cloud ice, otherwise graupel). do m = 1, ntb_IN - T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) + T_adjust = max(-3.0, min(3.0 - log10(Nt_IN(m)), 3.0)) do k = 1, 45 ! print*, ' Freezing water for temp = ', -k - Texp = DEXP( DFLOAT(k) - T_adjust*1.0D0 ) - 1.0D0 + Texp = exp( real(k, kind=dp) - T_adjust*1.0_dp ) - 1.0_dp !$OMP PARALLEL DO SCHEDULE(dynamic) num_threads(threads) & !$OMP PRIVATE(j,i,lam_exp,lamr,N0_r,sum1,sum2,sumn1,sumn2,n2,N_r,vol,prob) do j = 1, ntb_r1 @@ -4889,14 +4890,14 @@ subroutine freezeH2O(threads) lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1 lamr = lam_exp * (crg(3)*org2*org1)**obmr N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) - sum1 = 0.0d0 - sum2 = 0.0d0 - sumn1 = 0.0d0 - sumn2 = 0.0d0 + sum1 = 0.0_dp + sum2 = 0.0_dp + sumn1 = 0.0_dp + sumn2 = 0.0_dp do n2 = nbr, 1, -1 - N_r = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) + N_r = N0_r*Dr(n2)**mu_r*exp(real(-lamr*Dr(n2), kind=dp))*dtr(n2) vol = massr(n2)*orho_w - prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)) + prob = max(0.0_dp, 1.0_dp - exp(-120.0_dp*vol*5.2e-4_dp * Texp)) if (massr(n2) .lt. xm0g) then sumn1 = sumn1 + prob*N_r sum1 = sum1 + prob*N_r*massr(n2) @@ -4917,17 +4918,17 @@ subroutine freezeH2O(threads) !$OMP PARALLEL DO SCHEDULE(dynamic) num_threads(threads) & !$OMP PRIVATE(j,i,nu_c,lamc,N0_c,sum1,sumn2,vol,prob,N_c) do j = 1, nbc - nu_c = MIN(15, NINT(1000.E6/t_Nc(j)) + 2) + nu_c = min(15, nint(1000.E6/t_Nc(j)) + 2) do i = 1, ntb_c lamc = (t_Nc(j)*am_r* ccg(2,nu_c) * ocg1(nu_c) / r_c(i))**obmr N0_c = t_Nc(j)*ocg1(nu_c) * lamc**cce(1,nu_c) - sum1 = 0.0d0 - sumn2 = 0.0d0 + sum1 = 0.0_dp + sumn2 = 0.0_dp do n = nbc, 1, -1 vol = massc(n)*orho_w - prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)) + prob = max(0.0_dp, 1.0_dp - exp(-120.0_dp*vol*5.2e-4_dp * Texp)) N_c = N0_c*Dc(n)**nu_c*EXP(-lamc*Dc(n))*dtc(n) - sumn2 = MIN(t_Nc(j), sumn2 + prob*N_c) + sumn2 = min(t_Nc(j), sumn2 + prob*N_c) sum1 = sum1 + prob*N_c*massc(n) if (sum1 .ge. r_c(i)) EXIT enddo @@ -4978,7 +4979,7 @@ subroutine qi_aut_qs integer:: i, j, n2 real(kind_dbl_prec), dimension(nbi):: N_i real(kind_dbl_prec) :: N0_i, lami, Di_mean, t1, t2 - REAL:: xlimit_intg + real(kind_phys) :: xlimit_intg !+---+ @@ -4987,21 +4988,21 @@ subroutine qi_aut_qs lami = (am_i*cig(2)*oig1*Nt_i(j)/r_i(i))**obmi Di_mean = (bm_i + mu_i + 1.) / lami N0_i = Nt_i(j)*oig1 * lami**cie(1) - t1 = 0.0d0 - t2 = 0.0d0 + t1 = 0.0_dp + t2 = 0.0_dp if (SNGL(Di_mean) .gt. 5.*D0s) then t1 = r_i(i) t2 = Nt_i(j) - tpi_ide(i,j) = 0.0D0 + tpi_ide(i,j) = 0.0_dp elseif (SNGL(Di_mean) .lt. D0i) then - t1 = 0.0D0 - t2 = 0.0D0 - tpi_ide(i,j) = 1.0D0 + t1 = 0.0_dp + t2 = 0.0_dp + tpi_ide(i,j) = 1.0_dp else xlimit_intg = lami*D0s - tpi_ide(i,j) = GAMMP(mu_i+2.0, xlimit_intg) * 1.0D0 + tpi_ide(i,j) = GAMMP(mu_i+2.0, xlimit_intg) * 1.0_dp do n2 = 1, nbi - N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2) + N_i(n2) = N0_i*Di(n2)**mu_i * exp(real(-lami*Di(n2), kind=dp))*dti(n2) if (Di(n2).ge.D0s) then t1 = t1 + N_i(n2) * am_i*Di(n2)**bm_i t2 = t2 + N_i(n2) @@ -5036,7 +5037,7 @@ subroutine table_Efrw if (Dr(i).lt.50.E-6 .or. Dc(j).lt.3.E-6) then t_Efrw(i,j) = 0.0 elseif (p.gt.0.25) then - X = Dc(j)*1.D6 + X = Dc(j)*1.e6_dp if (Dr(i) .lt. 75.e-6) then Ef_rw = 0.026794*X - 0.20604 elseif (Dr(i) .lt. 125.e-6) then @@ -5061,17 +5062,17 @@ subroutine table_Efrw stokes = Dc(j)*Dc(j)*vtr*rho_w/(9.*1.718E-5*Dr(i)) reynolds = 9.*stokes/(p*p*rho_w) - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) + F = log(real(reynolds, kind=dp)) + G = -0.1007_dp - 0.358_dp*F + 0.0261_dp*F*F + K0 = exp(G) + z = log(stokes/(K0+1.e-15_dp)) H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) + yc0 = 2.0_dp/PI * ATAN(H) Ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) endif - t_Efrw(i,j) = MAX(0.0, MIN(SNGL(Ef_rw), 0.95)) + t_Efrw(i,j) = max(0.0, min(SNGL(Ef_rw), 0.95)) enddo enddo @@ -5093,9 +5094,9 @@ subroutine table_Efsw integer:: i, j do j = 1, nbc - vtc = 1.19D4 * (1.0D4*Dc(j)*Dc(j)*0.25D0) + vtc = 1.19e4_dp * (1.0e4_dp*Dc(j)*Dc(j)*0.25_dp) do i = 1, nbs - vts = av_s*Ds(i)**bv_s * DEXP(-fv_s*Ds(i)) - vtc + vts = av_s*Ds(i)**bv_s * exp(real(-fv_s*Ds(i), kind=dp)) - vtc Ds_m = (am_s*Ds(i)**bm_s / am_r)**obmr p = Dc(j)/Ds_m if (p.gt.0.25 .or. Ds(i).lt.D0s .or. Dc(j).lt.6.E-6 & @@ -5105,15 +5106,15 @@ subroutine table_Efsw stokes = Dc(j)*Dc(j)*vts*rho_w/(9.*1.718E-5*Ds_m) reynolds = 9.*stokes/(p*p*rho_w) - F = DLOG(reynolds) - G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F - K0 = DEXP(G) - z = DLOG(stokes/(K0+1.D-15)) + F = log(real(reynolds, kind=dp)) + G = -0.1007_dp - 0.358_dp*F + 0.0261_dp*F*F + K0 = exp(G) + z = log(stokes/(K0+1.e-15_dp)) H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z - yc0 = 2.0D0/PI * ATAN(H) + yc0 = 2.0_dp/PI * ATAN(H) Ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p)) - t_Efsw(i,j) = MAX(0.0, MIN(SNGL(Ef_sw), 0.95)) + t_Efsw(i,j) = max(0.0, min(SNGL(Ef_sw), 0.95)) endif enddo @@ -5160,7 +5161,7 @@ real function Eff_aero(D, Da, visc,rhoa,Temp,species) + 4.*Da/D * (0.02 + Da/D*(1.+2.*SQRT(Re))) if (St.gt.St2) Eff = Eff + ( (St-St2)/(St-St2+0.666667))**1.5 - Eff_aero = MAX(1.E-5, MIN(Eff, 1.0)) + Eff_aero = max(1.E-5, min(Eff, 1.0)) end function Eff_aero @@ -5181,14 +5182,14 @@ subroutine table_dropEvap real(kind_dbl_prec) :: summ, summ2, lamc, N0_c integer:: nu_c ! real(kind_dbl_prec) :: Nt_r, N0, lam_exp, lam -! REAL:: xlimit_intg +! real(kind_phys) :: xlimit_intg do n = 1, nbc massc(n) = am_r*Dc(n)**bm_r enddo do k = 1, nbc - nu_c = MIN(15, NINT(1000.E6/t_Nc(k)) + 2) + nu_c = min(15, nint(1000.E6/t_Nc(k)) + 2) do j = 1, ntb_c lamc = (t_Nc(k)*am_r* ccg(2,nu_c)*ocg1(nu_c) / r_c(j))**obmr N0_c = t_Nc(k)*ocg1(nu_c) * lamc**cce(1,nu_c) @@ -5227,36 +5228,36 @@ subroutine table_dropEvap ! TO APPLY TABLE ABOVE !..Rain lookup table indexes. -! Dr_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) & +! Dr_star = sqrt(-2.0_dp*DT * t1_evap/(2.*PI) & ! * 0.78*4.*diffu(k)*xsat*rvs/rho_w) -! idx_d = NINT(1.0 + FLOAT(nbr) * DLOG(Dr_star/D0r) & -! / DLOG(Dr(nbr)/D0r)) -! idx_d = MAX(1, MIN(idx_d, nbr)) +! idx_d = nint(1.0 + real(nbr, kind=kind_phys) * log(real(Dr_star/D0r, kind=dp)) & +! / log(real(Dr(nbr)/D0r, kind=dp))) +! idx_d = max(1, min(idx_d, nbr)) ! -! nir = NINT(ALOG10(rr(k))) +! nir = nint(log10(real(rr(k), kind=wp))) ! do nn = nir-1, nir+1 ! n = nn ! if ( (rr(k)/10.**nn).ge.1.0 .and. & ! (rr(k)/10.**nn).lt.10.0) goto 154 ! enddo !154 continue -! idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) -! idx_r = MAX(1, MIN(idx_r, ntb_r)) +! idx_r = int(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2) +! idx_r = max(1, min(idx_r, ntb_r)) ! ! lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr ! lam_exp = lamr * (crg(3)*org2*org1)**bm_r ! N0_exp = org1*rr(k)/am_r * lam_exp**cre(1) -! nir = NINT(DLOG10(N0_exp)) +! nir = nint(log10(real(N0_exp, kind=dp)) ! do nn = nir-1, nir+1 ! n = nn ! if ( (N0_exp/10.**nn).ge.1.0 .and. & ! (N0_exp/10.**nn).lt.10.0) goto 155 ! enddo !155 continue -! idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) -! idx_r1 = MAX(1, MIN(idx_r1, ntb_r1)) +! idx_r1 = int(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3) +! idx_r1 = max(1, min(idx_r1, ntb_r1)) ! -! pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M +! pnr_rev(k) = min(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M ! * odts)) end subroutine table_dropEvap @@ -5370,7 +5371,7 @@ real function activ_ncloud(Tt, Ww, NCCN, lsm_in) y1 = LOG(ta_Ww(j-1)) y2 = LOG(ta_Ww(j)) - k = MAX(1, MIN( NINT( (Tt - ta_Tk(1))*0.1) + 1, ntb_art)) + k = max(1, min( nint( (Tt - ta_Tk(1))*0.1) + 1, ntb_art)) !..The next two values are indexes of mean aerosol radius and !.. hygroscopicity. Currently these are constant but a future version @@ -5402,7 +5403,7 @@ real function activ_ncloud(Tt, Ww, NCCN, lsm_in) ! u = (w_local-ta_Ww(j-1))/(ta_Ww(j)-ta_Ww(j-1)) fraction = (1.0-t)*(1.0-u)*A + t*(1.0-u)*B + t*u*C + (1.0-t)*u*D - fraction = MAX(fraction, lower_lim_nuc_frac) + fraction = max(fraction, lower_lim_nuc_frac) ! if (NCCN*fraction .gt. 0.75*Nt_c_max) then ! write(*,*) ' DEBUG-GT ', n_local, w_local, Tt, i, j, k @@ -5508,7 +5509,7 @@ REAL FUNCTION GAMMLN(XX) TMP=(X+0.5D0)*LOG(TMP)-TMP SER=1.000000000190015D0 DO 11 J=1,6 - Y=Y+1.D0 + Y=Y+1.0_dp SER=SER+COF(J)/Y 11 CONTINUE GAMMLN=TMP+LOG(STP*SER/X) @@ -5565,12 +5566,12 @@ REAL FUNCTION RSLF(P,T) real(kind_phys), parameter:: C7= .379534310E-11 real(kind_phys), parameter:: C8=-.321582393E-13 - X=MAX(-80.,T-273.16) + X=max(-80.,T-273.16) ! ESL=612.2*EXP(17.67*X/(T-29.65)) ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - ESL=MIN(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. - RSLF=.622*ESL/max(1.e-4,(P-ESL)) + ESL=min(ESL, P*0.15) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres. + RSLF=RoverRv*ESL / max(1.e-4,(P-ESL)) ! ALTERNATIVE ! ; Source: Murphy and Koop, Review of the vapour pressure of ice and @@ -5600,10 +5601,10 @@ REAL FUNCTION RSIF(P,T) real(kind_phys), parameter:: C7= .105785160E-9 real(kind_phys), parameter:: C8= .161444444E-12 - X=MAX(-80.,T-273.16) + X=max(-80.,T-273.16) ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) - ESI=MIN(ESI, P*0.15) - RSIF=.622*ESI/max(1.e-4,(P-ESI)) + ESI=min(ESI, P*0.15) + RSIF=RoverRv*ESI / max(1.e-4,(P-ESI)) ! ALTERNATIVE ! ; Source: Murphy and Koop, Review of the vapour pressure of ice and @@ -5665,22 +5666,22 @@ real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) ! else ! nmax = p_psi*p_c1*exp(12.96*(siw-1.)-0.639) ! endif -! ntilde = MIN(ntilde, nmax) -! nhat = MIN(p_psi*p_c1*exp(12.96*(sati-1.)-0.639), nmax) +! ntilde = min(ntilde, nmax) +! nhat = min(p_psi*p_c1*exp(12.96*(sati-1.)-0.639), nmax) ! dab = delta_p (tempc, y1p, y2p, aap, bbp) -! n_in = MIN(nhat*(ntilde/nhat)**dab, nmax) +! n_in = min(nhat*(ntilde/nhat)**dab, nmax) ! endif ! mux = hx*p_alpha*n_in*rho ! xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.) ! elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then - nifa_cc = MAX(0.5, nifa*RHO_NOT0*1.E-6/rho) + nifa_cc = max(0.5, nifa*RHO_NOT0*1.E-6/rho) ! xni = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6) ! [DeMott, 2015] xni = (5.94e-5*(-tempc)**3.33) & ! [DeMott, 2010] * (nifa_cc**((-0.0264*(tempc))+0.0033)) xni = xni*rho/RHO_NOT0 * 1000. ! endif - iceDeMott = MAX(0., xni) + iceDeMott = max(0., xni) end FUNCTION iceDeMott @@ -5705,14 +5706,14 @@ real function iceKoop(temp, qv, qvs, naero, dt) log_J_rate = -906.7 + (8502.0*delta_aw) & & - (26924.0*delta_aw*delta_aw) & & + (29180.0*delta_aw*delta_aw*delta_aw) - log_J_rate = MIN(20.0, log_J_rate) + log_J_rate = min(20.0, log_J_rate) J_rate = 10.**log_J_rate ! cm-3 s-1 - prob_h = MIN(1.-exp(-J_rate*ar_volume*DT), 1.) + prob_h = min(1.-exp(-J_rate*ar_volume*DT), 1.) if (prob_h .gt. 0.) then - xni = MIN(prob_h*naero, 1000.E3) + xni = min(prob_h*naero, 1000.E3) endif - iceKoop = MAX(0.0, xni) + iceKoop = max(0.0, xni) end FUNCTION iceKoop @@ -5788,14 +5789,14 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & has_qi = .false. has_qs = .false. - re_qc1d(:) = 0.0D0 - re_qi1d(:) = 0.0D0 - re_qs1d(:) = 0.0D0 + re_qc1d(:) = 0.0_dp + re_qi1d(:) = 0.0_dp + re_qs1d(:) = 0.0_dp do k = kts, kte - rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) - rc(k) = MAX(R1, qc1d(k)*rho(k)) - nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) + rho(k) = RoverRv*p1d(k) / (R*t1d(k)*(qv1d(k)+RoverRv)) + rc(k) = max(R1, qc1d(k)*rho(k)) + nc(k) = max(2., min(nc1d(k)*rho(k), Nt_c_max)) if (.NOT. (is_aerosol_aware .or. merra2_aerosol_aware)) then if( lsml == 1) then nc(k) = Nt_c_l @@ -5804,10 +5805,10 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & endif endif if (rc(k).gt.R1 .and. nc(k).gt.R2) has_qc = .true. - ri(k) = MAX(R1, qi1d(k)*rho(k)) - ni(k) = MAX(R2, ni1d(k)*rho(k)) + ri(k) = max(R1, qi1d(k)*rho(k)) + ni(k) = max(R2, ni1d(k)*rho(k)) if (ri(k).gt.R1 .and. ni(k).gt.R2) has_qi = .true. - rs(k) = MAX(R1, qs1d(k)*rho(k)) + rs(k) = max(R1, qs1d(k)*rho(k)) if (rs(k).gt.R1) has_qs = .true. enddo @@ -5819,10 +5820,10 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & elseif (nc(k).gt.1.E10) then inu_c = 2 else - inu_c = MIN(15, NINT(1000.E6/nc(k)) + 2) + inu_c = min(15, nint(1000.E6/nc(k)) + 2) endif lamc = (nc(k)*am_r*g_ratio(inu_c)/rc(k))**obmr - re_qc1d(k) = SNGL(0.5D0 * DBLE(3.+inu_c)/lamc) + re_qc1d(k) = SNGL(0.5D0 * real(3.+inu_c, kind=dp)/lamc) enddo endif @@ -5830,14 +5831,14 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & do k = kts, kte if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - re_qi1d(k) = SNGL(0.5D0 * DBLE(3.+mu_i)/lami) + re_qi1d(k) = SNGL(0.5D0 * real(3.+mu_i, kind=dp)/lami) enddo endif if (has_qs) then do k = kts, kte if (rs(k).le.R1) CYCLE - tc0 = MIN(-0.1, t1d(k)-273.15) + tc0 = min(-0.1, t1d(k)-273.15) smob = rs(k)*oams !..All other moments based on reference, 2nd moment. If bm_s.ne.2, @@ -5952,14 +5953,14 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !+---+-----------------------------------------------------------------+ do k = kts, kte temp(k) = t1d(k) - qv(k) = MAX(1.E-10, qv1d(k)) + qv(k) = max(1.E-10, qv1d(k)) pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + rho(k) = RoverRv*pres(k) / (R*temp(k)*(qv(k)+RoverRv)) rhof(k) = SQRT(RHO_NOT/rho(k)) - rc(k) = MAX(R1, qc1d(k)*rho(k)) + rc(k) = max(R1, qc1d(k)*rho(k)) if (qr1d(k) .gt. R1) then rr(k) = qr1d(k)*rho(k) - nr(k) = MAX(R2, nr1d(k)*rho(k)) + nr(k) = max(R2, nr1d(k)*rho(k)) lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr ilamr(k) = 1./lamr N0_r(k) = nr(k)*org2*lamr**cre(2) @@ -5999,7 +6000,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & if (ANY(L_qs .eqv. .true.)) then do k = kts, kte if (.not. L_qs(k)) CYCLE - tc0 = MIN(-0.1, temp(k)-273.15) + tc0 = min(-0.1, temp(k)-273.15) smob(k) = rs(k)*oams !..All other moments based on reference, 2nd moment. If bm_s.ne.2, @@ -6065,7 +6066,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & K_LOOP:do k = kte-1, kts, -1 if ((temp(k).gt.273.15) .and. L_qr(k) & & .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) + k_0 = max(k+1, k_0) EXIT K_LOOP endif enddo K_LOOP @@ -6101,9 +6102,9 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !..Reflectivity contributed by melting snow if (allow_wet_snow .and. L_qs(k) .and. L_qs(k_0) ) then - SR = MAX(0.01, MIN(1.0 - rs(k)/(rs(k) + rr(k)), 0.99)) - fmelt_s = DBLE(SR*SR) - eta = 0.d0 + SR = max(0.01, min(1.0 - rs(k)/(rs(k) + rr(k)), 0.99)) + fmelt_s = real(SR*SR, kind=dp) + eta = 0.0_dp oM3 = 1./smoc(k) M0 = (smob(k)*oM3) Mrat = smob(k)*M0*M0*M0 @@ -6111,13 +6112,13 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & slam2 = M0 * Lam1 do n = 1, nrbins x = am_s * xxDs(n)**bm_s - call rayleigh_soak_wetgraupel (x, DBLE(ocms), DBLE(obms), & + call rayleigh_soak_wetgraupel (x, real(ocms, kind=dp), real(obms, kind=dp), & & fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & & CBACK, mixingrulestring_s, matrixstring_s, & & inclusionstring_s, hoststring_s, & & hostmatrixstring_s, hostinclusionstring_s) - f_d = Mrat*(Kap0*DEXP(-slam1*xxDs(n)) & - & + Kap1*(M0*xxDs(n))**mu_s * DEXP(-slam2*xxDs(n))) + f_d = Mrat*(Kap0*exp(real(-slam1*xxDs(n), kind=dp)) & + & + Kap1*(M0*xxDs(n))**mu_s * exp(real(-slam2*xxDs(n), kind=dp))) eta = eta + f_d * CBACK * simpson(n) * xdts(n) enddo ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) @@ -6125,18 +6126,18 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !..Reflectivity contributed by melting graupel if (allow_wet_graupel .and. L_qg(k) .and. L_qg(k_0) ) then - SR = MAX(0.01, MIN(1.0 - rg(k)/(rg(k) + rr(k)), 0.99)) - fmelt_g = DBLE(SR*SR) - eta = 0.d0 + SR = max(0.01, min(1.0 - rg(k)/(rg(k) + rr(k)), 0.99)) + fmelt_g = real(SR*SR, kind=dp) + eta = 0.0_dp lamg = 1./ilamg(k) do n = 1, nrbins x = am_g * xxDg(n)**bm_g - call rayleigh_soak_wetgraupel (x, DBLE(ocmg), DBLE(obmg), & + call rayleigh_soak_wetgraupel (x, real(ocmg, kind=dp), real(obmg, kind=dp), & & fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & & CBACK, mixingrulestring_g, matrixstring_g, & & inclusionstring_g, hoststring_g, & & hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**mu_g * DEXP(-lamg*xxDg(n)) + f_d = N0_g(k)*xxDg(n)**mu_g * exp(real(-lamg*xxDg(n), kind=dp)) eta = eta + f_d * CBACK * simpson(n) * xdtg(n) enddo ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) @@ -6146,7 +6147,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & endif do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) + dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.e18_dp) enddo !..Reflectivity-weighted terminal velocity (snow, rain, graupel, mix). @@ -6460,7 +6461,7 @@ subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) ygra1 = alog10(max(1.e-9, rg(k))) zans1 = 3.4 + 2./7.*(ygra1+8.) + rand1 N0_exp = 10.**(zans1) - N0_exp = max(dble(gonv_min), min(N0_exp, dble(gonv_max))) + N0_exp = max(real(gonv_min, kind=dp), min(N0_exp, real(gonv_max, kind=dp))) lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -6498,7 +6499,7 @@ function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) resu max_hail_column = 0. rg = 0. do k = kts, kte - rho(k) = 0.622*pressure(k)/(R*temperature(k)*(max(1.e-10, qv(k))+0.622)) + rho(k) = RoverRv*pressure(k) / (R*temperature(k)*(max(1.e-10, qv(k))+RoverRv)) if (qg(k) .gt. R1) then rg(k) = qg(k)*rho(k) else From dd3040fa5ce72c34affd1fd18e1b6a7ae6236346 Mon Sep 17 00:00:00 2001 From: Anders Jensen Date: Thu, 21 Dec 2023 13:39:04 -0700 Subject: [PATCH 005/154] Shorten kind type notation --- physics/module_mp_thompson.F90 | 722 ++++++++++++++++----------------- 1 file changed, 361 insertions(+), 361 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index f0530e412..63e7380d4 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -75,14 +75,14 @@ module module_mp_thompson logical, parameter, private :: homogIce = .true. integer, parameter, private :: IFDRY = 0 - real(kind_phys), parameter, private :: T_0 = 273.15 - real(kind_phys), parameter, private :: PI = 3.1415926536 + real(wp), parameter, private :: T_0 = 273.15 + real(wp), parameter, private :: PI = 3.1415926536 !..Densities of rain, snow, graupel, and cloud ice. - real(kind_phys), parameter, private :: rho_w = 1000.0 - real(kind_phys), parameter, private :: rho_s = 100.0 - real(kind_phys), parameter, private :: rho_g = 500.0 - real(kind_phys), parameter, private :: rho_i = 890.0 + real(wp), parameter, private :: rho_w = 1000.0 + real(wp), parameter, private :: rho_s = 100.0 + real(wp), parameter, private :: rho_g = 500.0 + real(wp), parameter, private :: rho_i = 890.0 !..Prescribed number of cloud droplets. Set according to known data or !.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and @@ -91,143 +91,143 @@ module module_mp_thompson !.. scheme. In 2-moment cloud water, Nt_c represents a maximum of !.. droplet concentration and nu_c is also variable depending on local !.. droplet number concentration. - !real(kind_phys), parameter :: Nt_c = 100.e6 - real(kind_phys), parameter :: Nt_c_o = 50.e6 - real(kind_phys), parameter :: Nt_c_l = 100.e6 - real(kind_phys), parameter, private :: Nt_c_max = 1999.e6 + !real(wp), parameter :: Nt_c = 100.e6 + real(wp), parameter :: Nt_c_o = 50.e6 + real(wp), parameter :: Nt_c_l = 100.e6 + real(wp), parameter, private :: Nt_c_max = 1999.e6 !..Declaration of constants for assumed CCN/IN aerosols when none in !.. the input data. Look inside the init routine for modifications !.. due to surface land-sea points or vegetation characteristics. - real(kind_phys), parameter :: naIN0 = 1.5e6 - real(kind_phys), parameter :: naIN1 = 0.5e6 - real(kind_phys), parameter :: naCCN0 = 300.0e6 - real(kind_phys), parameter :: naCCN1 = 50.0e6 + real(wp), parameter :: naIN0 = 1.5e6 + real(wp), parameter :: naIN1 = 0.5e6 + real(wp), parameter :: naCCN0 = 300.0e6 + real(wp), parameter :: naCCN1 = 50.0e6 !..Generalized gamma distributions for rain, graupel and cloud ice. !.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. - real(kind_phys), parameter, private :: mu_r = 0.0 - real(kind_phys), parameter, private :: mu_g = 0.0 - real(kind_phys), parameter, private :: mu_i = 0.0 - real(kind_phys), private :: mu_c_o, mu_c_l + real(wp), parameter, private :: mu_r = 0.0 + real(wp), parameter, private :: mu_g = 0.0 + real(wp), parameter, private :: mu_i = 0.0 + real(wp), private :: mu_c_o, mu_c_l !..Sum of two gamma distrib for snow (Field et al. 2005). !.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) !.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)] !.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively !.. calculated as function of ice water content and temperature. - real(kind_phys), parameter, private :: mu_s = 0.6357 - real(kind_phys), parameter, private :: Kap0 = 490.6 - real(kind_phys), parameter, private :: Kap1 = 17.46 - real(kind_phys), parameter, private :: Lam0 = 20.78 - real(kind_phys), parameter, private :: Lam1 = 3.29 + real(wp), parameter, private :: mu_s = 0.6357 + real(wp), parameter, private :: Kap0 = 490.6 + real(wp), parameter, private :: Kap1 = 17.46 + real(wp), parameter, private :: Lam0 = 20.78 + real(wp), parameter, private :: Lam1 = 3.29 !..Y-intercept parameter for graupel is not constant and depends on !.. mixing ratio. Also, when mu_g is non-zero, these become equiv !.. y-intercept for an exponential distrib and proper values are !.. computed based on same mixing ratio and total number concentration. - real(kind_phys), parameter, private :: gonv_min = 1.E2 - real(kind_phys), parameter, private :: gonv_max = 1.E6 + real(wp), parameter, private :: gonv_min = 1.E2 + real(wp), parameter, private :: gonv_max = 1.E6 !..Mass power law relations: mass = am*D**bm !.. Snow from Field et al. (2005), others assume spherical form. - real(kind_phys), parameter, private :: am_r = PI*rho_w/6.0 - real(kind_phys), parameter, private :: bm_r = 3.0 - real(kind_phys), parameter, private :: am_s = 0.069 - real(kind_phys), parameter, private :: bm_s = 2.0 - real(kind_phys), parameter, private :: am_g = PI*rho_g/6.0 - real(kind_phys), parameter, private :: bm_g = 3.0 - real(kind_phys), parameter, private :: am_i = PI*rho_i/6.0 - real(kind_phys), parameter, private :: bm_i = 3.0 + real(wp), parameter, private :: am_r = PI*rho_w/6.0 + real(wp), parameter, private :: bm_r = 3.0 + real(wp), parameter, private :: am_s = 0.069 + real(wp), parameter, private :: bm_s = 2.0 + real(wp), parameter, private :: am_g = PI*rho_g/6.0 + real(wp), parameter, private :: bm_g = 3.0 + real(wp), parameter, private :: am_i = PI*rho_i/6.0 + real(wp), parameter, private :: bm_i = 3.0 !..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) !.. Rain from Ferrier (1994), ice, snow, and graupel from !.. Thompson et al (2008). Coefficient fv is zero for graupel/ice. - real(kind_phys), parameter, private :: av_r = 4854.0 - real(kind_phys), parameter, private :: bv_r = 1.0 - real(kind_phys), parameter, private :: fv_r = 195.0 - real(kind_phys), parameter, private :: av_s = 40.0 - real(kind_phys), parameter, private :: bv_s = 0.55 - real(kind_phys), parameter, private :: fv_s = 100.0 - real(kind_phys), parameter, private :: av_g = 442.0 - real(kind_phys), parameter, private :: bv_g = 0.89 - real(kind_phys), parameter, private :: bv_i = 1.0 - real(kind_phys), parameter, private :: av_c = 0.316946E8 - real(kind_phys), parameter, private :: bv_c = 2.0 + real(wp), parameter, private :: av_r = 4854.0 + real(wp), parameter, private :: bv_r = 1.0 + real(wp), parameter, private :: fv_r = 195.0 + real(wp), parameter, private :: av_s = 40.0 + real(wp), parameter, private :: bv_s = 0.55 + real(wp), parameter, private :: fv_s = 100.0 + real(wp), parameter, private :: av_g = 442.0 + real(wp), parameter, private :: bv_g = 0.89 + real(wp), parameter, private :: bv_i = 1.0 + real(wp), parameter, private :: av_c = 0.316946E8 + real(wp), parameter, private :: bv_c = 2.0 !..Capacitance of sphere and plates/aggregates: D**3, D**2 - real(kind_phys), parameter, private :: C_cube = 0.5 - real(kind_phys), parameter, private :: C_sqrd = 0.15 + real(wp), parameter, private :: C_cube = 0.5 + real(wp), parameter, private :: C_sqrd = 0.15 !..Collection efficiencies. Rain/snow/graupel collection of cloud !.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and !.. get computed elsewhere because they are dependent on stokes !.. number. - real(kind_phys), parameter, private :: Ef_si = 0.05 - real(kind_phys), parameter, private :: Ef_rs = 0.95 - real(kind_phys), parameter, private :: Ef_rg = 0.75 - real(kind_phys), parameter, private :: Ef_ri = 0.95 + real(wp), parameter, private :: Ef_si = 0.05 + real(wp), parameter, private :: Ef_rs = 0.95 + real(wp), parameter, private :: Ef_rg = 0.75 + real(wp), parameter, private :: Ef_ri = 0.95 !..Minimum microphys values !.. R1 value, 1.E-12, cannot be set lower because of numerical !.. problems with Paul Field's moments and should not be set larger !.. because of truncation problems in snow/ice growth. - real(kind_phys), parameter, private :: R1 = 1.e-12 - real(kind_phys), parameter, private :: R2 = 1.e-6 - real(kind_phys), parameter :: eps = 1.E-15 + real(wp), parameter, private :: R1 = 1.e-12 + real(wp), parameter, private :: R2 = 1.e-6 + real(wp), parameter :: eps = 1.E-15 !..Constants in Cooper curve relation for cloud ice number. - real(kind_phys), parameter, private :: TNO = 5.0 - real(kind_phys), parameter, private :: ATO = 0.304 + real(wp), parameter, private :: TNO = 5.0 + real(wp), parameter, private :: ATO = 0.304 !..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. - real(kind_phys), parameter, private :: rho_not = 101325.0 / (287.05*298.0) + real(wp), parameter, private :: rho_not = 101325.0 / (287.05*298.0) !..Schmidt number - real(kind_phys), parameter, private :: Sc = 0.632 - real(kind_phys), private :: Sc3 + real(wp), parameter, private :: Sc = 0.632 + real(wp), private :: Sc3 !..Homogeneous freezing temperature - real(kind_phys), parameter, private:: HGFR = 235.16 + real(wp), parameter, private:: HGFR = 235.16 !..Water vapor and air gas constants at constant pressure - real(kind_phys), parameter, private :: Rv = 461.5 - real(kind_phys), parameter, private :: oRv = 1./Rv - real(kind_phys), parameter, private :: R = 287.04 - real(kind_phys), parameter, private :: RoverRv = R*oRv - real(kind_phys), parameter, private :: Cp = 1004.0 - real(kind_phys), parameter, private :: R_uni = 8.314 !< J (mol K)-1 - - real(kind_dbl_prec), parameter, private :: k_b = 1.38065e-23 !< Boltzmann constant [J/K] - real(kind_dbl_prec), parameter, private :: M_w = 18.01528e-3 !< molecular mass of water [kg/mol] - real(kind_dbl_prec), parameter, private :: M_a = 28.96e-3 !< molecular mass of air [kg/mol] - real(kind_dbl_prec), parameter, private :: N_avo = 6.022e23 !< Avogadro number [1/mol] - real(kind_dbl_prec), parameter, private :: ma_w = M_w / N_avo !< mass of water molecule [kg] - real(kind_phys), parameter, private :: ar_volume = 4./3.*PI*(2.5e-6)**3 !< assume radius of 0.025 micrometer, 2.5e-6 cm + real(wp), parameter, private :: Rv = 461.5 + real(wp), parameter, private :: oRv = 1./Rv + real(wp), parameter, private :: R = 287.04 + real(wp), parameter, private :: RoverRv = R*oRv + real(wp), parameter, private :: Cp = 1004.0 + real(wp), parameter, private :: R_uni = 8.314 !< J (mol K)-1 + + real(dp), parameter, private :: k_b = 1.38065e-23 !< Boltzmann constant [J/K] + real(dp), parameter, private :: M_w = 18.01528e-3 !< molecular mass of water [kg/mol] + real(dp), parameter, private :: M_a = 28.96e-3 !< molecular mass of air [kg/mol] + real(dp), parameter, private :: N_avo = 6.022e23 !< Avogadro number [1/mol] + real(dp), parameter, private :: ma_w = M_w / N_avo !< mass of water molecule [kg] + real(wp), parameter, private :: ar_volume = 4./3.*PI*(2.5e-6)**3 !< assume radius of 0.025 micrometer, 2.5e-6 cm !..Enthalpy of sublimation, vaporization, and fusion at 0C. - real(kind_phys), parameter, private :: lsub = 2.834e6 - real(kind_phys), parameter, private :: lvap0 = 2.5e6 - real(kind_phys), parameter, private :: lfus = lsub - lvap0 - real(kind_phys), parameter, private :: olfus = 1./lfus + real(wp), parameter, private :: lsub = 2.834e6 + real(wp), parameter, private :: lvap0 = 2.5e6 + real(wp), parameter, private :: lfus = lsub - lvap0 + real(wp), parameter, private :: olfus = 1./lfus !..Ice initiates with this mass (kg), corresponding diameter calc. !..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). - real(kind_phys), parameter, private :: xm0i = R1 - real(kind_phys), parameter, private :: D0c = 1.e-6 - real(kind_phys), parameter, private :: D0r = 50.e-6 - real(kind_phys), parameter, private :: D0s = 300.e-6 - real(kind_phys), parameter, private :: D0g = 350.e-6 - real(kind_phys), private :: D0i, xm0s, xm0g + real(wp), parameter, private :: xm0i = R1 + real(wp), parameter, private :: D0c = 1.e-6 + real(wp), parameter, private :: D0r = 50.e-6 + real(wp), parameter, private :: D0s = 300.e-6 + real(wp), parameter, private :: D0g = 350.e-6 + real(wp), private :: D0i, xm0s, xm0g !..Min and max radiative effective radius of cloud water, cloud ice, and snow; !.. performed by subroutine calc_effectRad. On purpose, these should stay PUBLIC. - real(kind_phys), parameter :: re_qc_min = 2.50e-6 ! 2.5 microns - real(kind_phys), parameter :: re_qc_max = 50.0e-6 ! 50 microns - real(kind_phys), parameter :: re_qi_min = 2.50e-6 ! 2.5 microns - real(kind_phys), parameter :: re_qi_max = 125.0e-6 ! 125 microns - real(kind_phys), parameter :: re_qs_min = 5.00e-6 ! 5 microns - real(kind_phys), parameter :: re_qs_max = 999.0e-6 ! 999 microns (1 mm) + real(wp), parameter :: re_qc_min = 2.50e-6 ! 2.5 microns + real(wp), parameter :: re_qc_max = 50.0e-6 ! 50 microns + real(wp), parameter :: re_qi_min = 2.50e-6 ! 2.5 microns + real(wp), parameter :: re_qi_max = 125.0e-6 ! 125 microns + real(wp), parameter :: re_qs_min = 5.00e-6 ! 5 microns + real(wp), parameter :: re_qs_max = 999.0e-6 ! 999 microns (1 mm) !..Lookup table dimensions integer, parameter, private :: nbins = 100 @@ -254,16 +254,16 @@ module module_mp_thompson integer, parameter, private :: ntb_IN = 55 integer, private:: niIN2 - real(kind_dbl_prec), dimension(nbins+1) :: xDx - real(kind_dbl_prec), dimension(nbc) :: Dc, dtc - real(kind_dbl_prec), dimension(nbi) :: Di, dti - real(kind_dbl_prec), dimension(nbr) :: Dr, dtr - real(kind_dbl_prec), dimension(nbs) :: Ds, dts - real(kind_dbl_prec), dimension(nbg) :: Dg, dtg - real(kind_dbl_prec), dimension(nbc) :: t_Nc + real(dp), dimension(nbins+1) :: xDx + real(dp), dimension(nbc) :: Dc, dtc + real(dp), dimension(nbi) :: Di, dti + real(dp), dimension(nbr) :: Dr, dtr + real(dp), dimension(nbs) :: Ds, dts + real(dp), dimension(nbg) :: Dg, dtg + real(dp), dimension(nbc) :: t_Nc !> Lookup tables for cloud water content (kg/m**3). - real(kind_phys), dimension(ntb_c), parameter, private :: & + real(wp), dimension(ntb_c), parameter, private :: & r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & @@ -271,7 +271,7 @@ module module_mp_thompson 1.e-2/) !> Lookup tables for cloud ice content (kg/m**3). - real(kind_phys), dimension(ntb_i), parameter, private :: & + real(wp), dimension(ntb_i), parameter, private :: & r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, & 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, & 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, & @@ -283,7 +283,7 @@ module module_mp_thompson 1.e-3/) !> Lookup tables for rain content (kg/m**3). - real(kind_phys), dimension(ntb_r), parameter, private :: & + real(wp), dimension(ntb_r), parameter, private :: & r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, & 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & @@ -291,21 +291,21 @@ module module_mp_thompson 1.e-2/) !> Lookup tables for graupel content (kg/m**3). - real(kind_phys), dimension(ntb_g), parameter, private :: & + real(wp), dimension(ntb_g), parameter, private :: & r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & 1.e-2/) !> Lookup tables for snow content (kg/m**3). - real(kind_phys), dimension(ntb_s), parameter, private :: & + real(wp), dimension(ntb_s), parameter, private :: & r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, & 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, & 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, & 1.e-2/) !> Lookup tables for rain y-intercept parameter (/m**4). - real(kind_phys), dimension(ntb_r1), parameter, private :: & + real(wp), dimension(ntb_r1), parameter, private :: & N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, & 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, & @@ -313,7 +313,7 @@ module module_mp_thompson 1.e10/) !> Lookup tables for graupel y-intercept parameter (/m**4). - real(kind_phys), dimension(ntb_g1), parameter, private :: & + real(wp), dimension(ntb_g1), parameter, private :: & N0g_exp = (/1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, & 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & @@ -321,7 +321,7 @@ module module_mp_thompson 1.e6/) !> Lookup tables for ice number concentration (/m**3). - real(kind_phys), dimension(ntb_i1), parameter, private :: & + real(wp), dimension(ntb_i1), parameter, private :: & Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & @@ -332,19 +332,19 @@ module module_mp_thompson !..Aerosol table parameter: Number of available aerosols, vertical !.. velocity, temperature, aerosol mean radius, and hygroscopicity. - real(kind_phys), dimension(ntb_arc), parameter, private :: & + real(wp), dimension(ntb_arc), parameter, private :: & ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) - real(kind_phys), dimension(ntb_arw), parameter, private :: & + real(wp), dimension(ntb_arw), parameter, private :: & ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) - real(kind_phys), dimension(ntb_art), parameter, private :: & + real(wp), dimension(ntb_art), parameter, private :: & ta_Tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/) - real(kind_phys), dimension(ntb_arr), parameter, private :: & + real(wp), dimension(ntb_arr), parameter, private :: & ta_Ra = (/0.01, 0.02, 0.04, 0.08, 0.16/) - real(kind_phys), dimension(ntb_ark), parameter, private :: & + real(wp), dimension(ntb_ark), parameter, private :: & ta_Ka = (/0.2, 0.4, 0.6, 0.8/) !> Lookup tables for IN concentration (/m**3) from 0.001 to 1000/Liter. - real(kind_phys), dimension(ntb_IN), parameter, private :: & + real(wp), dimension(ntb_IN), parameter, private :: & Nt_IN = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, & 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, & @@ -354,15 +354,15 @@ module module_mp_thompson 1.e6/) !> For snow moments conversions (from Field et al. 2005) - real(kind_phys), dimension(10), parameter, private :: & + real(wp), dimension(10), parameter, private :: & sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, & 0.31255, 0.000204, 0.003199, 0.0, -0.015952/) - real(kind_phys), dimension(10), parameter, private :: & + real(wp), dimension(10), parameter, private :: & sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, & 0.060366, 0.000079, 0.000594, 0.0, -0.003577/) !> Temperatures (5 C interval 0 to -40) used in lookup tables. - real(kind_phys), dimension(ntb_t), parameter, private :: & + real(wp), dimension(ntb_t), parameter, private :: & Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./) !..Lookup tables for various accretion/collection terms. @@ -379,44 +379,44 @@ module module_mp_thompson character(len=*), parameter :: qr_acr_qs_file = 'qr_acr_qsV2.dat' character(len=*), parameter :: freeze_h2o_file = 'freezeH2O.dat' - real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + real (dp), allocatable, dimension(:,:,:,:) :: & tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & tnr_racg, tnr_gacr - real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + real (dp), allocatable, dimension(:,:,:,:) :: & tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 - real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + real (dp), allocatable, dimension(:,:,:,:) :: & tpi_qcfz, tni_qcfz - real (kind_dbl_prec), allocatable, dimension(:,:,:,:) :: & + real (dp), allocatable, dimension(:,:,:,:) :: & tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz - real (kind_dbl_prec), allocatable, dimension(:,:) :: & + real (dp), allocatable, dimension(:,:) :: & tps_iaus, tni_iaus, tpi_ide - real (kind_dbl_prec), allocatable, dimension(:,:) :: t_Efrw - real (kind_dbl_prec), allocatable, dimension(:,:) :: t_Efsw - real (kind_dbl_prec), allocatable, dimension(:,:,:) :: tnr_rev - real (kind_dbl_prec), allocatable, dimension(:,:,:) :: & + real (dp), allocatable, dimension(:,:) :: t_Efrw + real (dp), allocatable, dimension(:,:) :: t_Efsw + real (dp), allocatable, dimension(:,:,:) :: tnr_rev + real (dp), allocatable, dimension(:,:,:) :: & tpc_wev, tnc_wev - real (kind_sngl_prec), allocatable, dimension(:,:,:,:,:) :: tnccn_act + real (sp), allocatable, dimension(:,:,:,:,:) :: tnccn_act !..Variables holding a bunch of exponents and gamma values (cloud water, !.. cloud ice, rain, snow, then graupel). - real(kind_phys), dimension(5,15), private :: cce, ccg - real(kind_phys), dimension(15), private :: ocg1, ocg2 - real(kind_phys), dimension(7), private :: cie, cig - real(kind_phys), private :: oig1, oig2, obmi - real(kind_phys), dimension(13), private :: cre, crg - real(kind_phys), private :: ore1, org1, org2, org3, obmr - real(kind_phys), dimension(18), private :: cse, csg - real(kind_phys), private :: oams, obms, ocms - real(kind_phys), dimension(12), private :: cge, cgg - real(kind_phys), private :: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg + real(wp), dimension(5,15), private :: cce, ccg + real(wp), dimension(15), private :: ocg1, ocg2 + real(wp), dimension(7), private :: cie, cig + real(wp), private :: oig1, oig2, obmi + real(wp), dimension(13), private :: cre, crg + real(wp), private :: ore1, org1, org2, org3, obmr + real(wp), dimension(18), private :: cse, csg + real(wp), private :: oams, obms, ocms + real(wp), dimension(12), private :: cge, cgg + real(wp), private :: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg !..Declaration of precomputed constants in various rate eqns. - real(kind_phys) :: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi - real(kind_phys) :: t1_qr_ev, t2_qr_ev - real(kind_phys) :: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd - real(kind_phys) :: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me + real(wp) :: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi + real(wp) :: t1_qr_ev, t2_qr_ev + real(wp) :: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd + real(wp) :: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me !..MPI communicator integer :: mpi_communicator @@ -453,7 +453,7 @@ subroutine thompson_init(is_aerosol_aware_in, & integer:: i, j, k, l, m, n logical:: micro_init - real(kind_phys) :: stime, etime + real(wp) :: stime, etime logical, parameter :: precomputed_tables = .FALSE. ! Set module variable is_aerosol_aware/merra2_aerosol_aware @@ -1029,44 +1029,44 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & integer, intent(in):: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & qv, qc, qr, qi, qs, qg, ni, nr - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & tt, th - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(in):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(in):: & pii - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & nc, nwfa, nifa - real(kind_phys), dimension(ims:ime, jms:jme), optional, intent(in):: nwfa2d, nifa2d + real(wp), dimension(ims:ime, jms:jme), optional, intent(in):: nwfa2d, nifa2d integer, dimension(ims:ime, jms:jme), intent(in):: lsm - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & re_cloud, re_ice, re_snow - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: pfils, pflls + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: pfils, pflls integer, intent(in) :: rand_perturb_on, kme_stoch, n_var_spp - real(kind_phys), dimension(:,:), intent(in) :: rand_pert - real(kind_phys), dimension(:), intent(in) :: spp_prt_list, spp_stddev_cutoff + real(wp), dimension(:,:), intent(in) :: rand_pert + real(wp), dimension(:), intent(in) :: spp_prt_list, spp_stddev_cutoff character(len=10), dimension(:), intent(in) :: spp_var_list integer, intent(in):: has_reqc, has_reqi, has_reqs #if ( WRF_CHEM == 1 ) - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & rainprod, evapprod #endif - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(in):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(in):: & p, w, dz - real(kind_phys), dimension(ims:ime, jms:jme), intent(inout):: & + real(wp), dimension(ims:ime, jms:jme), intent(inout):: & RAINNC, RAINNCV, SR - real(kind_phys), dimension(ims:ime, jms:jme), optional, intent(inout):: & + real(wp), dimension(ims:ime, jms:jme), optional, intent(inout):: & SNOWNC, SNOWNCV, & ICENC, ICENCV, & GRAUPELNC, GRAUPELNCV - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & refl_10cm - real(kind_phys), dimension(ims:ime, jms:jme), intent(inout):: & + real(wp), dimension(ims:ime, jms:jme), intent(inout):: & max_hail_diam_sfc - real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & vt_dbz_wt logical, intent(in) :: first_time_step - real(kind_phys), intent(in):: dt_in, dt_inner + real(wp), intent(in):: dt_in, dt_inner logical, intent(in) :: sedi_semi integer, intent(in) :: decfl ! To support subcycling: current step and maximum number of steps @@ -1075,7 +1075,7 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. logical, intent (in) :: ext_diag logical, optional, intent(in):: aero_ind_fdb - real(kind_phys), dimension(:,:,:), intent(inout):: & + real(wp), dimension(:,:,:), intent(inout):: & !vts1, txri, txrc, & prw_vcdc, & prw_vcde, tpri_inu, tpri_ide_d, & @@ -1092,12 +1092,12 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nrten3, ncten3, qcten3 !..Local variables - real(kind_phys), dimension(kts:kte):: & + real(wp), dimension(kts:kte):: & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ, pfil1, pfll1 !..Extended diagnostics, single column arrays - real(kind_phys), dimension(:), allocatable:: & + real(wp), dimension(:), allocatable:: & !vtsk1, txri1, txrc1, & prw_vcdc1, & prw_vcde1, tpri_inu1, tpri_ide1_d, & @@ -1113,16 +1113,16 @@ subroutine mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qrten1, qsten1, qgten1, qiten1, niten1, & nrten1, ncten1, qcten1 - real(kind_phys), dimension(kts:kte):: re_qc1d, re_qi1d, re_qs1d + real(wp), dimension(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) - real(kind_phys), dimension(kts:kte):: & + real(wp), dimension(kts:kte):: & rainprod1d, evapprod1d #endif - real(kind_phys), dimension(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic - real(kind_phys) :: dt, pptrain, pptsnow, pptgraul, pptice - real(kind_phys) :: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max + real(wp), dimension(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic + real(wp) :: dt, pptrain, pptsnow, pptgraul, pptice + real(wp) :: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max integer:: lsml - real(kind_phys) :: rand1, rand2, rand3, rand_pert_max + real(wp) :: rand1, rand2, rand3, rand_pert_max integer:: i, j, k, m integer:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr integer:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr @@ -1889,20 +1889,20 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Sub arguments integer, intent(in):: kts, kte, ii, jj - real(kind_phys), dimension(kts:kte), intent(inout) :: & + real(wp), dimension(kts:kte), intent(inout) :: & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d - real(kind_phys), dimension(kts:kte), intent(out) :: pfil1, pfll1 - real(kind_phys), dimension(kts:kte), intent(in) :: p1d, w1d, dzq - real(kind_phys), intent(inout) :: pptrain, pptsnow, pptgraul, pptice - real(kind_phys), intent(in) :: dt + real(wp), dimension(kts:kte), intent(out) :: pfil1, pfll1 + real(wp), dimension(kts:kte), intent(in) :: p1d, w1d, dzq + real(wp), intent(inout) :: pptrain, pptsnow, pptgraul, pptice + real(wp), intent(in) :: dt integer, intent(in) :: lsml - real(kind_phys), intent(in) :: rand1, rand2, rand3 + real(wp), intent(in) :: rand1, rand2, rand3 ! Extended diagnostics, most arrays only allocated if ext_diag is true logical, intent(in) :: ext_diag logical, intent(in) :: sedi_semi integer, intent(in) :: decfl - real(kind_phys), dimension(:), intent(out) :: & + real(wp), dimension(:), intent(out) :: & !vtsk1, txri1, txrc1, & prw_vcdc1, & prw_vcde1, tpri_inu1, tpri_ide1_d, & @@ -1919,88 +1919,88 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nrten1, ncten1, qcten1 #if ( WRF_CHEM == 1 ) - real(kind_phys), dimension(kts:kte), intent(inout) :: & + real(wp), dimension(kts:kte), intent(inout) :: & rainprod, evapprod #endif !..Local variables - real(kind_phys), dimension(kts:kte) :: tten, qvten, qcten, qiten, & + real(wp), dimension(kts:kte) :: tten, qvten, qcten, qiten, & qrten, qsten, qgten, niten, nrten, ncten, nwfaten, nifaten - real(kind_dbl_prec), dimension(kts:kte) :: prw_vcd + real(dp), dimension(kts:kte) :: prw_vcd - real(kind_dbl_prec), dimension(kts:kte) :: pnc_wcd, pnc_wau, pnc_rcw, & + real(dp), dimension(kts:kte) :: pnc_wcd, pnc_wau, pnc_rcw, & pnc_scw, pnc_gcw - real(kind_dbl_prec), dimension(kts:kte) :: pna_rca, pna_sca, pna_gca, & + real(dp), dimension(kts:kte) :: pna_rca, pna_sca, pna_gca, & pnd_rcd, pnd_scd, pnd_gcd - real(kind_dbl_prec), dimension(kts:kte) :: prr_wau, prr_rcw, prr_rcs, & + real(dp), dimension(kts:kte) :: prr_wau, prr_rcw, prr_rcs, & prr_rcg, prr_sml, prr_gml, & prr_rci, prv_rev, & pnr_wau, pnr_rcs, pnr_rcg, & pnr_rci, pnr_sml, pnr_gml, & pnr_rev, pnr_rcr, pnr_rfz - real(kind_dbl_prec), dimension(kts:kte) :: pri_inu, pni_inu, pri_ihm, & + real(dp), dimension(kts:kte) :: pri_inu, pni_inu, pri_ihm, & pni_ihm, pri_wfz, pni_wfz, & pri_rfz, pni_rfz, pri_ide, & pni_ide, pri_rci, pni_rci, & pni_sci, pni_iau, pri_iha, pni_iha - real(kind_dbl_prec), dimension(kts:kte) :: prs_iau, prs_sci, prs_rcs, & + real(dp), dimension(kts:kte) :: prs_iau, prs_sci, prs_rcs, & prs_scw, prs_sde, prs_ihm, & prs_ide - real(kind_dbl_prec), dimension(kts:kte) :: prg_scw, prg_rfz, prg_gde, & + real(dp), dimension(kts:kte) :: prg_scw, prg_rfz, prg_gde, & prg_gcw, prg_rci, prg_rcs, & prg_rcg, prg_ihm - real(kind_dbl_prec), parameter:: zeroD0 = 0.0 - real(kind_phys) :: dtcfl, rainsfc, graulsfc + real(dp), parameter:: zeroD0 = 0.0 + real(wp) :: dtcfl, rainsfc, graulsfc integer :: niter - real(kind_phys), dimension(kts:kte) :: temp, pres, qv, pfll, pfil, pdummy - real(kind_phys), dimension(kts:kte) :: rc, ri, rr, rs, rg, ni, nr, nc, nwfa, nifa - real(kind_phys), dimension(kts:kte) :: rr_tmp, nr_tmp, rg_tmp - real(kind_phys), dimension(kts:kte) :: rho, rhof, rhof2 - real(kind_phys), dimension(kts:kte) :: qvs, qvsi, delQvs - real(kind_phys), dimension(kts:kte) :: satw, sati, ssatw, ssati - real(kind_phys), dimension(kts:kte) :: diffu, visco, vsc2, & + real(wp), dimension(kts:kte) :: temp, pres, qv, pfll, pfil, pdummy + real(wp), dimension(kts:kte) :: rc, ri, rr, rs, rg, ni, nr, nc, nwfa, nifa + real(wp), dimension(kts:kte) :: rr_tmp, nr_tmp, rg_tmp + real(wp), dimension(kts:kte) :: rho, rhof, rhof2 + real(wp), dimension(kts:kte) :: qvs, qvsi, delQvs + real(wp), dimension(kts:kte) :: satw, sati, ssatw, ssati + real(wp), dimension(kts:kte) :: diffu, visco, vsc2, & tcond, lvap, ocp, lvt2 - real(kind_dbl_prec), dimension(kts:kte) :: ilamr, ilamg, N0_r, N0_g - real(kind_phys), dimension(kts:kte) :: mvd_r, mvd_c - real(kind_phys), dimension(kts:kte) :: smob, smo2, smo1, smo0, & + real(dp), dimension(kts:kte) :: ilamr, ilamg, N0_r, N0_g + real(wp), dimension(kts:kte) :: mvd_r, mvd_c + real(wp), dimension(kts:kte) :: smob, smo2, smo1, smo0, & smoc, smod, smoe, smof - real(kind_phys), dimension(kts:kte) :: sed_r, sed_s, sed_g, sed_i, sed_n,sed_c - - real(kind_phys) :: rgvm, delta_tp, orho, lfus2, orhodt - real(kind_phys), dimension(5):: onstep - real(kind_dbl_prec) :: N0_exp, N0_min, lam_exp, lamc, lamr, lamg - real(kind_dbl_prec) :: lami, ilami, ilamc - real(kind_phys) :: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m - real(kind_dbl_prec) :: Dr_star, Dc_star - real(kind_phys) :: zeta1, zeta, taud, tau - real(kind_phys) :: stoke_r, stoke_s, stoke_g, stoke_i - real(kind_phys) :: vti, vtr, vts, vtg, vtc - real(kind_phys), dimension(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk, & + real(wp), dimension(kts:kte) :: sed_r, sed_s, sed_g, sed_i, sed_n,sed_c + + real(wp) :: rgvm, delta_tp, orho, lfus2, orhodt + real(wp), dimension(5):: onstep + real(dp) :: N0_exp, N0_min, lam_exp, lamc, lamr, lamg + real(dp) :: lami, ilami, ilamc + real(wp) :: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m + real(dp) :: Dr_star, Dc_star + real(wp) :: zeta1, zeta, taud, tau + real(wp) :: stoke_r, stoke_s, stoke_g, stoke_i + real(wp) :: vti, vtr, vts, vtg, vtc + real(wp), dimension(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk, & vtck, vtnck - real(kind_phys), dimension(kts:kte):: vts_boost - real(kind_phys) :: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow - real(kind_phys) :: a_, b_, loga_, A1, A2, tf - real(kind_phys) :: tempc, tc0, r_mvd1, r_mvd2, xkrat - real(kind_phys) :: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr - real(kind_phys) :: xsat, rate_max, sump, ratio - real(kind_phys) :: clap, fcd, dfcd - real(kind_phys) :: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl - real(kind_phys) :: r_frac, g_frac - real(kind_phys) :: Ef_rw, Ef_sw, Ef_gw, Ef_rr - real(kind_phys) :: Ef_ra, Ef_sa, Ef_ga - real(kind_phys) :: dtsave, odts, odt, odzq, hgt_agl, SR - real(kind_phys) :: xslw1, ygra1, zans1, eva_factor - real(kind_phys) av_i + real(wp), dimension(kts:kte):: vts_boost + real(wp) :: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow + real(wp) :: a_, b_, loga_, A1, A2, tf + real(wp) :: tempc, tc0, r_mvd1, r_mvd2, xkrat + real(wp) :: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr + real(wp) :: xsat, rate_max, sump, ratio + real(wp) :: clap, fcd, dfcd + real(wp) :: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl + real(wp) :: r_frac, g_frac + real(wp) :: Ef_rw, Ef_sw, Ef_gw, Ef_rr + real(wp) :: Ef_ra, Ef_sa, Ef_ga + real(wp) :: dtsave, odts, odt, odzq, hgt_agl, SR + real(wp) :: xslw1, ygra1, zans1, eva_factor + real(wp) av_i integer :: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq integer, dimension(5) :: ksed1 integer :: nir, nis, nig, nii, nic, niin @@ -4368,10 +4368,10 @@ subroutine qr_acr_qg !..Local variables integer:: i, j, k, m, n, n2 integer:: km, km_s, km_e - real(kind_dbl_prec), dimension(nbg):: vg, N_g - real(kind_dbl_prec), dimension(nbr):: vr, N_r - real(kind_dbl_prec) :: N0_r, N0_g, lam_exp, lamg, lamr - real(kind_dbl_prec) :: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2 + real(dp), dimension(nbg):: vg, N_g + real(dp), dimension(nbr):: vr, N_r + real(dp) :: N0_r, N0_g, lam_exp, lamg, lamr + real(dp) :: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2 logical force_read_thompson, write_thompson_tables logical lexist,lopen integer good,ierr @@ -4540,13 +4540,13 @@ subroutine qr_acr_qs !..Local variables integer:: i, j, k, m, n, n2 integer:: km, km_s, km_e - real(kind_dbl_prec), dimension(nbr):: vr, D1, N_r - real(kind_dbl_prec), dimension(nbs):: vs, N_s - real(kind_dbl_prec) :: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 - real(kind_dbl_prec) :: N0_r, lam_exp, lamr, slam1, slam2 - real(kind_dbl_prec) :: dvs, dvr, masss, massr - real(kind_dbl_prec) :: t1, t2, t3, t4, z1, z2, z3, z4 - real(kind_dbl_prec) :: y1, y2, y3, y4 + real(dp), dimension(nbr):: vr, D1, N_r + real(dp), dimension(nbs):: vs, N_s + real(dp) :: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 + real(dp) :: N0_r, lam_exp, lamr, slam1, slam2 + real(dp) :: dvs, dvr, masss, massr + real(dp) :: t1, t2, t3, t4, z1, z2, z3, z4 + real(dp) :: y1, y2, y3, y4 logical force_read_thompson, write_thompson_tables logical lexist,lopen integer good,ierr @@ -4801,14 +4801,14 @@ subroutine freezeH2O(threads) !..Local variables integer:: i, j, k, m, n, n2 - real(kind_dbl_prec) :: N_r, N_c - real(kind_dbl_prec), dimension(nbr):: massr - real(kind_dbl_prec), dimension(nbc):: massc - real(kind_dbl_prec) :: sum1, sum2, sumn1, sumn2, & + real(dp) :: N_r, N_c + real(dp), dimension(nbr):: massr + real(dp), dimension(nbc):: massc + real(dp) :: sum1, sum2, sumn1, sumn2, & prob, vol, Texp, orho_w, & lam_exp, lamr, N0_r, lamc, N0_c, y integer :: nu_c - real(kind_phys) :: T_adjust + real(wp) :: T_adjust logical force_read_thompson, write_thompson_tables logical lexist,lopen integer good,ierr @@ -4977,9 +4977,9 @@ subroutine qi_aut_qs !..Local variables integer:: i, j, n2 - real(kind_dbl_prec), dimension(nbi):: N_i - real(kind_dbl_prec) :: N0_i, lami, Di_mean, t1, t2 - real(kind_phys) :: xlimit_intg + real(dp), dimension(nbi):: N_i + real(dp) :: N0_i, lami, Di_mean, t1, t2 + real(wp) :: xlimit_intg !+---+ @@ -5026,8 +5026,8 @@ subroutine table_Efrw implicit none !..Local variables - real(kind_dbl_prec) :: vtr, stokes, reynolds, Ef_rw - real(kind_dbl_prec) :: p, yc0, F, G, H, z, K0, X + real(dp) :: vtr, stokes, reynolds, Ef_rw + real(dp) :: p, yc0, F, G, H, z, K0, X integer:: i, j do j = 1, nbc @@ -5089,8 +5089,8 @@ subroutine table_Efsw implicit none !..Local variables - real(kind_dbl_prec) :: Ds_m, vts, vtc, stokes, reynolds, Ef_sw - real(kind_dbl_prec) :: p, yc0, F, G, H, z, K0 + real(dp) :: Ds_m, vts, vtc, stokes, reynolds, Ef_sw + real(dp) :: p, yc0, F, G, H, z, K0 integer:: i, j do j = 1, nbc @@ -5133,8 +5133,8 @@ real function Eff_aero(D, Da, visc,rhoa,Temp,species) real:: D, Da, visc, rhoa, Temp character(LEN=1):: species real:: aval, Cc, diff, Re, Sc, St, St2, vt, Eff - real(kind_phys), parameter:: boltzman = 1.3806503E-23 - real(kind_phys), parameter:: meanPath = 0.0256E-6 + real(wp), parameter:: boltzman = 1.3806503E-23 + real(wp), parameter:: meanPath = 0.0256E-6 vt = 1. if (species .eq. 'r') then @@ -5178,11 +5178,11 @@ subroutine table_dropEvap !..Local variables integer:: i, j, k, n - real(kind_dbl_prec), dimension(nbc):: N_c, massc - real(kind_dbl_prec) :: summ, summ2, lamc, N0_c + real(dp), dimension(nbc):: N_c, massc + real(dp) :: summ, summ2, lamc, N0_c integer:: nu_c -! real(kind_dbl_prec) :: Nt_r, N0, lam_exp, lam -! real(kind_phys) :: xlimit_intg +! real(dp) :: Nt_r, N0, lam_exp, lam +! real(wp) :: xlimit_intg do n = 1, nbc massc(n) = am_r*Dc(n)**bm_r @@ -5230,7 +5230,7 @@ subroutine table_dropEvap !..Rain lookup table indexes. ! Dr_star = sqrt(-2.0_dp*DT * t1_evap/(2.*PI) & ! * 0.78*4.*diffu(k)*xsat*rvs/rho_w) -! idx_d = nint(1.0 + real(nbr, kind=kind_phys) * log(real(Dr_star/D0r, kind=dp)) & +! idx_d = nint(1.0 + real(nbr, kind=wp) * log(real(Dr_star/D0r, kind=dp)) & ! / log(real(Dr(nbr)/D0r, kind=dp))) ! idx_d = max(1, min(idx_d, nbr)) ! @@ -5329,12 +5329,12 @@ end subroutine table_ccnAct real function activ_ncloud(Tt, Ww, NCCN, lsm_in) implicit none - real(kind_phys), intent(in):: Tt, Ww, NCCN + real(wp), intent(in):: Tt, Ww, NCCN integer, intent(in):: lsm_in - real(kind_phys):: n_local, w_local + real(wp):: n_local, w_local integer:: i, j, k, l, m, n - real(kind_phys):: A, B, C, D, t, u, x1, x2, y1, y2, nx, wy, fraction - real(kind_phys):: lower_lim_nuc_frac + real(wp):: A, B, C, D, t, u, x1, x2, y1, y2, nx, wy, fraction + real(wp):: lower_lim_nuc_frac ! ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/) ntb_arc ! ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/) ntb_arw @@ -5426,12 +5426,12 @@ SUBROUTINE GCF(GAMMCF,A,X,GLN) ! --- USES GAMMLN IMPLICIT NONE integer, parameter:: ITMAX=100 - real(kind_phys), parameter:: gEPS=3.E-7 - real(kind_phys), parameter:: FPMIN=1.E-30 - real(kind_phys), intent(in):: A, X - real(kind_phys):: GAMMCF,GLN + real(wp), parameter:: gEPS=3.E-7 + real(wp), parameter:: FPMIN=1.E-30 + real(wp), intent(in):: A, X + real(wp):: GAMMCF,GLN integer:: I - real(kind_phys):: AN,B,C,D,DEL,H + real(wp):: AN,B,C,D,DEL,H GLN=GAMMLN(A) B=X+1.-A C=1./FPMIN @@ -5464,11 +5464,11 @@ SUBROUTINE GSER(GAMSER,A,X,GLN) ! --- USES GAMMLN IMPLICIT NONE integer, parameter:: ITMAX=100 - real(kind_phys), parameter:: gEPS=3.E-7 - real(kind_phys), intent(in):: A, X - real(kind_phys):: GAMSER,GLN + real(wp), parameter:: gEPS=3.E-7 + real(wp), intent(in):: A, X + real(wp):: GAMSER,GLN integer:: N - real(kind_phys):: AP,DEL,SUM + real(wp):: AP,DEL,SUM GLN=GAMMLN(A) IF(X.LE.0.)THEN IF(X.LT.0.) PRINT *, 'X < 0 IN GSER' @@ -5494,13 +5494,13 @@ END SUBROUTINE GSER REAL FUNCTION GAMMLN(XX) ! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. IMPLICIT NONE - real(kind_phys), intent(in):: XX - real(kind_dbl_prec), parameter:: STP = 2.5066282746310005D0 - real(kind_dbl_prec), dimension(6), parameter:: & + real(wp), intent(in):: XX + real(dp), parameter:: STP = 2.5066282746310005D0 + real(dp), dimension(6), parameter:: & COF = (/76.18009172947146D0, -86.50532032941677D0, & 24.01409824083091D0, -1.231739572450155D0, & .1208650973866179D-2, -.5395239384953D-5/) - real(kind_dbl_prec) :: SER,TMP,X,Y + real(dp) :: SER,TMP,X,Y integer:: J X=XX @@ -5522,8 +5522,8 @@ REAL FUNCTION GAMMP(A,X) ! --- SEE ABRAMOWITZ AND STEGUN 6.5.1 ! --- USES GCF,GSER IMPLICIT NONE - real(kind_phys), intent(in):: A,X - real(kind_phys):: GAMMCF,GAMSER,GLN + real(wp), intent(in):: A,X + real(wp):: GAMMCF,GAMSER,GLN GAMMP = 0. IF((X.LT.0.) .OR. (A.LE.0.)) THEN PRINT *, 'BAD ARGUMENTS IN GAMMP' @@ -5542,7 +5542,7 @@ END FUNCTION GAMMP REAL FUNCTION WGAMMA(y) IMPLICIT NONE - real(kind_phys), intent(in):: y + real(wp), intent(in):: y WGAMMA = EXP(GAMMLN(y)) @@ -5554,17 +5554,17 @@ END FUNCTION WGAMMA REAL FUNCTION RSLF(P,T) IMPLICIT NONE - real(kind_phys), intent(in):: P, T - real(kind_phys):: ESL,X - real(kind_phys), parameter:: C0= .611583699E03 - real(kind_phys), parameter:: C1= .444606896E02 - real(kind_phys), parameter:: C2= .143177157E01 - real(kind_phys), parameter:: C3= .264224321E-1 - real(kind_phys), parameter:: C4= .299291081E-3 - real(kind_phys), parameter:: C5= .203154182E-5 - real(kind_phys), parameter:: C6= .702620698E-8 - real(kind_phys), parameter:: C7= .379534310E-11 - real(kind_phys), parameter:: C8=-.321582393E-13 + real(wp), intent(in):: P, T + real(wp):: ESL,X + real(wp), parameter:: C0= .611583699E03 + real(wp), parameter:: C1= .444606896E02 + real(wp), parameter:: C2= .143177157E01 + real(wp), parameter:: C3= .264224321E-1 + real(wp), parameter:: C4= .299291081E-3 + real(wp), parameter:: C5= .203154182E-5 + real(wp), parameter:: C6= .702620698E-8 + real(wp), parameter:: C7= .379534310E-11 + real(wp), parameter:: C8=-.321582393E-13 X=max(-80.,T-273.16) @@ -5589,17 +5589,17 @@ END FUNCTION RSLF REAL FUNCTION RSIF(P,T) IMPLICIT NONE - real(kind_phys), intent(in):: P, T - real(kind_phys):: ESI,X - real(kind_phys), parameter:: C0= .609868993E03 - real(kind_phys), parameter:: C1= .499320233E02 - real(kind_phys), parameter:: C2= .184672631E01 - real(kind_phys), parameter:: C3= .402737184E-1 - real(kind_phys), parameter:: C4= .565392987E-3 - real(kind_phys), parameter:: C5= .521693933E-5 - real(kind_phys), parameter:: C6= .307839583E-7 - real(kind_phys), parameter:: C7= .105785160E-9 - real(kind_phys), parameter:: C8= .161444444E-12 + real(wp), intent(in):: P, T + real(wp):: ESI,X + real(wp), parameter:: C0= .609868993E03 + real(wp), parameter:: C1= .499320233E02 + real(wp), parameter:: C2= .184672631E01 + real(wp), parameter:: C3= .402737184E-1 + real(wp), parameter:: C4= .565392987E-3 + real(wp), parameter:: C5= .521693933E-5 + real(wp), parameter:: C6= .307839583E-7 + real(wp), parameter:: C7= .105785160E-9 + real(wp), parameter:: C8= .161444444E-12 X=max(-80.,T-273.16) ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) @@ -5619,26 +5619,26 @@ END FUNCTION RSIF real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) implicit none - real(kind_phys), intent(in):: tempc, qv, qvs, qvsi, rho, nifa + real(wp), intent(in):: tempc, qv, qvs, qvsi, rho, nifa !..Local vars - real(kind_phys):: satw, sati, siw, p_x, si0x, dtt, dsi, dsw, dab, fc, hx - real(kind_phys):: ntilde, n_in, nmax, nhat, mux, xni, nifa_cc - real(kind_phys), parameter:: p_c1 = 1000. - real(kind_phys), parameter:: p_rho_c = 0.76 - real(kind_phys), parameter:: p_alpha = 1.0 - real(kind_phys), parameter:: p_gam = 2. - real(kind_phys), parameter:: delT = 5. - real(kind_phys), parameter:: T0x = -40. - real(kind_phys), parameter:: Sw0x = 0.97 - real(kind_phys), parameter:: delSi = 0.1 - real(kind_phys), parameter:: hdm = 0.15 - real(kind_phys), parameter:: p_psi = 0.058707*p_gam/p_rho_c - real(kind_phys), parameter:: aap = 1. - real(kind_phys), parameter:: bbp = 0. - real(kind_phys), parameter:: y1p = -35. - real(kind_phys), parameter:: y2p = -25. - real(kind_phys), parameter:: rho_not0 = 101325./(287.05*273.15) + real(wp):: satw, sati, siw, p_x, si0x, dtt, dsi, dsw, dab, fc, hx + real(wp):: ntilde, n_in, nmax, nhat, mux, xni, nifa_cc + real(wp), parameter:: p_c1 = 1000. + real(wp), parameter:: p_rho_c = 0.76 + real(wp), parameter:: p_alpha = 1.0 + real(wp), parameter:: p_gam = 2. + real(wp), parameter:: delT = 5. + real(wp), parameter:: T0x = -40. + real(wp), parameter:: Sw0x = 0.97 + real(wp), parameter:: delSi = 0.1 + real(wp), parameter:: hdm = 0.15 + real(wp), parameter:: p_psi = 0.058707*p_gam/p_rho_c + real(wp), parameter:: aap = 1. + real(wp), parameter:: bbp = 0. + real(wp), parameter:: y1p = -35. + real(wp), parameter:: y2p = -25. + real(wp), parameter:: rho_not0 = 101325./(287.05*273.15) !+---+ @@ -5693,9 +5693,9 @@ end FUNCTION iceDeMott real function iceKoop(temp, qv, qvs, naero, dt) implicit none - real(kind_phys), intent(in):: temp, qv, qvs, naero, DT - real(kind_phys):: mu_diff, a_w_i, delta_aw, log_J_rate, J_rate, prob_h, satw - real(kind_phys):: xni + real(wp), intent(in):: temp, qv, qvs, naero, DT + real(wp):: mu_diff, a_w_i, delta_aw, log_J_rate, J_rate, prob_h, satw + real(wp):: xni xni = 0.0 satw = qv/qvs @@ -5723,8 +5723,8 @@ end FUNCTION iceKoop REAL FUNCTION delta_p (yy, y1, y2, aa, bb) IMPLICIT NONE - real(kind_phys), intent(in):: yy, y1, y2, aa, bb - real(kind_phys):: dab, A, B, a0, a1, a2, a3 + real(wp), intent(in):: yy, y1, y2, aa, bb + real(wp):: dab, A, B, a0, a1, a2, a3 A = 6.*(aa-bb)/((y2-y1)*(y2-y1)*(y2-y1)) B = aa+(A*y1*y1*y1/6.)-(A*y1*y1*y2*0.5) @@ -5770,19 +5770,19 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & !..Sub arguments integer, intent(in):: kts, kte - real(kind_phys), dimension(kts:kte), intent(in):: & + real(wp), dimension(kts:kte), intent(in):: & & t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d - real(kind_phys), dimension(kts:kte), intent(out):: re_qc1d, re_qi1d, re_qs1d + real(wp), dimension(kts:kte), intent(out):: re_qc1d, re_qi1d, re_qs1d !..Local variables integer:: k - real(kind_phys), dimension(kts:kte):: rho, rc, nc, ri, ni, rs - real(kind_phys):: smo2, smob, smoc - real(kind_phys):: tc0, loga_, a_, b_ - real(kind_dbl_prec) :: lamc, lami + real(wp), dimension(kts:kte):: rho, rc, nc, ri, ni, rs + real(wp):: smo2, smob, smoc + real(wp):: tc0, loga_, a_, b_ + real(dp) :: lamc, lami logical:: has_qc, has_qi, has_qs integer:: inu_c integer:: lsml - real(kind_phys), dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & + real(wp), dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & & 504,720,990,1320,1716,2184,2730,3360,4080,4896/) has_qc = .false. @@ -5894,39 +5894,39 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !..Sub arguments integer, intent(in):: kts, kte, ii, jj - real(kind_phys), intent(in):: rand1 - real(kind_phys), dimension(kts:kte), intent(in):: & + real(wp), intent(in):: rand1 + real(wp), dimension(kts:kte), intent(in):: & qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d - real(kind_phys), dimension(kts:kte), intent(inout):: dBZ - real(kind_phys), dimension(kts:kte), optional, intent(inout):: vt_dBZ + real(wp), dimension(kts:kte), intent(inout):: dBZ + real(wp), dimension(kts:kte), optional, intent(inout):: vt_dBZ logical, optional, intent(in) :: first_time_step !..Local variables logical :: do_vt_dBZ logical :: allow_wet_graupel logical :: allow_wet_snow - real(kind_phys), dimension(kts:kte):: temp, pres, qv, rho, rhof - real(kind_phys), dimension(kts:kte):: rc, rr, nr, rs, rg + real(wp), dimension(kts:kte):: temp, pres, qv, rho, rhof + real(wp), dimension(kts:kte):: rc, rr, nr, rs, rg - real(kind_dbl_prec), dimension(kts:kte):: ilamr, ilamg, N0_r, N0_g - real(kind_phys), dimension(kts:kte):: mvd_r - real(kind_phys), dimension(kts:kte):: smob, smo2, smoc, smoz - real(kind_phys):: oM3, M0, Mrat, slam1, slam2, xDs - real(kind_phys):: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts - real(kind_phys):: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt + real(dp), dimension(kts:kte):: ilamr, ilamg, N0_r, N0_g + real(wp), dimension(kts:kte):: mvd_r + real(wp), dimension(kts:kte):: smob, smo2, smoc, smoz + real(wp):: oM3, M0, Mrat, slam1, slam2, xDs + real(wp):: ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts + real(wp):: vtr_dbz_wt, vts_dbz_wt, vtg_dbz_wt - real(kind_phys), dimension(kts:kte):: ze_rain, ze_snow, ze_graupel + real(wp), dimension(kts:kte):: ze_rain, ze_snow, ze_graupel - real(kind_dbl_prec) :: N0_exp, N0_min, lam_exp, lamr, lamg - real(kind_phys):: a_, b_, loga_, tc0, SR - real(kind_dbl_prec) :: fmelt_s, fmelt_g + real(dp) :: N0_exp, N0_min, lam_exp, lamr, lamg + real(wp):: a_, b_, loga_, tc0, SR + real(dp) :: fmelt_s, fmelt_g integer:: i, k, k_0, kbot, n logical, intent(in):: melti logical, dimension(kts:kte):: L_qr, L_qs, L_qg - real(kind_dbl_prec) :: cback, x, eta, f_d - real(kind_phys):: xslw1, ygra1, zans1 + real(dp) :: cback, x, eta, f_d + real(wp):: xslw1, ygra1, zans1 !+---+ if (present(vt_dBZ) .and. present(first_time_step)) then @@ -6222,21 +6222,21 @@ SUBROUTINE semi_lagrange_sedim(km,dzl,wwl,rql,precip,pfsan,dt,R1) implicit none integer, intent(in) :: km - real(kind_phys), intent(in) :: dt, R1 - real(kind_phys), intent(in) :: dzl(km),wwl(km) - real(kind_phys), intent(out) :: precip - real(kind_phys), intent(inout) :: rql(km) - real(kind_phys), intent(out) :: pfsan(km) + real(wp), intent(in) :: dt, R1 + real(wp), intent(in) :: dzl(km),wwl(km) + real(wp), intent(out) :: precip + real(wp), intent(inout) :: rql(km) + real(wp), intent(out) :: pfsan(km) integer :: k,m,kk,kb,kt - real(kind_phys) :: tl,tl2,qql,dql,qqd - real(kind_phys) :: th,th2,qqh,dqh - real(kind_phys) :: zsum,qsum,dim,dip,con1,fa1,fa2 - real(kind_phys) :: allold, decfl - real(kind_phys) :: dz(km), ww(km), qq(km) - real(kind_phys) :: wi(km+1), zi(km+1), za(km+2) - real(kind_phys) :: qn(km) - real(kind_phys) :: dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) - real(kind_phys) :: net_flx(km) + real(wp) :: tl,tl2,qql,dql,qqd + real(wp) :: th,th2,qqh,dqh + real(wp) :: zsum,qsum,dim,dip,con1,fa1,fa2 + real(wp) :: allold, decfl + real(wp) :: dz(km), ww(km), qq(km) + real(wp) :: wi(km+1), zi(km+1), za(km+2) + real(wp) :: qn(km) + real(wp) :: dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) + real(wp) :: net_flx(km) ! precip = 0.0 qa(:) = 0.0 @@ -6449,13 +6449,13 @@ subroutine graupel_psd_parameters(kts, kte, rand1, rg, ilamg, N0_g) implicit none integer, intent(in) :: kts, kte - real(kind_phys), intent(in) :: rand1 - real(kind_phys), intent(in) :: rg(:) - real(kind_dbl_prec), intent(out) :: ilamg(:), N0_g(:) + real(wp), intent(in) :: rand1 + real(wp), intent(in) :: rg(:) + real(dp), intent(out) :: ilamg(:), N0_g(:) integer :: k - real(kind_phys) :: ygra1, zans1 - real(kind_dbl_prec) :: N0_exp, lam_exp, lamg + real(wp) :: ygra1, zans1 + real(dp) :: N0_exp, lam_exp, lamg do k = kte, kts, -1 ygra1 = alog10(max(1.e-9, rg(k))) @@ -6488,13 +6488,13 @@ function hail_mass_99th_percentile(kts, kte, qg, temperature, pressure, qv) resu implicit none integer, intent(in) :: kts, kte - real(kind_phys), intent(in) :: qg(:), temperature(:), pressure(:), qv(:) - real(kind_phys) :: max_hail_diam + real(wp), intent(in) :: qg(:), temperature(:), pressure(:), qv(:) + real(wp) :: max_hail_diam integer :: k - real(kind_phys) :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte) - real(kind_dbl_prec) :: ilamg(kts:kte), N0_g(kts:kte) - real(kind_phys), parameter :: random_number = 0. + real(wp) :: rho(kts:kte), rg(kts:kte), max_hail_column(kts:kte) + real(dp) :: ilamg(kts:kte), N0_g(kts:kte) + real(wp), parameter :: random_number = 0. max_hail_column = 0. rg = 0. From f2ea60d11375c7e1121ab954611ba92c3278674e Mon Sep 17 00:00:00 2001 From: Anders Jensen Date: Fri, 26 Jan 2024 16:48:44 -0700 Subject: [PATCH 006/154] Fixes to precision --- physics/MP/Thompson/module_mp_thompson.F90 | 42 +++++++++++----------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/physics/MP/Thompson/module_mp_thompson.F90 b/physics/MP/Thompson/module_mp_thompson.F90 index 63e7380d4..3c0224568 100644 --- a/physics/MP/Thompson/module_mp_thompson.F90 +++ b/physics/MP/Thompson/module_mp_thompson.F90 @@ -711,10 +711,10 @@ subroutine thompson_init(is_aerosol_aware_in, & xDx(nbi+1) = D0s*2.0_dp do n = 2, nbi xDx(n) = exp(real(n-1, kind=dp)/real(nbi, kind=dp) & - *log(real(xDx(nbi+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) + *log(xDx(nbi+1)/xDx(1)) + log(xDx(1))) enddo do n = 1, nbi - Di(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) + Di(n) = sqrt(xDx(n)*xDx(n+1)) dti(n) = xDx(n+1) - xDx(n) enddo @@ -723,10 +723,10 @@ subroutine thompson_init(is_aerosol_aware_in, & xDx(nbr+1) = 0.005_dp do n = 2, nbr xDx(n) = exp(real(n-1, kind=dp)/real(nbr, kind=dp) & - *log(real(xDx(nbr+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) + *log(xDx(nbr+1)/xDx(1)) + log(xDx(1))) enddo do n = 1, nbr - Dr(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) + Dr(n) = sqrt(xDx(n)*xDx(n+1)) dtr(n) = xDx(n+1) - xDx(n) enddo @@ -735,10 +735,10 @@ subroutine thompson_init(is_aerosol_aware_in, & xDx(nbs+1) = 0.02_dp do n = 2, nbs xDx(n) = exp(real(n-1, kind=dp)/real(nbs, kind=dp) & - *log(real(xDx(nbs+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) + *log(xDx(nbs+1)/xDx(1)) + log(xDx(1))) enddo do n = 1, nbs - Ds(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) + Ds(n) = sqrt(xDx(n)*xDx(n+1)) dts(n) = xDx(n+1) - xDx(n) enddo @@ -747,10 +747,10 @@ subroutine thompson_init(is_aerosol_aware_in, & xDx(nbg+1) = 0.05_dp do n = 2, nbg xDx(n) = exp(real(n-1, kind=dp)/real(nbg, kind=dp) & - *log(real(xDx(nbg+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) + *log(xDx(nbg+1)/xDx(1)) + log(xDx(1))) enddo do n = 1, nbg - Dg(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) + Dg(n) = sqrt(xDx(n)*xDx(n+1)) dtg(n) = xDx(n+1) - xDx(n) enddo @@ -759,12 +759,12 @@ subroutine thompson_init(is_aerosol_aware_in, & xDx(nbc+1) = 3000.0_dp do n = 2, nbc xDx(n) = exp(real(n-1, kind=dp)/real(nbc, kind=dp) & - *log(real(xDx(nbc+1)/xDx(1), kind=dp)) + log(real(xDx(1), kind=dp))) + *log(xDx(nbc+1)/xDx(1)) + log(xDx(1))) enddo do n = 1, nbc - t_Nc(n) = sqrt(real(xDx(n)*xDx(n+1), kind=dp)) * 1.e6_dp + t_Nc(n) = sqrt(xDx(n)*xDx(n+1)) * 1.e6_dp enddo - nic1 = log(real(t_Nc(nbc)/t_Nc(1), kind=dp)) + nic1 = log(t_Nc(nbc)/t_Nc(1)) !+---+-----------------------------------------------------------------+ !> - Create lookup tables for most costly calculations @@ -2525,7 +2525,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Rain collecting cloud water. In CE, assume Dc< - Snow collecting cloud water. In CE, assume Dc< Date: Fri, 23 Feb 2024 03:22:07 +0000 Subject: [PATCH 007/154] "MYNN, GF, RUC LSM and smoke plumerise updates for RRFSv1 code freeze" --- physics/CONV/Grell_Freitas/cu_gf_deep.F90 | 14 ++++---- .../UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 | 11 +++--- .../UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta | 15 ++++++++ physics/PBL/MYNN_EDMF/module_bl_mynn.F90 | 8 ++--- physics/SFC_Models/Land/RUC/lsm_ruc.F90 | 3 +- .../SFC_Models/Land/RUC/module_sf_ruclsm.F90 | 4 +-- physics/smoke_dust/module_smoke_plumerise.F90 | 36 +++++++++++++------ physics/smoke_dust/rrfs_smoke_wrapper.F90 | 9 +++-- physics/smoke_dust/rrfs_smoke_wrapper.meta | 8 +++++ 9 files changed, 76 insertions(+), 32 deletions(-) diff --git a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 index 8a2c73600..cbf02effb 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 @@ -425,9 +425,9 @@ subroutine cu_gf_deep_run( & integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers - real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB + real(kind=kind_phys), dimension (its:ite) :: c0, rrfs_factor ! HCB real(kind=kind_phys), dimension (its:ite,kts:kte) :: c0t3d ! hli for smoke/dust wet scavenging -!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0,c0t3d) +!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0,rrfs_factor,c0t3d) ! rainevap from sas real(kind=kind_phys) zuh2(40) @@ -486,6 +486,7 @@ subroutine cu_gf_deep_run( & ! Set cloud water to rain water conversion rate (c0) !$acc kernels c0(:)=0.004 + rrfs_factor(:)=1. do i=its,itf xland1(i)=int(xland(i)+.0001) ! 1. if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then @@ -495,6 +496,7 @@ subroutine cu_gf_deep_run( & if(imid.eq.1)then c0(i)=0.002 endif + if(kdt.le.(4500./dtime))rrfs_factor(i)=1.-(float(kdt)/(4500./dtime)-1.)**2 enddo !$acc end kernels @@ -591,7 +593,6 @@ subroutine cu_gf_deep_run( & sig(i)=(1.-frh)**2 !frh_out(i) = frh if(forcing(i,7).eq.0.)sig(i)=1. - if(kdt.le.(3600./dtime))sig(i)=1. frh_out(i) = frh*sig(i) enddo !$acc end kernels @@ -2029,7 +2030,7 @@ subroutine cu_gf_deep_run( & zuo,pre,pwo_ens,xmb,ktop, & edto,pwdo,'deep',ierr2,ierr3, & po_cup,pr_ens,maxens3, & - sig,closure_n,xland1,xmbm_in,xmbs_in, & + sig,closure_n,xland1,xmbm_in,xmbs_in,rrfs_factor, & ichoice,imid,ipr,itf,ktf, & its,ite, kts,kte, & dicycle,xf_dicycle ) @@ -4056,7 +4057,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & zu,pre,pw,xmb,ktop, & edt,pwd,name,ierr2,ierr3,p_cup,pr_ens, & maxens3, & - sig,closure_n,xland1,xmbm_in,xmbs_in, & + sig,closure_n,xland1,xmbm_in,xmbs_in,rrfs_factor, & ichoice,imid,ipr,itf,ktf, & its,ite, kts,kte, & dicycle,xf_dicycle ) @@ -4118,7 +4119,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ,intent (inout) :: & ierr,ierr2,ierr3 integer, intent(in) :: dicycle - real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle + real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle, rrfs_factor !$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) !$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) ! @@ -4198,6 +4199,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & clos_wei=16./max(1.,closure_n(i)) xmb_ave(i)=min(xmb_ave(i),100.) xmb(i)=clos_wei*sig(i)*xmb_ave(i) + if(dx(i) diag3d(:,:,35:35) ncten3 => diag3d(:,:,36:36) qcten3 => diag3d(:,:,37:37) + else + allocate(prw_vcdc (0,0,0)) + allocate(prw_vcde (0,0,0)) + allocate(tpri_inu (0,0,0)) + allocate(tpri_ide_d (0,0,0)) + allocate(tpri_ide_s (0,0,0)) + allocate(tprs_ide (0,0,0)) + allocate(tprs_sde_d (0,0,0)) + allocate(tprs_sde_s (0,0,0)) + allocate(tprg_gde_d (0,0,0)) + allocate(tprg_gde_s (0,0,0)) + allocate(tpri_iha (0,0,0)) + allocate(tpri_wfz (0,0,0)) + allocate(tpri_rfz (0,0,0)) + allocate(tprg_rfz (0,0,0)) + allocate(tprs_scw (0,0,0)) + allocate(tprg_scw (0,0,0)) + allocate(tprg_rcs (0,0,0)) + allocate(tprs_rcs (0,0,0)) + allocate(tprr_rci (0,0,0)) + allocate(tprg_rcg (0,0,0)) + allocate(tprw_vcd_c (0,0,0)) + allocate(tprw_vcd_e (0,0,0)) + allocate(tprr_sml (0,0,0)) + allocate(tprr_gml (0,0,0)) + allocate(tprr_rcg (0,0,0)) + allocate(tprr_rcs (0,0,0)) + allocate(tprv_rev (0,0,0)) + allocate(tten3 (0,0,0)) + allocate(qvten3 (0,0,0)) + allocate(qrten3 (0,0,0)) + allocate(qsten3 (0,0,0)) + allocate(qgten3 (0,0,0)) + allocate(qiten3 (0,0,0)) + allocate(niten3 (0,0,0)) + allocate(nrten3 (0,0,0)) + allocate(ncten3 (0,0,0)) + allocate(qcten3 (0,0,0)) end if set_extended_diagnostic_pointers !> - Call mp_gt_driver() with or without aerosols, with or without effective radii, ... if (is_aerosol_aware .or. merra2_aerosol_aware) then diff --git a/physics/photochem/module_ozphys.F90 b/physics/photochem/module_ozphys.F90 index f824736b1..8d0486422 100644 --- a/physics/photochem/module_ozphys.F90 +++ b/physics/photochem/module_ozphys.F90 @@ -198,7 +198,7 @@ end subroutine update_o3prog ! ######################################################################################### ! Procedure (type-bound) for NRL prognostic ozone (2015). ! ######################################################################################### - subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, & + subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do_diag, do3_dt_prd, & do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) class(ty_ozphys), intent(in) :: this real(kind_phys), intent(in) :: & @@ -213,7 +213,8 @@ subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, ozpl ! Ozone forcing data real(kind_phys), intent(inout), dimension(:,:) :: & oz ! Ozone concentration updated by physics - real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + logical, intent(in) :: do_diag + real(kind_phys), intent(inout), dimension(:,:) :: & do3_dt_prd, & ! Physics tendency: production and loss effect do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect do3_dt_temp, & ! Physics tendency: temperature effect @@ -297,10 +298,12 @@ subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, enddo ! Diagnostics (optional) - if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = (prod(:,1)-prod(:,2)*prod(:,6))*dt - if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) - if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3)*(t(:,iLev)-prod(:,5))*dt - if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * (colo3(:,iLev)-coloz(:,iLev))*dt + if (do_diag) then + do3_dt_prd(:,iLev) = (prod(:,1)-prod(:,2)*prod(:,6))*dt + do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) + do3_dt_temp(:,iLev) = prod(:,3)*(t(:,iLev)-prod(:,5))*dt + do3_dt_ohoz(:,iLev) = prod(:,4) * (colo3(:,iLev)-coloz(:,iLev))*dt + endif enddo return @@ -309,7 +312,7 @@ end subroutine run_o3prog_2015 ! ######################################################################################### ! Procedure (type-bound) for NRL prognostic ozone (2006). ! ######################################################################################### - subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, & + subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do_diag, do3_dt_prd, & do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) class(ty_ozphys), intent(in) :: this real(kind_phys), intent(in) :: & @@ -324,7 +327,8 @@ subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, ozpl ! Ozone forcing data real(kind_phys), intent(inout), dimension(:,:) :: & oz ! Ozone concentration updated by physics - real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: & + logical, intent(in) :: do_diag + real(kind_phys), intent(inout), dimension(:,:) :: & do3_dt_prd, & ! Physics tendency: production and loss effect do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect do3_dt_temp, & ! Physics tendency: temperature effect @@ -418,12 +422,14 @@ subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 + prod(iCol,2)*dt) enddo endif - ! Diagnostics (optional) - if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = prod(:,1)*dt - if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) - if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3) * t(:,iLev) * dt - if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * colo3(:,iLev) * dt + ! Diagnostics (optional) + if (do_diag) then + do3_dt_prd(:,iLev) = prod(:,1)*dt + do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:)) + do3_dt_temp(:,iLev) = prod(:,3) * t(:,iLev) * dt + do3_dt_ohoz(:,iLev) = prod(:,4) * colo3(:,iLev) * dt + endif enddo return From 9cd8d824b5bb2bf6ee1b367294ce5f40fefda041 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Tue, 27 Feb 2024 18:28:41 +0000 Subject: [PATCH 010/154] "update to address code reviewer's comments" --- physics/GWD/drag_suite.F90 | 3 ++- .../Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 | 4 ++-- physics/smoke_dust/module_smoke_plumerise.F90 | 6 ------ physics/smoke_dust/rrfs_smoke_wrapper.F90 | 4 ++-- physics/smoke_dust/rrfs_smoke_wrapper.meta | 8 -------- 5 files changed, 6 insertions(+), 19 deletions(-) diff --git a/physics/GWD/drag_suite.F90 b/physics/GWD/drag_suite.F90 index ff68f4216..71bb0a64f 100644 --- a/physics/GWD/drag_suite.F90 +++ b/physics/GWD/drag_suite.F90 @@ -1363,7 +1363,8 @@ subroutine drag_suite_run( & DO k=kts,km wsp=SQRT(uwnd1(i,k)**2 + vwnd1(i,k)**2) ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - var_temp = 0.0759*EXP(-(zl(i,k)/H_efold)**1.5)*a2* & + ! Change alpha to 35 -- 0.0759 becomes 0.2214 + var_temp = 0.2214*EXP(-(zl(i,k)/H_efold)**1.5)*a2* & zl(i,k)**(-1.2)*ss_taper(i) ! this is greater than zero ! Note: This is a semi-implicit treatment of the time differencing ! per Beljaars et al. (2004, QJRMS) diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 index 060c7f59e..d9d30fb90 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 @@ -21,11 +21,11 @@ module GFS_MP_generic_post subroutine GFS_MP_generic_post_run( & im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rhowater, rainmin, dtf, & - frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, phil, htop, refl_10cm, & + frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, phil, htop, refl_10cm, & imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf, con_t0c, snow, graupel, save_t, save_q, & rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp,& totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, & - pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, & + pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & diff --git a/physics/smoke_dust/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 index 61215e5e1..13016d929 100755 --- a/physics/smoke_dust/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -109,12 +109,6 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! print *,' Plumerise_scalar 1',ncall coms => get_thread_coms() -IF (frp_inst Date: Fri, 23 Feb 2024 19:53:47 -0500 Subject: [PATCH 011/154] use physical constants from host for Thompson MP --- physics/MP/Thompson/module_mp_thompson.F90 | 62 ++++++++----- ...mp_thompson_make_number_concentrations.F90 | 2 +- physics/MP/Thompson/mp_thompson.F90 | 30 ++++++- physics/MP/Thompson/mp_thompson.meta | 88 +++++++++++++++++++ 4 files changed, 154 insertions(+), 28 deletions(-) diff --git a/physics/MP/Thompson/module_mp_thompson.F90 b/physics/MP/Thompson/module_mp_thompson.F90 index 3c0224568..453b2dd8b 100644 --- a/physics/MP/Thompson/module_mp_thompson.F90 +++ b/physics/MP/Thompson/module_mp_thompson.F90 @@ -75,8 +75,8 @@ module module_mp_thompson logical, parameter, private :: homogIce = .true. integer, parameter, private :: IFDRY = 0 - real(wp), parameter, private :: T_0 = 273.15 - real(wp), parameter, private :: PI = 3.1415926536 + real(wp) :: T_0 !set in mp_thompson_init from host model + real(wp) :: PI !set in mp_thompson_init from host model !..Densities of rain, snow, graupel, and cloud ice. real(wp), parameter, private :: rho_w = 1000.0 @@ -131,13 +131,13 @@ module module_mp_thompson !..Mass power law relations: mass = am*D**bm !.. Snow from Field et al. (2005), others assume spherical form. - real(wp), parameter, private :: am_r = PI*rho_w/6.0 + real(wp), private :: am_r !set in thompson_init real(wp), parameter, private :: bm_r = 3.0 real(wp), parameter, private :: am_s = 0.069 real(wp), parameter, private :: bm_s = 2.0 - real(wp), parameter, private :: am_g = PI*rho_g/6.0 + real(wp), private :: am_g !set in thompson_init real(wp), parameter, private :: bm_g = 3.0 - real(wp), parameter, private :: am_i = PI*rho_i/6.0 + real(wp), private :: am_i !set in thompson_init real(wp), parameter, private :: bm_i = 3.0 !..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D) @@ -181,7 +181,7 @@ module module_mp_thompson real(wp), parameter, private :: ATO = 0.304 !..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. - real(wp), parameter, private :: rho_not = 101325.0 / (287.05*298.0) + real(wp) :: rho_not !set in thompson_init !..Schmidt number real(wp), parameter, private :: Sc = 0.632 @@ -191,25 +191,25 @@ module module_mp_thompson real(wp), parameter, private:: HGFR = 235.16 !..Water vapor and air gas constants at constant pressure - real(wp), parameter, private :: Rv = 461.5 - real(wp), parameter, private :: oRv = 1./Rv - real(wp), parameter, private :: R = 287.04 - real(wp), parameter, private :: RoverRv = R*oRv - real(wp), parameter, private :: Cp = 1004.0 - real(wp), parameter, private :: R_uni = 8.314 !< J (mol K)-1 - - real(dp), parameter, private :: k_b = 1.38065e-23 !< Boltzmann constant [J/K] - real(dp), parameter, private :: M_w = 18.01528e-3 !< molecular mass of water [kg/mol] - real(dp), parameter, private :: M_a = 28.96e-3 !< molecular mass of air [kg/mol] - real(dp), parameter, private :: N_avo = 6.022e23 !< Avogadro number [1/mol] - real(dp), parameter, private :: ma_w = M_w / N_avo !< mass of water molecule [kg] - real(wp), parameter, private :: ar_volume = 4./3.*PI*(2.5e-6)**3 !< assume radius of 0.025 micrometer, 2.5e-6 cm + real(wp) :: Rv !set in mp_thompson_init from host model + real(wp), private :: oRv !set in thompson_init + real(wp) :: R !set in mp_thompson_init from host model + real(wp) :: RoverRv !set in mp_thompson_init from host model + real(wp) :: Cp !set in mp_thompson_init from host model + real(wp) :: R_uni !set in mp_thompson_init from host model + + real(dp) :: k_b !set in mp_thompson_init from host model !< Boltzmann constant [J/K] + real(dp) :: M_w !set in mp_thompson_init from host model !< molecular mass of water [kg/mol] + real(dp) :: M_a !set in mp_thompson_init from host model !< molecular mass of air [kg/mol] + real(dp) :: N_avo !set in mp_thompson_init from host model !< Avogadro number [1/mol] + real(dp), private :: ma_w !set in thompson_init !< mass of water molecule [kg] + real(wp), private :: ar_volume !set in thompson_init !..Enthalpy of sublimation, vaporization, and fusion at 0C. - real(wp), parameter, private :: lsub = 2.834e6 - real(wp), parameter, private :: lvap0 = 2.5e6 - real(wp), parameter, private :: lfus = lsub - lvap0 - real(wp), parameter, private :: olfus = 1./lfus + real(wp), private :: lsub !set in thompson_init + real(wp) :: lvap0 !set in mp_thompson_init from host model + real(wp) :: lfus !set in mp_thompson_init from host model + real(wp), private :: olfus !set in thompson_init !..Ice initiates with this mass (kg), corresponding diameter calc. !..Min diameters and mass of cloud, rain, snow, and graupel (m, kg). @@ -456,6 +456,22 @@ subroutine thompson_init(is_aerosol_aware_in, & real(wp) :: stime, etime logical, parameter :: precomputed_tables = .FALSE. +! Set module derived constants + am_r = PI*rho_w/6.0 + am_g = PI*rho_g/6.0 + am_i = PI*rho_i/6.0 + + ar_volume = 4./3.*PI*(2.5e-6)**3 !< assume radius of 0.025 micrometer, 2.5e-6 cm + + rho_not = 101325.0 / (R*298.0) + + oRv = 1./Rv + + ma_w = M_w / N_avo + + lsub = lvap0 + lfus + olfus = 1./lfus + ! Set module variable is_aerosol_aware/merra2_aerosol_aware is_aerosol_aware = is_aerosol_aware_in merra2_aerosol_aware = merra2_aerosol_aware_in diff --git a/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 b/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 index 72a1055dd..a54f910c9 100644 --- a/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 +++ b/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 @@ -4,7 +4,7 @@ !>\ingroup aathompson module module_mp_thompson_make_number_concentrations - use physcons, only: PI => con_pi + use module_mp_thompson, only: PI implicit none diff --git a/physics/MP/Thompson/mp_thompson.F90 b/physics/MP/Thompson/mp_thompson.F90 index 7b5b83b37..d66a62256 100644 --- a/physics/MP/Thompson/mp_thompson.F90 +++ b/physics/MP/Thompson/mp_thompson.F90 @@ -7,7 +7,7 @@ module mp_thompson use machine, only : kind_phys - + use module_mp_thompson, only : thompson_init, mp_gt_driver, thompson_finalize, calc_effectRad use module_mp_thompson, only : naIN0, naIN1, naCCN0, naCCN1, eps, Nt_c_l, Nt_c_o use module_mp_thompson, only : re_qc_min, re_qc_max, re_qi_min, re_qi_max, re_qs_min, re_qs_max @@ -30,7 +30,10 @@ module mp_thompson !! \section arg_table_mp_thompson_init Argument Table !! \htmlinclude mp_thompson_init.html !! - subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & + subroutine mp_thompson_init(ncol, nlev, con_pi, con_t0c, con_rv, & + con_cp, con_rgas, con_boltz, con_amd, & + con_amw, con_avgd, con_hvap, con_hfus, & + con_g, con_rd, con_eps, & restart, imp_physics, & imp_physics_thompson, convert_dry_rho, & spechum, qc, qr, qi, qs, qg, ni, nr, & @@ -40,13 +43,17 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & aerfld, mpicomm, mpirank, mpiroot, & threads, ext_diag, diag3d, & errmsg, errflg) - + use module_mp_thompson, only : PI, T_0, Rv, R, RoverRv, Cp + use module_mp_thompson, only : R_uni, k_b, M_w, M_a, N_avo, lvap0, lfus + implicit none ! Interface variables integer, intent(in ) :: ncol integer, intent(in ) :: nlev - real(kind_phys), intent(in ) :: con_g, con_rd, con_eps + real(kind_phys), intent(in ) :: con_pi, con_t0c, con_rv, con_cp, con_rgas, & + con_boltz, con_amd, con_amw, con_avgd, & + con_hvap, con_hfus, con_g, con_rd, con_eps logical, intent(in ) :: restart integer, intent(in ) :: imp_physics integer, intent(in ) :: imp_physics_thompson @@ -103,6 +110,21 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & if (is_initialized) return + ! Set local Thompson MP module constants from host model + PI = con_pi + T_0 = con_t0c + Rv = con_Rv + R = con_rd + RoverRv = con_eps + Cp = con_cp + R_uni = con_rgas + k_b = con_boltz + M_w = con_amw*1.0E-3 !module_mp_thompson expects kg/mol + M_a = con_amd*1.0E-3 !module_mp_thompson expects kg/mol + N_avo = con_avgd + lvap0 = con_hvap + lfus = con_hfus + ! Consistency checks if (imp_physics/=imp_physics_thompson) then write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from Thompson MP" diff --git a/physics/MP/Thompson/mp_thompson.meta b/physics/MP/Thompson/mp_thompson.meta index ffe34bafb..b880d2e26 100644 --- a/physics/MP/Thompson/mp_thompson.meta +++ b/physics/MP/Thompson/mp_thompson.meta @@ -23,6 +23,94 @@ dimensions = () type = integer intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degrees Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rgas] + standard_name = molar_gas_constant + long_name = universal ideal molar gas constant + units = J K-1 mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_boltz] + standard_name = boltzmann_constant + long_name = Boltzmann constant + units = J K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amd] + standard_name = molecular_weight_of_dry_air + long_name = molecular weight of dry air + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amw] + standard_name = molecular_weight_of_water_vapor + long_name = molecular weight of water vapor + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_avgd] + standard_name = avogadro_consant + long_name = Avogadro constant + units = mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration From 8718420e5cd52498fd4b1ef57bf7603da0217180 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 27 Feb 2024 16:04:42 +0000 Subject: [PATCH 012/154] change parameters to variables in module_mp_thompson_make_number_concentrations.F90 due to passing in PI as variable --- .../module_mp_thompson_make_number_concentrations.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 b/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 index a54f910c9..7618b0a9f 100644 --- a/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 +++ b/physics/MP/Thompson/module_mp_thompson_make_number_concentrations.F90 @@ -137,13 +137,15 @@ elemental real function make_DropletNumber (Q_cloud, qnwfa) real, intent(in):: Q_cloud, qnwfa !real, parameter:: PI = 3.1415926536 - real, parameter:: am_r = PI*1000./6. + real :: am_r real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & & 504,720,990,1320,1716,2184,2730,3360,4080,4896/) double precision:: lambda, qnc real:: q_nwfa, x1, xDc integer:: nu_c + am_r = PI*1000./6. + if (Q_cloud == 0) then make_DropletNumber = 0 return @@ -176,7 +178,9 @@ elemental real function make_RainNumber (Q_rain, temp) real, intent(in):: Q_rain, temp double precision:: lambda, N0, qnr !real, parameter:: PI = 3.1415926536 - real, parameter:: am_r = PI*1000./6. + real :: am_r + + am_r = PI*1000./6. if (Q_rain == 0) then make_RainNumber = 0 From 9fba7ff0120914054468349ff42d7fe3caa1cb51 Mon Sep 17 00:00:00 2001 From: tsga Date: Sat, 16 Mar 2024 16:56:50 +0000 Subject: [PATCH 013/154] land iau init --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 967 ++++++++++++++++++ physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 132 ++- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 152 ++- 3 files changed, 1213 insertions(+), 38 deletions(-) create mode 100644 physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 new file mode 100644 index 000000000..2b53edd81 --- /dev/null +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -0,0 +1,967 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!> The routine 'remapcoeff is copied from 'fv_treat_da_inc.F90 by Xi.Chen +! and put at the end of this module because, due to the compile order in CCPP framework it wasn't possible to 'include' +! the original module when the land iau mod is called through CCPP frameowrk +! + + +!------------------------------------------------------------------------------- +!> @brief incremental analysis update module +!> @author Xi.Chen - author of fv_treat_da_inc.F90 +!> @author Philip Pegion +!> @date 09/13/2017 +! +!> REVISION HISTORY: +!> 09/13/2017 - Initial Version based on fv_treat_da_inc.F90 +!------------------------------------------------------------------------------- + +#ifdef OVERLOAD_R4 +#define _GET_VAR1 get_var1_real +#else +#define _GET_VAR1 get_var1_double +#endif + +module lnd_iau_mod + +! use fms_mod, only: file_exist +! use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe +! use mpp_domains_mod, only: domain2d +! use constants_mod, only: pi=>pi_8 +! use fv_arrays_mod, only: R_GRID !, & + ! fv_atmos_type, & + ! fv_grid_type, & + ! fv_grid_bounds_type, & +! use fv_mp_mod, only: is_master + use sim_nc_mod_lnd, only: open_ncfile, & + close_ncfile, & + get_ncdim1, & + get_var1_double, & + get_var3_r4, & + get_var1_real, check_var_exists +! #ifdef GFS_TYPES +! use GFS_typedefs, only: IPD_init_type => GFS_init_type, & +! LND_IAU_Control_type => GFS_control_type, & +! kind_phys, & +! IPD_Data_type => GFS_data_type +! #else +! use IPD_typedefs, only: IPD_init_type, LND_IAU_Control_type, & +! kind_phys => IPD_kind_phys +! #endif + +! use block_control_mod, only: block_control_type +! use fv_treat_da_inc_mod, only: remap_coef +! use tracer_manager_mod, only: get_tracer_names,get_tracer_index, get_number_tracers +! use field_manager_mod, only: MODEL_ATMOS + + use machine, only: kind_phys, kind_dyn + use physcons, only: pi => con_pi + + implicit none + + private + + real,allocatable::s2c(:,:,:) +! real:: s2c(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je,4) +! integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je):: & +! id1, id2, jdc + integer,allocatable,dimension(:,:) :: id1,id2,jdc + + real :: deg2rad,dt,rdt + integer :: im,jm,km,nfiles,ncid + + integer :: n_soill, n_snowl !1.27.24 soil and snow layers + logical :: do_lnd_iau_inc !do_lnd_iau_inc + + integer :: is, ie, js, je + integer :: npz !, ntracers +! character(len=32), allocatable :: tracer_names(:) +! integer, allocatable :: tracer_indicies(:) + + real(kind=4), allocatable:: wk3(:,:,:) + + type iau_internal_data_type + ! real,allocatable :: ua_inc(:,:,:) + ! real,allocatable :: va_inc(:,:,:) + ! real,allocatable :: temp_inc(:,:,:) + ! real,allocatable :: delp_inc(:,:,:) + ! real,allocatable :: delz_inc(:,:,:) + ! real,allocatable :: tracer_inc(:,:,:,:) + real,allocatable :: stc_inc(:,:,:) + real,allocatable :: slc_inc(:,:,:) + real,allocatable :: tmp2m_inc(:,:, :) + real,allocatable :: spfh2m_inc(:,:, :) + end type iau_internal_data_type + + type lnd_iau_external_data_type + real,allocatable :: stc_inc(:,:,:) + real,allocatable :: slc_inc(:,:,:) + real,allocatable :: tmp2m_inc(:,:,:) + real,allocatable :: spfh2m_inc(:,:,:) + logical :: in_interval = .false. + ! logical :: drymassfixer = .false. + end type lnd_iau_external_data_type + + type iau_state_type + type(iau_internal_data_type):: inc1 + type(iau_internal_data_type):: inc2 + real(kind=kind_phys) :: hr1 + real(kind=kind_phys) :: hr2 + real(kind=kind_phys) :: wt + real(kind=kind_phys) :: wt_normfact + end type iau_state_type + + type lnd_iau_control_type + integer :: isc + integer :: jsc + integer :: nx + integer :: ny + integer :: nblks + ! integer :: blksz ! this could vary for the last block + integer, allocatable :: blksz(:) + integer, allocatable :: blk_strt_indx(:) + + integer :: lsoil !< number of soil layers + ! this is the max dim (TBC: check it is consitent for noahmpdrv) + integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model + logical :: do_lnd_iau_inc + real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours + character(len=240) :: iau_inc_files(7)! list of increment files + real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files + logical :: iau_filter_increments + !, iau_drymassfixer + integer :: me !< MPI rank designator + integer :: mpi_root !< MPI rank of master atmosphere processor + character(len=64) :: fn_nml !< namelist filename for surface data cycling + real(kind=kind_phys) :: dtp !< physics timestep in seconds + real(kind=kind_phys) :: fhour !< current forecast hour + character(len=:), pointer, dimension(:) :: input_nml_file => null() ! null() !< character string containing full namelist + ! integer :: logunit + !--- calendars and time parameters and activation triggers + ! real(kind=kind_phys) :: dtf !< dynamics timestep in seconds + ! integer :: idat(1:8) !< initialization date and time + ! !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) + ! integer :: jdat(1:8) !< current forecast date and time + ! !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) + ! real(kind=kind_phys) :: sec !< seconds since model initialization + ! real(kind=kind_phys) :: phour !< previous forecast hour + ! real(kind=kind_phys) :: zhour !< previous hour diagnostic buckets emptied + ! integer :: kdt !< current forecast iteration + ! logical :: first_time_step !< flag signaling first time step for time integration routine + end type lnd_iau_control_type + + type(iau_state_type) :: IAU_state + public lnd_iau_control_type, lnd_iau_external_data_type, lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing + +contains + +subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, mpi_root, isc, jsc, nx, ny, nblks, blksz, & + lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) !nlunit + + type (lnd_iau_control_type), intent(inout) :: LND_IAU_Control + character(*), intent(in) :: fn_nml !< namelist filename for surface data cycling + character(len=:), intent(in), dimension(:), pointer :: input_nml_file_i + integer, intent(in) :: me, mpi_root !< MPI rank of master atmosphere processor + integer, intent(in) :: isc, jsc, nx, ny, nblks, lsoil, lsnow_lsm + integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + real(kind=kind_phys), intent(in) :: dtp !< physics timestep in seconds + real(kind=kind_phys), intent(in) :: fhour !< current forecast hour + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: nb, ix + integer :: nlunit = 360 ! unit for namelist !, intent(in) + integer :: ios + logical :: exists + character(len=512) :: ioerrmsg + !character(len=32) :: fn_nml = "input.nml" + character(len=:), pointer, dimension(:) :: input_nml_file => null() + integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads + + + !> 3.9.24 these are not available through the CCPP interface so need to read them from namelist file + !> vars to read from namelist + logical :: do_lnd_iau_inc = .false. + real(kind=kind_phys) :: lnd_iau_delthrs = 0 !< iau time interval (to scale increments) + character(len=240) :: lnd_iau_inc_files(7) = '' !< list of increment files + real(kind=kind_phys) :: lnd_iaufhrs(7) = -1 !< forecast hours associated with increment files + logical :: lnd_iau_filter_increments = .false. !< filter IAU increments + + NAMELIST /lnd_iau_nml/ do_lnd_iau_inc, lnd_iau_delthrs, lnd_iau_inc_files, lnd_iaufhrs, lnd_iau_filter_increments !, lnd_iau_drymassfixer & + + !Errors messages handled through CCPP error handling variables + errmsg = '' + errflg = 0 + +!3.11.24: copied from GFS_typedefs.F90 +#ifdef INTERNAL_FILE_NML + ! allocate required to work around GNU compiler bug 100886 + ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=100886 + allocate(input_nml_file, mold=input_nml_file_i) + input_nml_file => input_nml_file_i + read(input_nml_file, nml=lnd_iau_nml) + ! Set length (number of lines) in namelist for internal reads + input_nml_file_length = size(input_nml_file) +#else + ! if (file_exist(fn_nml)) then + inquire (file=trim(fn_nml), exist=exists) ! TBCL: this maybe be replaced by nlunit passed from ccpp + if (.not. exists) then + ! call mpp_error(FATAL, 'lnd_iau_mod_set_control: namelist file ',trim(fn_nml),' does not exist') + write(6,*) 'lnd_iau_mod_set_control: namelist file ',trim(fn_nml),' does not exist' + errmsg = 'lnd_iau_mod_set_control: namelist file '//trim(fn_nml)//' does not exist' + errflg = 1 + return + else + LND_IAU_Control%fn_nml = trim(fn_nml) ! maynot need this + open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios, iomsg=ioerrmsg) + rewind(nlunit) + read (nlunit, nml=lnd_iau_nml) + close (nlunit) + if (ios /= 0) then + ! call mpp_error(FATAL, 'lnd_iau_mod_set_control: error reading namelist file ',trim(fn_nml)) + ! write(6,*) 'lnd_iau_mod_set_control: error reading namelist file ',trim(fn_nml) + write(6,*) trim(ioerrmsg) + errmsg = 'lnd_iau_mod_set_control: error reading namelist file '//trim(fn_nml) & + // 'the error message from file handler:' //trim(ioerrmsg) + errflg = 1 + return + end if + endif +#endif + + if (me == mpi_root) then + write(6,*) "lnd_iau_nml" + write(6, lnd_iau_nml) + endif + + LND_IAU_Control%do_lnd_iau_inc = do_lnd_iau_inc + LND_IAU_Control%iau_delthrs = lnd_iau_delthrs + LND_IAU_Control%iau_inc_files = lnd_iau_inc_files + LND_IAU_Control%iaufhrs = lnd_iaufhrs + LND_IAU_Control%iau_filter_increments = lnd_iau_filter_increments + ! LND_IAU_Control%iau_drymassfixer = lnd_iau_drymassfixer + LND_IAU_Control%me = me + LND_IAU_Control%mpi_root = mpi_root + LND_IAU_Control%isc = isc + LND_IAU_Control%jsc = jsc + LND_IAU_Control%nx = nx + LND_IAU_Control%ny = ny + LND_IAU_Control%nblks = nblks + LND_IAU_Control%lsoil = lsoil + LND_IAU_Control%lsnow_lsm = lsnow_lsm + LND_IAU_Control%dtp = dtp + LND_IAU_Control%fhour = fhour + + LND_IAU_Control%input_nml_file = input_nml_file + LND_IAU_Control%input_nml_file_length = input_nml_file_length + + allocate(LND_IAU_Control%blksz(nblks)) + allocate(LND_IAU_Control%blk_strt_indx(nblks)) + !start index of each block, for flattened (ncol=nx*ny) arrays + ! required in noahmpdriv_run to get subsection of the stc array for each + ! proc/thread + ix = 1 + do nb=1, nblks + LND_IAU_Control%blksz(nb) = blksz(nb) + LND_IAU_Control%blk_strt_indx(nb) = ix + ix = ix + blksz(nb) + enddo + +end subroutine lnd_iau_mod_set_control + +subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) + ! integer, intent(in) :: me, mpi_root + type (lnd_iau_control_type), intent(in) :: LND_IAU_Control + type (lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + ! type (IPD_init_type), intent(in) :: Init_parm + ! type (IPD_Data_type), dimension(:), intent(in) :: IPD_Data + ! integer, intent(in) :: ncols + real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local + character(len=128) :: fname + ! real, dimension(:,:,:), allocatable:: u_inc, v_inc + real(kind=kind_dyn), allocatable:: lat(:), lon(:),agrid(:,:,:) + real(kind=kind_phys) sx,wx,wt,normfact,dtp + + integer:: ib, i, j, k, nstep, kstep + integer:: i1, i2, j1 + integer:: jbeg, jend + + logical:: found + integer nfilesall + integer, allocatable :: idt(:) + + real (kind=kind_phys), allocatable :: Init_parm_xlon (:, :) + real (kind=kind_phys), allocatable :: Init_parm_xlat (:, :) + integer :: nlon, nlat + ! integer :: nb, ix, nblks, blksz + logical :: exists + + !Errors messages handled through CCPP error handling variables + errmsg = '' + errflg = 0 + + do_lnd_iau_inc = LND_IAU_Control%do_lnd_iau_inc + n_soill = LND_IAU_Control%lsoil !4 for sfc updates +! n_snowl = LND_IAU_Control%lsnowl + npz = LND_IAU_Control%lsoil + + is = LND_IAU_Control%isc + ie = is + LND_IAU_Control%nx-1 + js = LND_IAU_Control%jsc + je = js + LND_IAU_Control%ny-1 + nlon = LND_IAU_Control%nx + nlat = LND_IAU_Control%ny + !nblks = LND_IAU_Control%nblks + !blksz = LND_IAU_Control%blksz(1) + + allocate(Init_parm_xlon(nlon,nlat), Init_parm_xlat(nlon,nlat)) + ib = 1 + do j = 1, nlat !ny + ! do i = 1, nx + Init_parm_xlon (:,j) = xlon(ib:ib+nlon-1) + Init_parm_xlat (:,j) = xlat(ib:ib+nlon-1) + ib = ib+nlon + ! enddo + enddo + ! call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers) + ! allocate (tracer_names(ntracers)) + ! allocate (tracer_indicies(ntracers)) + ! do i = 1, ntracers + ! call get_tracer_names(MODEL_ATMOS, i, tracer_names(i)) + ! tracer_indicies(i) = get_tracer_index(MODEL_ATMOS,tracer_names(i)) + ! enddo + allocate(s2c(is:ie,js:je,4)) + allocate(id1(is:ie,js:je)) + allocate(id2(is:ie,js:je)) + allocate(jdc(is:ie,js:je)) + allocate(agrid(is:ie,js:je,2)) +! determine number of increment files to read, and the valid forecast hours + + nfilesall = size(LND_IAU_Control%iau_inc_files) + nfiles = 0 + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print*,'in lnd_iau_init incfile1 iaufhr1 ', & + trim(LND_IAU_Control%iau_inc_files(1)),LND_IAU_Control%iaufhrs(1) + do k=1,nfilesall + if (trim(LND_IAU_Control%iau_inc_files(k)) .eq. '' .or. LND_IAU_Control%iaufhrs(k) .lt. 0) exit + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print *,k,trim(adjustl(LND_IAU_Control%iau_inc_files(k))) + endif + nfiles = nfiles + 1 + enddo + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'nfiles = ',nfiles + if (nfiles < 1) then + return + endif + if (nfiles > 1) then + allocate(idt(nfiles-1)) + idt = LND_IAU_Control%iaufhrs(2:nfiles)-LND_IAU_Control%iaufhrs(1:nfiles-1) + do k=1,nfiles-1 + if (idt(k) .ne. LND_IAU_Control%iaufhrs(2)-LND_IAU_Control%iaufhrs(1)) then + print *,'in lnd_iau_init: forecast intervals in iaufhrs must be constant' + ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') + errmsg = 'Fatal error in lnd_iau_init. forecast intervals in iaufhrs must be constant' + errflg = 1 + return + endif + enddo + deallocate(idt) + endif + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'lnd_iau interval = ',LND_IAU_Control%iau_delthrs,' hours' + dt = (LND_IAU_Control%iau_delthrs*3600.) + rdt = 1.0/dt + +! set up interpolation weights to go from GSI's gaussian grid to cubed sphere + deg2rad = pi/180. + + ! npz = LND_IAU_Control%levs + fname = 'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)) + inquire (file=trim(fname), exist=exists) + if (exists) then + ! if( file_exist(fname) ) then + call open_ncfile( fname, ncid ) ! open the file +!TODO !change to Latitude + call get_ncdim1( ncid, 'longitude', im) + call get_ncdim1( ncid, 'latitude', jm) + ! call get_ncdim1( ncid, 'nsoill', km) + km = n_soill + ! if (km.ne.npz) then + ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *, 'km = ', km + ! ! call mpp_error(FATAL, '==> Error in IAU_initialize: km is not equal to npz') + ! errmsg = 'Fatal Error in IAU_initialize: km is not equal to npz' + ! errflg = 1 + ! return + ! endif + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) write(*,*) fname, ' DA increment dimensions:', im,jm,km + + allocate ( lon(im) ) + allocate ( lat(jm) ) + + call _GET_VAR1 (ncid, 'longitude', im, lon ) + call _GET_VAR1 (ncid, 'latitude', jm, lat ) + call close_ncfile(ncid) + + ! Convert to radians + do i=1,im + lon(i) = lon(i) * deg2rad + enddo + do j=1,jm + lat(j) = lat(j) * deg2rad + enddo + else + ! call mpp_error(FATAL,'==> Error in IAU_initialize: Expected file '& + ! //trim(fname)//' for DA increment does not exist') + errmsg = 'FATAL Error in IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' + errflg = 1 + return + endif + + ! Initialize lat-lon to Cubed bi-linear interpolation coeff: + ! populate agrid +! print*,'is,ie,js,je=',is,ie,js,ie +! print*,'size xlon=',size(Init_parm%xlon(:,1)),size(Init_parm%xlon(1,:)) +! print*,'size agrid=',size(agrid(:,1,1)),size(agrid(1,:,1)),size(agrid(1,1,:)) + do j = 1,size(Init_parm_xlon,2) + do i = 1,size(Init_parm_xlon,1) +! print*,i,j,is-1+j,js-1+j + agrid(is-1+i,js-1+j,1)=Init_parm_xlon(i,j) + agrid(is-1+i,js-1+j,2)=Init_parm_xlat(i,j) + enddo + enddo + call remap_coef( is, ie, js, je, is, ie, js, je, & + im, jm, lon, lat, id1, id2, jdc, s2c, & + agrid) + deallocate ( lon, lat,agrid ) + if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) + if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) + + ! allocate(LND_IAU_Data%ua_inc(is:ie, js:je, km)) + ! allocate(LND_IAU_Data%va_inc(is:ie, js:je, km)) + ! allocate(LND_IAU_Data%temp_inc(is:ie, js:je, km)) + ! allocate(LND_IAU_Data%delp_inc(is:ie, js:je, km)) + ! allocate(LND_IAU_Data%delz_inc(is:ie, js:je, km)) + ! allocate(LND_IAU_Data%tracer_inc(is:ie, js:je, km,ntracers)) + allocate(LND_IAU_Data%stc_inc(is:ie, js:je, km)) + allocate(LND_IAU_Data%slc_inc(is:ie, js:je, km)) + allocate(LND_IAU_Data%tmp2m_inc(is:ie, js:je, 1)) + allocate(LND_IAU_Data%spfh2m_inc(is:ie, js:je, 1)) +! allocate arrays that will hold iau state + allocate (iau_state%inc1%stc_inc(is:ie, js:je, km)) + allocate (iau_state%inc1%slc_inc(is:ie, js:je, km)) + allocate (iau_state%inc1%tmp2m_inc(is:ie, js:je, 1)) + allocate (iau_state%inc1%spfh2m_inc (is:ie, js:je, 1)) + iau_state%hr1=LND_IAU_Control%iaufhrs(1) + iau_state%wt = 1.0 ! IAU increment filter weights (default 1.0) + iau_state%wt_normfact = 1.0 + if (LND_IAU_Control%iau_filter_increments) then + ! compute increment filter weights, sum to obtain normalization factor + dtp=LND_IAU_Control%dtp + nstep = 0.5*LND_IAU_Control%iau_delthrs*3600/dtp + ! compute normalization factor for filter weights + normfact = 0. + do k=1,2*nstep+1 + kstep = k-1-nstep + sx = acos(-1.)*kstep/nstep + wx = acos(-1.)*kstep/(nstep+1) + if (kstep .ne. 0) then + wt = sin(wx)/wx*sin(sx)/sx + else + wt = 1.0 + endif + normfact = normfact + wt + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt + enddo + iau_state%wt_normfact = (2*nstep+1)/normfact + endif + ! if (do_lnd_iau_inc) then + ! call read_iau_forcing(LND_IAU_Control,iau_state%inc1,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)), errmsg, errflg, & + ! 'INPUT/'//trim(LND_IAU_Control%iau_inc_files_sfc(1))) + ! else + call read_iau_forcing(LND_IAU_Control,iau_state%inc1,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)), errmsg, errflg) + ! endif + if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window + call setiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) + endif + if (nfiles.GT.1) then !have multiple files, but only read in 2 at a time and interpoalte between them + allocate (iau_state%inc2%stc_inc(is:ie, js:je, km)) + allocate (iau_state%inc2%slc_inc(is:ie, js:je, km)) + allocate (iau_state%inc2%tmp2m_inc(is:ie, js:je, 1)) + allocate (iau_state%inc2%spfh2m_inc(is:ie, js:je, 1)) + iau_state%hr2=LND_IAU_Control%iaufhrs(2) + ! if (do_lnd_iau_inc) then + ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(2)),errmsg,errflg, & + ! 'INPUT/'//trim(LND_IAU_Control%iau_inc_files_sfc(2))) + ! else + call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(2)), errmsg, errflg) + ! endif + endif +! print*,'in IAU init',dt,rdt +! LND_IAU_Data%drymassfixer = LND_IAU_Control%iau_drymassfixer + +end subroutine lnd_iau_mod_init + +subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control,LND_IAU_Data, errmsg, errflg) + + implicit none + ! integer, intent(in) :: me, mpi_root + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys) t1,t2,sx,wx,wt,dtp + integer n,i,j,k,sphum,kstep,nstep,itnext + + LND_IAU_Data%in_interval=.false. + if (nfiles.LE.0) then + return + endif + + if (nfiles .eq. 1) then + t1 = LND_IAU_Control%iaufhrs(1)-0.5*LND_IAU_Control%iau_delthrs + t2 = LND_IAU_Control%iaufhrs(1)+0.5*LND_IAU_Control%iau_delthrs + else + t1 = LND_IAU_Control%iaufhrs(1) + t2 = LND_IAU_Control%iaufhrs(nfiles) + endif + if (LND_IAU_Control%iau_filter_increments) then + ! compute increment filter weight + ! t1 is beginning of window, t2 end of window + ! LND_IAU_Control%fhour current time + ! in window kstep=-nstep,nstep (2*nstep+1 total) + ! time step LND_IAU_Control%dtp + dtp=LND_IAU_Control%dtp + nstep = 0.5*LND_IAU_Control%iau_delthrs*3600/dtp + ! compute normalized filter weight + kstep = ((LND_IAU_Control%fhour-t1) - 0.5*LND_IAU_Control%iau_delthrs)*3600./dtp + if (LND_IAU_Control%fhour >= t1 .and. LND_IAU_Control%fhour < t2) then + sx = acos(-1.)*kstep/nstep + wx = acos(-1.)*kstep/(nstep+1) + if (kstep .ne. 0) then + wt = (sin(wx)/wx*sin(sx)/sx) + else + wt = 1. + endif + iau_state%wt = iau_state%wt_normfact*wt + !if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact + else + iau_state%wt = 0. + endif + endif + + if (nfiles.EQ.1) then +! on check to see if we are in the IAU window, no need to update the +! tendencies since they are fixed over the window + if ( LND_IAU_Control%fhour < t1 .or. LND_IAU_Control%fhour >= t2 ) then +! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'no iau forcing',t1,LND_IAU_Control%fhour,t2 + LND_IAU_Data%in_interval=.false. + else + if (LND_IAU_Control%iau_filter_increments) call setiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt=',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact + LND_IAU_Data%in_interval=.true. + endif + return + endif + + if (nfiles > 1) then + itnext=2 + if (LND_IAU_Control%fhour < t1 .or. LND_IAU_Control%fhour >= t2) then +! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'no iau forcing',LND_IAU_Control%iaufhrs(1),LND_IAU_Control%fhour,LND_IAU_Control%iaufhrs(nfiles) + LND_IAU_Data%in_interval=.false. + else + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt=',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact + LND_IAU_Data%in_interval=.true. + do k=nfiles,1,-1 + if (LND_IAU_Control%iaufhrs(k) > LND_IAU_Control%fhour) then + itnext=k + endif + enddo +! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'itnext=',itnext + if (LND_IAU_Control%fhour >= iau_state%hr2) then ! need to read in next increment file + iau_state%hr1=iau_state%hr2 + iau_state%hr2=LND_IAU_Control%iaufhrs(itnext) + iau_state%inc1=iau_state%inc2 + ! if (do_lnd_iau_inc) then + ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'reading next increment files',trim(LND_IAU_Control%iau_inc_files(itnext)), & + ! trim(LND_IAU_Control%iau_inc_files_sfc(itnext)) + ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(itnext)), errmsg, errflg, & + ! 'INPUT/'//trim(LND_IAU_Control%iau_inc_files_sfc(itnext))) + ! else + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(LND_IAU_Control%iau_inc_files(itnext)) + call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(itnext)), errmsg, errflg) + ! endif + endif + call updateiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) + endif + endif + ! sphum=get_tracer_index(MODEL_ATMOS,'sphum') + + end subroutine lnd_iau_mod_getiauforcing + +subroutine updateiauforcing(LND_IAU_Control,LND_IAU_Data,wt) + + implicit none + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + real(kind_phys) delt,wt + integer i,j,k,l + +! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'in updateiauforcing',nfiles,LND_IAU_Control%iaufhrs(1:nfiles) + delt = (iau_state%hr2-(LND_IAU_Control%fhour))/(IAU_state%hr2-IAU_state%hr1) + do j = js,je + do i = is,ie + do k = 1,npz + ! LND_IAU_Data%ua_inc(i,j,k) =(delt*IAU_state%inc1%ua_inc(i,j,k) + (1.-delt)* IAU_state%inc2%ua_inc(i,j,k))*rdt*wt + ! LND_IAU_Data%va_inc(i,j,k) =(delt*IAU_state%inc1%va_inc(i,j,k) + (1.-delt)* IAU_state%inc2%va_inc(i,j,k))*rdt*wt + ! LND_IAU_Data%temp_inc(i,j,k) =(delt*IAU_state%inc1%temp_inc(i,j,k) + (1.-delt)* IAU_state%inc2%temp_inc(i,j,k))*rdt*wt + ! LND_IAU_Data%delp_inc(i,j,k) =(delt*IAU_state%inc1%delp_inc(i,j,k) + (1.-delt)* IAU_state%inc2%delp_inc(i,j,k))*rdt*wt + ! LND_IAU_Data%delz_inc(i,j,k) =(delt*IAU_state%inc1%delz_inc(i,j,k) + (1.-delt)* IAU_state%inc2%delz_inc(i,j,k))*rdt*wt + ! do l=1,ntracers + ! LND_IAU_Data%tracer_inc(i,j,k,l) =(delt*IAU_state%inc1%tracer_inc(i,j,k,l) + (1.-delt)* IAU_state%inc2%tracer_inc(i,j,k,l))*rdt*wt + ! enddo + ! enddo + ! do k = 1,n_soill ! + LND_IAU_Data%stc_inc(i,j,k) =(delt*IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* IAU_state%inc2%stc_inc(i,j,k))*rdt*wt + LND_IAU_Data%slc_inc(i,j,k) =(delt*IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* IAU_state%inc2%slc_inc(i,j,k))*rdt*wt + end do + LND_IAU_Data%tmp2m_inc(i,j,1) =(delt*IAU_state%inc1%tmp2m_inc(i,j,1) + (1.-delt)* IAU_state%inc2%tmp2m_inc(i,j,1))*rdt*wt + LND_IAU_Data%spfh2m_inc(i,j,1) =(delt*IAU_state%inc1%spfh2m_inc(i,j,1) + (1.-delt)* IAU_state%inc2%spfh2m_inc(i,j,1))*rdt*wt + enddo + enddo + end subroutine updateiauforcing + + + subroutine setiauforcing(LND_IAU_Control,LND_IAU_Data,wt) + + implicit none + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + real(kind_phys) delt, dt,wt + integer i,j,k,l,sphum +! this is only called if using 1 increment file + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'in lnd_iau setiauforcing',rdt + do j = js,je + do i = is,ie + do k = 1,npz + ! LND_IAU_Data%ua_inc(i,j,k) =wt*IAU_state%inc1%ua_inc(i,j,k)*rdt + ! LND_IAU_Data%va_inc(i,j,k) =wt*IAU_state%inc1%va_inc(i,j,k)*rdt + ! LND_IAU_Data%temp_inc(i,j,k) =wt*IAU_state%inc1%temp_inc(i,j,k)*rdt + ! LND_IAU_Data%delp_inc(i,j,k) =wt*IAU_state%inc1%delp_inc(i,j,k)*rdt + ! LND_IAU_Data%delz_inc(i,j,k) =wt*IAU_state%inc1%delz_inc(i,j,k)*rdt + ! do l = 1,ntracers + ! LND_IAU_Data%tracer_inc(i,j,k,l) =wt*IAU_state%inc1%tracer_inc(i,j,k,l)*rdt + ! enddo + ! enddo + ! do k = 1,n_soill ! + LND_IAU_Data%stc_inc(i,j,k) = wt*IAU_state%inc1%stc_inc(i,j,k)*rdt + LND_IAU_Data%slc_inc(i,j,k) = wt*IAU_state%inc1%slc_inc(i,j,k)*rdt + end do + LND_IAU_Data%tmp2m_inc(i,j,1) = wt*IAU_state%inc1%tmp2m_inc(i,j,1)*rdt + LND_IAU_Data%spfh2m_inc(i,j,1) = wt*IAU_state%inc1%spfh2m_inc(i,j,1)*rdt + enddo + enddo +! sphum=get_tracer_index(MODEL_ATMOS,'sphum') + + end subroutine setiauforcing + +subroutine read_iau_forcing(LND_IAU_Control, increments, fname, errmsg, errflg) !, fname_sfc) + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type(iau_internal_data_type), intent(inout):: increments + character(len=*), intent(in) :: fname + ! character(len=*), intent(in), optional :: fname_sfc + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +!locals + ! real, dimension(:,:,:), allocatable:: u_inc, v_inc + + integer:: i, j, k, l, npz + integer:: i1, i2, j1 + integer:: jbeg, jend + ! real(kind=R_GRID), dimension(2):: p1, p2, p3 + ! real(kind=R_GRID), dimension(3):: e1, e2, ex, ey + + ! logical :: found + integer :: is, ie, js, je, km_store + logical :: exists + + !Errors messages handled through CCPP error handling variables + errmsg = '' + errflg = 0 + + is = LND_IAU_Control%isc + ie = is + LND_IAU_Control%nx-1 + js = LND_IAU_Control%jsc + je = js + LND_IAU_Control%ny-1 + + deg2rad = pi/180. + + npz = LND_IAU_Control%lsoil + + inquire (file=trim(fname), exist=exists) + if (exists) then + ! if( file_exist(fname) ) then + call open_ncfile( fname, ncid ) ! open the file + else + ! call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '& + ! //trim(fname)//' for DA increment does not exist') + errmsg = 'FATAL Error in read_iau_forcing: Expected file '//trim(fname)//' for DA increment does not exist' + errflg = 1 + return + endif + + ! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je + do i=is,ie + j1 = jdc(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + ! allocate ( wk3(1:im,jbeg:jend, 1:km) ) + ! read in 1 time level +! call interp_inc(LND_IAU_Control, 'T_inc',increments%temp_inc(:,:,:),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'delp_inc',increments%delp_inc(:,:,:),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'delz_inc',increments%delz_inc(:,:,:),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'u_inc',increments%ua_inc(:,:,:),jbeg,jend) ! can these be treated as scalars? +! call interp_inc(LND_IAU_Control, 'v_inc',increments%va_inc(:,:,:),jbeg,jend) +! ! do l=1,ntracers +! ! call interp_inc(trim(tracer_names(l))//'_inc',increments%tracer_inc(:,:,:,l),jbeg,jend) +! ! enddo +! call close_ncfile(ncid) +! deallocate (wk3) + +! ! is_land = .true. +! if ( present(fname_sfc) ) then +! inquire (file=trim(fname_sfc), exist=exists) +! if (exists) then +! ! if( file_exist(fname_sfc) ) then +! call open_ncfile( fname_sfc, ncid ) ! open the file +! else +! ! call mpp_error(FATAL,'==> Error in read_iau_forcing sfc: Expected file '& +! ! //trim(fname_sfc)//' for DA increment does not exist') +! errmsg = 'FATAL Error in read_iau_forcing sfc: Expected file '//trim(fname_sfc)//' for DA increment does not exist' +! errflg = 1 +! return +! endif + km_store = km + km = 1 ! n_soill Currently each soil layer increment is saved separately + allocate ( wk3(1:im,jbeg:jend, 1:km) ) + ! call interp_inc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend) !TODO check var name + call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) + call interp_inc(LND_IAU_Control, 'soilt2_inc',increments%stc_inc(:,:,2),jbeg,jend) + call interp_inc(LND_IAU_Control, 'soilt3_inc',increments%stc_inc(:,:,3),jbeg,jend) + call interp_inc(LND_IAU_Control, 'soilt4_inc',increments%stc_inc(:,:,4),jbeg,jend) + + call interp_inc(LND_IAU_Control, 'slc1_inc',increments%slc_inc(:,:,1),jbeg,jend) + call interp_inc(LND_IAU_Control, 'slc2_inc',increments%slc_inc(:,:,2),jbeg,jend) + call interp_inc(LND_IAU_Control, 'slc3_inc',increments%slc_inc(:,:,3),jbeg,jend) + call interp_inc(LND_IAU_Control, 'slc4_inc',increments%slc_inc(:,:,4),jbeg,jend) + + call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) + call interp_inc(LND_IAU_Control, 'spfh2m_inc',increments%spfh2m_inc(:,:,1),jbeg,jend) + ! call interp_inc_sfc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend, n_soill) + call close_ncfile(ncid) + deallocate (wk3) + km = km_store + ! else + ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'No IAU inc file for sfc, setting stc_inc=0.' + ! increments%stc_inc(:,:,:) = 0. + ! end if + +end subroutine read_iau_forcing + +subroutine interp_inc(LND_IAU_Control, field_name,var,jbeg,jend) +! interpolate increment from GSI gaussian grid to cubed sphere +! everying is on the A-grid, earth relative + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + character(len=*), intent(in) :: field_name + real, dimension(is:ie,js:je,1:km), intent(inout) :: var + integer, intent(in) :: jbeg,jend + integer:: i1, i2, j1, k,j,i,ierr + call check_var_exists(ncid, field_name, ierr) + if (ierr == 0) then + call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) + else + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(field_name),' found, assuming zero' + wk3 = 0. + endif + do k=1,km + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + var(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+& + s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) + enddo + enddo + enddo +end subroutine interp_inc + +!> This routine is copied from 'fv_treat_da_inc.F90 by Xi.Chen +! copying it here, due to inability to 'include' from the original module when the land iau mod is called through CCPP frameowrk +! +!> @author Xi.Chen +!> @date 02/12/2016 +! +! REVISION HISTORY: +! 02/12/2016 - Initial Version + !============================================================================= + !>@brief The subroutine 'remap_coef' calculates the coefficients for horizonal regridding. + + subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & + im, jm, lon, lat, id1, id2, jdc, s2c, agrid ) + + integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed + integer, intent(in):: im, jm + real(kind=kind_dyn), intent(in):: lon(im), lat(jm) + real, intent(out):: s2c(is:ie,js:je,4) + integer, intent(out), dimension(is:ie,js:je):: id1, id2, jdc + real(kind=kind_dyn), intent(in):: agrid(isd:ied,jsd:jed,2) + ! local: + real :: rdlon(im) + real :: rdlat(jm) + real:: a1, b1 + integer i,j, i1, i2, jc, i0, j0 + do i=1,im-1 + rdlon(i) = 1. / (lon(i+1) - lon(i)) + enddo + rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) + + do j=1,jm-1 + rdlat(j) = 1. / (lat(j+1) - lat(j)) + enddo + + ! * Interpolate to cubed sphere cell center + do 5000 j=js,je + + do i=is,ie + + if ( agrid(i,j,1)>lon(im) ) then + i1 = im; i2 = 1 + a1 = (agrid(i,j,1)-lon(im)) * rdlon(im) + elseif ( agrid(i,j,1)=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then + i1 = i0; i2 = i0+1 + a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0) + go to 111 + endif + enddo + endif +111 continue + + if ( agrid(i,j,2)lat(jm) ) then + jc = jm-1 + b1 = 1. + else + do j0=1,jm-1 + if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then + jc = j0 + b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc) + go to 222 + endif + enddo + endif +222 continue + + if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then +!TODO uncomment and fix mpp_pe write(*,*) 'gid=', mpp_pe(), i,j,a1, b1 + endif + + s2c(i,j,1) = (1.-a1) * (1.-b1) + s2c(i,j,2) = a1 * (1.-b1) + s2c(i,j,3) = a1 * b1 + s2c(i,j,4) = (1.-a1) * b1 + id1(i,j) = i1 + id2(i,j) = i2 + jdc(i,j) = jc + enddo !i-loop +5000 continue ! j-loop + + end subroutine remap_coef + +! subroutine interp_inc_sfc(LND_IAU_Control, field_name,var,jbeg,jend, k_lv) !is_land_in) +! ! interpolate increment from GSI gaussian grid to cubed sphere +! ! everying is on the A-grid, earth relative +! type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control +! character(len=*), intent(in) :: field_name +! integer, intent(in) :: jbeg, jend, k_lv +! real, dimension(is:ie,js:je,1:k_lv), intent(inout) :: var +! ! logical, intent(in), optional :: is_land_in +! ! logical :: is_land +! integer:: i1, i2, j1, k,j,i,ierr +! ! k_lv = km +! ! is_land = .false. +! ! if ( present(is_land_in) ) is_land = is_land_in +! ! if (is_land) k_lv = n_soill +! call check_var_exists(ncid, field_name, ierr) +! if (ierr == 0) then +! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,k_lv, wk3 ) !k, wk3 ) +! else +! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(field_name),' found, assuming zero' +! wk3 = 0. +! endif + +! do k=1,k_lv !km +! do j=js,je +! do i=is,ie +! i1 = id1(i,j) +! i2 = id2(i,j) +! j1 = jdc(i,j) +! var(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+& +! s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) +! enddo +! enddo +! enddo + +! end subroutine interp_inc_sfc + +end module lnd_iau_mod + + diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 6aff50666..a780eb745 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -12,6 +12,9 @@ module noahmpdrv use module_sf_noahmplsm + ! 3.5.24 for use in IAU + use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& + lnd_iau_mod_set_control, lnd_iau_mod_init,lnd_iau_mod_getiauforcing implicit none @@ -20,6 +23,10 @@ module noahmpdrv private public :: noahmpdrv_init, noahmpdrv_run + + ! IAU data and control + type (lnd_iau_control_type) :: LND_IAU_Control + type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks contains @@ -29,29 +36,46 @@ module noahmpdrv !! \section arg_table_noahmpdrv_init Argument Table !! \htmlinclude noahmpdrv_init.html !! - subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & - nlunit, pores, resid, & - do_mynnsfclay,do_mynnedmf, & - errmsg, errflg) + subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & + isot, ivegsrc, & + nlunit, pores, resid, & + do_mynnsfclay,do_mynnedmf, & + errmsg, errflg, & + mpi_root, & + fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, nblks, & + blksz, xlon, xlat, & + lsoil, lsnow_lsm, dtp, fhour) use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg use namelist_soilveg use noahmp_tables + !use GFS_typedefs, only: GFS_control_type + ! use GFS_typedefs, only: GFS_data_type implicit none + integer, intent(in) :: lsm integer, intent(in) :: lsm_noahmp - integer, intent(in) :: me, isot, ivegsrc, nlunit - + integer, intent(in) :: me ! mpi_rank + integer, intent(in) :: isot, ivegsrc, nlunit real (kind=kind_phys), dimension(:), intent(out) :: pores, resid - logical, intent(in) :: do_mynnsfclay logical, intent(in) :: do_mynnedmf - - character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + ! land iau mod + integer, intent(in) :: mpi_root ! = GFS_Control%master + character(*), intent(in) :: fn_nml + character(len=:), intent(in), dimension(:), pointer :: input_nml_file + integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks + integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + integer, intent(in) :: lsoil, lsnow_lsm + real(kind=kind_phys), intent(in) :: dtp, fhour + ! type(gfs_data_type), dimension(:), intent(inout) :: GFS_Data ! !(one:) + !type(gfs_control_type), intent(in) :: GFS_Control ! Initialize CCPP error handling variables errmsg = '' @@ -85,7 +109,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & return end if - !--- initialize soil vegetation call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) @@ -101,6 +124,18 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & pores (:) = maxsmc (:) resid (:) = drysmc (:) + ! 3.7.24 init iau for land + call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & + lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) +! print*, 'proc errmsg, errflg after set control', me, errmsg, errflg +! print*, 'proc iau_control isc, nx, dtp fhour', me, LND_IAU_Control%isc, LND_IAU_Control%nx, & +! LND_IAU_Control%dtp, LND_IAU_Control%fhour +! print*, 'proc iau_control incfiles(1)', me, LND_IAU_Control%iau_inc_files(1) +! stop + call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) + !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval + print*, 'proc nblks blksize(1) after set init', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) + end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM @@ -127,7 +162,7 @@ end subroutine noahmpdrv_init subroutine noahmpdrv_run & !................................... ! --- inputs: - ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp,soilcol,& + (nb, im, km, lsnowl, itime, fhour, ps, u1, v1, t1, q1, soiltyp,soilcol,& vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp,& shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & @@ -136,7 +171,7 @@ subroutine noahmpdrv_run & iopt_trs,iopt_diag,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, rhonewsn1,& con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & - con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd, cpllnd2atm,& + con_fvirt, con_rd, con_hfus, thsfc_loc, & ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & @@ -229,10 +264,12 @@ subroutine noahmpdrv_run & ! --- CCPP interface fields (in call order) ! + integer , intent(in) :: nb !=cdata%blk_no, integer , intent(in) :: im ! horiz dimension and num of used pts integer , intent(in) :: km ! vertical soil layer dimension integer , intent(in) :: lsnowl ! lower bound for snow level arrays - integer , intent(in) :: itime ! NOT USED + integer , intent(in) :: itime ! NOT USED current forecast iteration + real(kind=kind_phys) , intent(in) :: fhour ! currentforecast time (hr) real(kind=kind_phys), dimension(:) , intent(in) :: ps ! surface pressure [Pa] real(kind=kind_phys), dimension(:) , intent(in) :: u1 ! u-component of wind [m/s] real(kind=kind_phys), dimension(:) , intent(in) :: v1 ! u-component of wind [m/s] @@ -310,9 +347,6 @@ subroutine noahmpdrv_run & logical , intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation - logical , intent(in) :: cpllnd ! Flag for land coupling (atm->lnd) - logical , intent(in) :: cpllnd2atm ! Flag for land coupling (lnd->atm) - real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! ground surface skin temperature [K] @@ -670,6 +704,13 @@ subroutine noahmpdrv_run & logical :: is_snowing ! used for penman calculation logical :: is_freeze_rain ! used for penman calculation integer :: i, k + + ! IAU update + real,allocatable :: stc_inc_flat(:,:) + real,allocatable :: slc_inc_flat(:,:) + real,allocatable :: tmp2m_inc_flat(:) + real,allocatable :: spfh2m_inc_flat(:) + integer :: j, ix, ib ! ! --- local derived constants: @@ -686,13 +727,62 @@ subroutine noahmpdrv_run & ! errmsg = '' errflg = 0 + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*,"nb ",nb," itime ",itime," GFScont%fhour ",fhour," iauCon%fhour",LND_IAU_Control%fhour," delt ",delt," iauCont%dtp",LND_IAU_Control%dtp + endif + ! 3.7.24 read iau increments + call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) + if (errflg .ne. 0) return + ! update with iau increments + if (LND_IAU_Data%in_interval) then + if (LND_IAU_Control%lsoil .ne. km) then + write(errmsg, *)'in noahmpdrv_run, lnd_iau_mod update increments:LND_IAU_Control%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km + errflg = 1 + return + endif + ! LND_IAU_Data%stc_inc(is:ie, js:je, km)) size of (nx, ny) + ! xlatin(im) stc(im,km) slc() t2mmp(:) q2mp(im) km=n_soill, im = + ! GFS_Control%blksz(cdata%blk_no) + ! >> need to get (cdata%blk_no from function call + + ! local variable to copy blocked data LND_IAU_Data%stc_inc + allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ib = 1 + do j = 1, LND_IAU_Control%ny !ny + do k = 1, km + stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%stc_inc(:,j,k) + slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j,k) + enddo + ! ib = 1 + ! do j = 1, LND_IAU_Control%ny !ny + tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%tmp2m_inc(:,j,1) + spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%spfh2m_inc(:,j,1) + ib = ib + LND_IAU_Control%nx !nlon + enddo + + !IAU increments are in units of 1/sec !LND_IAU_Control%dtp + ! delt=GFS_Control%dtf + if ((LND_IAU_Control%dtp - delt) > 0.0001) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "Warning time step used in noahmpdrv_run delt ",delt," different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp + endif + endif + do k = 1, km + stc(:,k)=stc(:,k)+stc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp + slc(:,k)=slc(:,k)+slc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp + enddo + t2mmp = t2mmp+tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp + q2mp = q2mp +spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp + + deallocate(stc_inc_flat, slc_inc_flat, tmp2m_inc_flat, spfh2m_inc_flat) + + end if -! -! --- Just return if external land component is activated for two-way interaction -! - if (cpllnd .and. cpllnd2atm) return - do i = 1, im +do i = 1, im if (flag_iter(i) .and. dry(i)) then diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 39eed1493..8a8093dd3 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -1,9 +1,8 @@ [ccpp-table-properties] name = noahmpdrv type = scheme - dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F - dependencies = module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90 - dependencies = ../Noah/set_soilveg.f + dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90,set_soilveg.f + dependencies = sim_nc_mod_lnd.F90,lnd_iau_mod.F90 ######################################################################## [ccpp-arg-table] @@ -96,11 +95,136 @@ dimensions = () type = integer intent = out +[mpi_root] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[fn_nml] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + type = character + dimensions = () + kind = len=* + intent = in +[input_nml_file] + standard_name = filename_of_internal_namelist + long_name = amelist filename for internal file reads + units = none + type = character + dimensions = (ccpp_constant_one:number_of_lines_in_internal_namelist) + kind = len=256 + intent = in +[isc] + standard_name = starting_x_index_for_this_mpi_rank + long_name = starting index in the x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[jsc] + standard_name = starting_y_index_for_this_mpi_rank + long_name = starting index in the y direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[ncols] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nx] + standard_name = number_of_points_in_x_direction_for_this_mpi_rank + long_name = number of points in x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[ny] + standard_name = number_of_points_in_y_direction_for_this_mpi_rank + long_name = number of points in y direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[nblks] + standard_name = ccpp_block_count + long_name = for explicit data blocking: number of blocks + units = count + dimensions = () + type = integer + intent = in +[blksz] + standard_name = ccpp_block_sizes + long_name = for explicit data blocking: block sizes of all blocks + units = count + dimensions = (ccpp_constant_one:ccpp_block_count) + type = integer + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[lsoil] + standard_name = vertical_dimension_of_soil + long_name = number of soil layers + units = count + dimensions = () + type = integer + intent = in +[lsnow_lsm] + standard_name = vertical_dimension_of_surface_snow + long_name = maximum number of snow layers for land surface model + units = count + dimensions = () + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in ######################################################################## [ccpp-arg-table] name = noahmpdrv_run type = scheme +[nb] + standard_name = ccpp_block_number + long_name = number of block for explicit data blocking in CCPP + units = index + dimensions = () + type = integer + intent = in [im] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -129,6 +253,14 @@ dimensions = () type = integer intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in [ps] standard_name = surface_air_pressure long_name = surface pressure @@ -635,20 +767,6 @@ dimensions = () type = logical intent = in -[cpllnd] - standard_name = flag_for_land_coupling - long_name = flag controlling cpllnd collection (default off) - units = flag - dimensions = () - type = logical - intent = in -[cpllnd2atm] - standard_name = flag_for_one_way_land_coupling_to_atmosphere - long_name = flag controlling land coupling to the atmosphere (default off) - units = flag - dimensions = () - type = logical - intent = in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land From bc810b4e0d68c4ba6b027ff7939cda3fd20bfd79 Mon Sep 17 00:00:00 2001 From: tsga Date: Sun, 17 Mar 2024 18:55:05 +0000 Subject: [PATCH 014/154] mv iau forcing read to noahmpdrv_timestep_init --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 212 +++++--- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 66 +++ .../SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 | 466 ++++++++++++++++++ 3 files changed, 679 insertions(+), 65 deletions(-) create mode 100644 physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index a780eb745..69228e926 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -22,7 +22,7 @@ module noahmpdrv private - public :: noahmpdrv_init, noahmpdrv_run + public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_timestep_init ! IAU data and control type (lnd_iau_control_type) :: LND_IAU_Control @@ -134,10 +134,153 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & ! stop call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval - print*, 'proc nblks blksize(1) after set init', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) + ! print*, 'proc nblks blksize(1) after set init', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) end subroutine noahmpdrv_init +!> \ingroup NoahMP_LSM +!! \brief This subroutine is called before noahmpdrv_run timestep to update +!! states with iau increments +!! \section arg_table_noahmpdrv_timestep_init Argument Table +!! \htmlinclude noahmpdrv_timestep_init.html +!! + subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, + stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, + ! lsnow_lsm, lsnowl, & + ! ncols, isc, jsc, nx, ny, nblks, + ! & + ! blksz, xlon, xlat, + ! & !& garea, iyrlen, julian, + ! vegtype, idveg, & + ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, + + use machine, only: kind_phys + + implicit none + + ! integer, intent(in) :: me !mpi_rank + ! integer, intent(in) :: mpi_root ! = GFS_Control%master + integer , intent(in) :: itime !current forecast iteration + real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) + real(kind=kind_phys) , intent(in) :: delt ! time interval [s] + integer , intent(in) :: km !vertical soil layer dimension + real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] + real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! integer, intent(in) :: lsnow_lsm + ! integer , intent(in) :: lsnowl ! lower bound for snow level arrays + ! integer, intent(in) :: ncols, isc, jsc, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks + ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + !integer , dimension(:) , intent(in) :: vegtype !vegetation type (integer index) + ! real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] + ! real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] + ! real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! + ! ground surface skin temperature [K] + ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! + ! total soil moisture content [m3/m3] + ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! + ! soil temp [K] + ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc ! + ! liquid soil moisture [m3/m3] + ! real(kind=kind_phys), dimension(:) , intent(out) :: t2mmp ! + ! combined T2m from tiles + ! real(kind=kind_phys), dimension(:) , intent(out) :: q2mp ! + ! combined q2m from tiles + ! character(len=*), intent(out) :: errmsg + ! integer, intent(out) :: errflg + + ! --- local variable + ! integer :: nb, im ! vertical soil layer dimension + + ! IAU update + real,allocatable :: stc_inc_flat(:,:) + real,allocatable :: slc_inc_flat(:,:) + ! real,allocatable :: tmp2m_inc_flat(:) + ! real,allocatable :: spfh2m_inc_flat(:) + integer :: j, k, ib + ! --- end declaration + + ! --- Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + !> update current forecast hour + ! GFS_control%jdat(:) = jdat(:) + LND_IAU_Control%fhour=fhour + + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & + " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp + endif + + !> 3.7.24 read iau increments + call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) + if (errflg .ne. 0) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" + print*, errmsg + endif + return + endif + + !> update with iau increments + if (LND_IAU_Data%in_interval) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "adding land iau increments " + endif + + if (LND_IAU_Control%lsoil .ne. km) then + write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km + errflg = 1 + return + endif + + ! local variable to copy blocked data LND_IAU_Data%stc_inc + allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ib = 1 + do j = 1, LND_IAU_Control%ny !ny + do k = 1, km + stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) + slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) + enddo + ! ib = 1 + ! do j = 1, LND_IAU_Control%ny !ny + ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) + ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) + + ib = ib + LND_IAU_Control%nx !nlon + enddo + + ! delt=GFS_Control%dtf + if ((LND_IAU_Control%dtp - delt) > 0.0001) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp + endif + endif + !IAU increments are in units of 1/sec !LND_IAU_Control%dtp + do k = 1, km + stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + enddo + ! t2mmp = t2mmp + & + ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp + ! q2mp = q2mp + & + ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp + + deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + + endif + + end subroutine noahmpdrv_timestep_init + + !> \ingroup NoahMP_LSM !! \brief This subroutine is the main CCPP entry point for the NoahMP LSM. !! \section arg_table_noahmpdrv_run Argument Table @@ -704,14 +847,7 @@ subroutine noahmpdrv_run & logical :: is_snowing ! used for penman calculation logical :: is_freeze_rain ! used for penman calculation integer :: i, k - - ! IAU update - real,allocatable :: stc_inc_flat(:,:) - real,allocatable :: slc_inc_flat(:,:) - real,allocatable :: tmp2m_inc_flat(:) - real,allocatable :: spfh2m_inc_flat(:) - integer :: j, ix, ib - + ! ! --- local derived constants: ! @@ -727,62 +863,8 @@ subroutine noahmpdrv_run & ! errmsg = '' errflg = 0 - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*,"nb ",nb," itime ",itime," GFScont%fhour ",fhour," iauCon%fhour",LND_IAU_Control%fhour," delt ",delt," iauCont%dtp",LND_IAU_Control%dtp - endif - ! 3.7.24 read iau increments - call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) - if (errflg .ne. 0) return - ! update with iau increments - if (LND_IAU_Data%in_interval) then - if (LND_IAU_Control%lsoil .ne. km) then - write(errmsg, *)'in noahmpdrv_run, lnd_iau_mod update increments:LND_IAU_Control%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km - errflg = 1 - return - endif - ! LND_IAU_Data%stc_inc(is:ie, js:je, km)) size of (nx, ny) - ! xlatin(im) stc(im,km) slc() t2mmp(:) q2mp(im) km=n_soill, im = - ! GFS_Control%blksz(cdata%blk_no) - ! >> need to get (cdata%blk_no from function call - - ! local variable to copy blocked data LND_IAU_Data%stc_inc - allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols - allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols - ib = 1 - do j = 1, LND_IAU_Control%ny !ny - do k = 1, km - stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%stc_inc(:,j,k) - slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j,k) - enddo - ! ib = 1 - ! do j = 1, LND_IAU_Control%ny !ny - tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%tmp2m_inc(:,j,1) - spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%spfh2m_inc(:,j,1) - ib = ib + LND_IAU_Control%nx !nlon - enddo - - !IAU increments are in units of 1/sec !LND_IAU_Control%dtp - ! delt=GFS_Control%dtf - if ((LND_IAU_Control%dtp - delt) > 0.0001) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "Warning time step used in noahmpdrv_run delt ",delt," different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp - endif - endif - do k = 1, km - stc(:,k)=stc(:,k)+stc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp - slc(:,k)=slc(:,k)+slc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp - enddo - t2mmp = t2mmp+tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp - q2mp = q2mp +spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp - - deallocate(stc_inc_flat, slc_inc_flat, tmp2m_inc_flat, spfh2m_inc_flat) - - end if - -do i = 1, im + do i = 1, im if (flag_iter(i) .and. dry(i)) then diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 8a8093dd3..2f037467f 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -214,6 +214,72 @@ kind = kind_phys intent = in +######################################################################## +[ccpp-arg-table] + name = noahmpdrv_timestep_init + type = scheme +[itime] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[delt] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[km] + standard_name = vertical_dimension_of_soil + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[slc] + standard_name = volume_fraction_of_unfrozen_water_in_soil + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + ######################################################################## [ccpp-arg-table] name = noahmpdrv_run diff --git a/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 b/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 new file mode 100644 index 000000000..9dcb096ef --- /dev/null +++ b/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 @@ -0,0 +1,466 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +!>@brief The module 'sim_nc' is a netcdf file reader. +!>@details The code is necessary to circumvent issues with the FMS +!! 'read_data' utility, which opens too many files and uses excessive +!! memory. +!>@author Shian-Jiann Lin + +module sim_nc_mod_lnd + +! This is S-J Lin's private netcdf file reader +! This code is needed because FMS utility (read_data) led to too much +! memory usage and too many files openned. Perhaps lower-level FMS IO +! calls should be used instead. + +#if defined(OLD_PT_TO_T) || defined(OLD_COS_SG) +#error +#error Compile time options -DOLD_PT_TO_T and -DOLD_COS_SG are no longer supported. Please remove them from your XML. +#error +#endif + +! use mpp_mod, only: mpp_error, FATAL + + implicit none +#include + + private + public open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_double, & + get_var3_real, get_var3_double, get_var3_r4, get_var2_real, get_var2_r4, & + handle_err, check_var, get_var1_real, get_var_att_double, & + check_var_exists + + contains + + subroutine open_ncfile( iflnm, ncid ) + character(len=*), intent(in):: iflnm + integer, intent(out):: ncid + integer:: status + + status = nf_open (iflnm, NF_NOWRITE, ncid) + if (status .ne. NF_NOERR) call handle_err('nf_open',status) + + + end subroutine open_ncfile + + + subroutine close_ncfile( ncid ) + integer, intent(in):: ncid + integer:: status + + status = nf_close (ncid) + if (status .ne. NF_NOERR) call handle_err('nf_close',status) + + + end subroutine close_ncfile + + + subroutine get_ncdim1( ncid, var1_name, im ) + integer, intent(in):: ncid + character(len=*), intent(in):: var1_name + integer, intent(out):: im + integer:: status, var1id + + status = nf_inq_dimid (ncid, var1_name, var1id) + if (status .ne. NF_NOERR) call handle_err('dimid '//var1_name,status) + + status = nf_inq_dimlen (ncid, var1id, im) + if (status .ne. NF_NOERR) call handle_err('dimid '//var1_name,status) + + end subroutine get_ncdim1 + +!>@brief The 'get_var' subroutines read in variables from netcdf files + subroutine get_var1_double( ncid, var1_name, im, var1, var_exist ) + integer, intent(in):: ncid + character(len=*), intent(in):: var1_name + integer, intent(in):: im + logical, intent(out), optional:: var_exist + real(kind=8), intent(out):: var1(im) + integer:: status, var1id + + status = nf_inq_varid (ncid, var1_name, var1id) + if (status .ne. NF_NOERR) then +! call handle_err('varid '//var1_name,status) + if(present(var_exist) ) var_exist = .false. + else + status = nf_get_var_double (ncid, var1id, var1) + if (status .ne. NF_NOERR) call handle_err('varid '//var1_name,status) + if(present(var_exist) ) var_exist = .true. + endif + + + end subroutine get_var1_double + + +! 4-byte data: + subroutine get_var1_real( ncid, var1_name, im, var1, var_exist ) + integer, intent(in):: ncid + character(len=*), intent(in):: var1_name + integer, intent(in):: im + logical, intent(out), optional:: var_exist + real(kind=4), intent(out):: var1(im) + integer:: status, var1id + + status = nf_inq_varid (ncid, var1_name, var1id) + if (status .ne. NF_NOERR) then +! call handle_err(status) + if(present(var_exist) ) var_exist = .false. + else + status = nf_get_var_real (ncid, var1id, var1) + if (status .ne. NF_NOERR) call handle_err('get_var1_real1 '//var1_name,status) + if(present(var_exist) ) var_exist = .true. + endif + + + end subroutine get_var1_real + + subroutine get_var2_real( ncid, var_name, im, jm, var2 ) + integer, intent(in):: ncid + character(len=*), intent(in):: var_name + integer, intent(in):: im, jm + real(kind=4), intent(out):: var2(im) + + integer:: status, var1id + + status = nf_inq_varid (ncid, var_name, var1id) + if (status .ne. NF_NOERR) call handle_err('get_var2_real varid '//var_name,status) + + status = nf_get_var_real (ncid, var1id, var2) + if (status .ne. NF_NOERR) call handle_err('get_var2_real get_var'//var_name,status) + + end subroutine get_var2_real + + subroutine get_var2_r4( ncid, var2_name, is,ie, js,je, var2, time_slice ) + integer, intent(in):: ncid + character(len=*), intent(in):: var2_name + integer, intent(in):: is, ie, js, je + real(kind=4), intent(out):: var2(is:ie,js:je) + integer, intent(in), optional :: time_slice +! + real(kind=4), dimension(1) :: time + integer, dimension(3):: start, nreco + integer:: status, var2id + + status = nf_inq_varid (ncid, var2_name, var2id) + if (status .ne. NF_NOERR) call handle_err('get_var2_r4 varid'//var2_name,status) + + start(1) = is; start(2) = js; start(3) = 1 + if ( present(time_slice) ) then + start(3) = time_slice + end if + + nreco(1) = ie - is + 1 + nreco(2) = je - js + 1 + nreco(3) = 1 + + status = nf_get_vara_real(ncid, var2id, start, nreco, var2) + if (status .ne. NF_NOERR) call handle_err('get_var2_r4 get_vara_real'//var2_name,status) + + end subroutine get_var2_r4 + + subroutine get_var2_double( ncid, var2_name, im, jm, var2 ) + integer, intent(in):: ncid + character(len=*), intent(in):: var2_name + integer, intent(in):: im, jm + real(kind=8), intent(out):: var2(im,jm) + + integer:: status, var2id + + status = nf_inq_varid (ncid, var2_name, var2id) + if (status .ne. NF_NOERR) call handle_err('get_var2_double varid'//var2_name,status) + + status = nf_get_var_double (ncid, var2id, var2) + if (status .ne. NF_NOERR) call handle_err('get_var2_double get_var_double'//var2_name,status) + + + end subroutine get_var2_double + + + subroutine get_var3_double( ncid, var3_name, im, jm, km, var3 ) + integer, intent(in):: ncid + character(len=*), intent(in):: var3_name + integer, intent(in):: im, jm, km + real(kind=8), intent(out):: var3(im,jm,km) + + integer:: status, var3id + + status = nf_inq_varid (ncid, var3_name, var3id) + + if (status .ne. NF_NOERR) & + call handle_err('get_var3_double varid '//var3_name,status) + + status = nf_get_var_double (ncid, var3id, var3) + if (status .ne. NF_NOERR) & + call handle_err('get_var3_double get_vara_double '//var3_name,status) + + end subroutine get_var3_double + + subroutine get_var3_real( ncid, var3_name, im, jm, km, var3 ) + integer, intent(in):: ncid + character(len=*), intent(in):: var3_name + integer, intent(in):: im, jm, km + real(kind=4), intent(out):: var3(im,jm,km) + + integer:: status, var3id + + status = nf_inq_varid (ncid, var3_name, var3id) + + if (status .ne. NF_NOERR) & + call handle_err('get_var3_real varid '//var3_name,status) + status = nf_get_var_real (ncid, var3id, var3) + + if (status .ne. NF_NOERR) & + call handle_err('get_var3_real get_var_real '//var3_name,status) + + end subroutine get_var3_real + + + subroutine check_var_exists(ncid, var_name, status) + integer, intent(in):: ncid + integer, intent(inout) :: status + character(len=*), intent(in):: var_name + integer:: varid + status = nf_inq_varid (ncid, var_name, varid) + end subroutine check_var_exists + + subroutine get_var3_r4( ncid, var3_name, is,ie, js,je, ks,ke, var3, time_slice ) + integer, intent(in):: ncid + character(len=*), intent(in):: var3_name + integer, intent(in):: is, ie, js, je, ks,ke + real(kind=4), intent(out):: var3(is:ie,js:je,ks:ke) + integer, intent(in), optional :: time_slice +! + real(kind=4), dimension(1) :: time + integer, dimension(4):: start, nreco + integer:: status, var3id + + status = nf_inq_varid (ncid, var3_name, var3id) + if (status .ne. NF_NOERR) call handle_err('get_var3_r4 varid '//var3_name,status) + + start(1) = is; start(2) = js; start(3) = ks; start(4) = 1 + if ( present(time_slice) ) then + start(4) = time_slice + end if + + nreco(1) = ie - is + 1 + nreco(2) = je - js + 1 + nreco(3) = ke - ks + 1 + nreco(4) = 1 + + status = nf_get_vara_real(ncid, var3id, start, nreco, var3) + if (status .ne. NF_NOERR) call handle_err('get_var3_r4 get_vara_real '//var3_name,status) + + end subroutine get_var3_r4 + + + subroutine get_var4_real( ncid, var4_name, im, jm, km, nt, var4 ) + implicit none +#include + integer, intent(in):: ncid + character*(*), intent(in):: var4_name + integer, intent(in):: im, jm, km, nt + real*4:: wk4(im,jm,km,4) + real*4, intent(out):: var4(im,jm) + integer:: status, var4id + integer:: start(4), icount(4) + integer:: i,j + + start(1) = 1 + start(2) = 1 + start(3) = 1 + start(4) = nt + + icount(1) = im ! all range + icount(2) = jm ! all range + icount(3) = km ! all range + icount(4) = 1 ! one time level at a time + +! write(*,*) nt, 'Within get_var4_double: ', var4_name + + status = nf_inq_varid (ncid, var4_name, var4id) +! write(*,*) '#1', status, ncid, var4id + + status = nf_get_vara_real(ncid, var4id, start, icount, var4) +! status = nf_get_vara_real(ncid, var4id, start, icount, wk4) +! write(*,*) '#2', status, ncid, var4id + + do j=1,jm + do i=1,im +! var4(i,j) = wk4(i,j,1,nt) + enddo + enddo + + if (status .ne. NF_NOERR) call handle_err('get_var4_r4 get_vara_real '//var4_name,status) + + end subroutine get_var4_real + + + subroutine get_var4_double( ncid, var4_name, im, jm, km, nt, var4 ) + integer, intent(in):: ncid + character(len=*), intent(in):: var4_name + integer, intent(in):: im, jm, km, nt + real(kind=8), intent(out):: var4(im,jm,km,1) + integer:: status, var4id +! + integer:: start(4), icount(4) + + start(1) = 1 + start(2) = 1 + start(3) = 1 + start(4) = nt + + icount(1) = im ! all range + icount(2) = jm ! all range + icount(3) = km ! all range + icount(4) = 1 ! one time level at a time + + status = nf_inq_varid (ncid, var4_name, var4id) + status = nf_get_vara_double(ncid, var4id, start, icount, var4) + + if (status .ne. NF_NOERR) call handle_err('get_var4_double get_vara_double '//var4_name,status) + + end subroutine get_var4_double +!------------------------------------------------------------------------ + + subroutine get_real3( ncid, var4_name, im, jm, nt, var4 ) +! This is for multi-time-level 2D var + integer, intent(in):: ncid + character(len=*), intent(in):: var4_name + integer, intent(in):: im, jm, nt + real(kind=4), intent(out):: var4(im,jm) + integer:: status, var4id + integer:: start(3), icount(3) + integer:: i,j + + start(1) = 1 + start(2) = 1 + start(3) = nt + + icount(1) = im + icount(2) = jm + icount(3) = 1 + + status = nf_inq_varid (ncid, var4_name, var4id) + status = nf_get_vara_real(ncid, var4id, start, icount, var4) + + if (status .ne. NF_NOERR) & + call handle_err('get_real3 get_vara_real '//var4_name,status) + + end subroutine get_real3 +!------------------------------------------------------------------------ + + logical function check_var( ncid, var3_name) + integer, intent(in):: ncid + character(len=*), intent(in):: var3_name + + integer:: status, var3id + + status = nf_inq_varid (ncid, var3_name, var3id) + check_var = (status == NF_NOERR) + + end function check_var + + subroutine get_var_att_str(ncid, var_name, att_name, att) + implicit none +#include + integer, intent(in):: ncid + character*(*), intent(in):: var_name, att_name + character*(*), intent(out):: att + + integer:: status, varid + + status = nf_inq_varid (ncid, var_name, varid) + status = nf_get_att_text(ncid, varid, att_name, att) + + if (status .ne. NF_NOERR) call handle_err('get_var_att_str '//var_name,status) + + end subroutine get_var_att_str + + subroutine get_var_att_double(ncid, var_name, att_name, value) + implicit none +#include + integer, intent(in):: ncid + character*(*), intent(in):: var_name, att_name + real(kind=8), intent(out):: value + + integer:: status, varid + + status = nf_inq_varid (ncid, var_name, varid) + status = nf_get_att(ncid, varid, att_name, value) + + if (status .ne. NF_NOERR) call handle_err('get_var_att_double '//var_name,status) + + end subroutine get_var_att_double + + + subroutine handle_err(idstr, status, errflg) + integer status + character(len=500) :: errstr + character(len=*) :: idstr + integer, optional, intent(inout) :: errflg + + if (status .ne. nf_noerr) then + write(errstr,*) 'Error in handle_err: ',trim(idstr)//' ',NF_STRERROR(STATUS) + ! call mpp_error(FATAL,errstr) + ! if (available(errflg)) errflg = 1 + ! return + write(6, *) trim(errstr) + stop + endif + + end subroutine handle_err + +!>@brief The subroutine 'calendar' computes the current GMT. + subroutine calendar(year, month, day, hour) + integer, intent(inout) :: year ! year + integer, intent(inout) :: month ! month + integer, intent(inout) :: day ! day + integer, intent(inout) :: hour +! +! Local variables +! + integer irem4,irem100 + integer mdays(12) !< number day of month + data mdays /31,28,31,30,31,30,31,31,30,31,30,31/ +!**** consider leap year +! + irem4 = mod( year, 4 ) + irem100 = mod( year, 100 ) + if( irem4 == 0 .and. irem100 /= 0) mdays(2) = 29 +! + if( hour >= 24 ) then + day = day + 1 + hour = hour - 24 + end if + + if( day > mdays(month) ) then + day = day - mdays(month) + month = month + 1 + end if + if( month > 12 ) then + year = year + 1 + month = 1 + end if + + end subroutine calendar + +end module sim_nc_mod_lnd From fcbfb5ca175f1409114fb7267f6ff12a069772bd Mon Sep 17 00:00:00 2001 From: tsga Date: Tue, 19 Mar 2024 11:55:53 +0000 Subject: [PATCH 015/154] add land iau as noahmpdrv_time_vary module --- config/ccpp_prebuild_config.py | 250 +++++++++++++ driver/CCPP_driver.F90 | 254 +++++++++++++ physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 288 +++++++-------- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 130 +++---- .../Land/Noahmp/noahmpdrv_time_vary.F90 | 340 ++++++++++++++++++ .../Land/Noahmp/noahmpdrv_time_vary.meta | 230 ++++++++++++ .../suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml | 96 +++++ suites/suite_FV3_GFS_v17_p8_ugwpv1.xml | 95 +++++ 8 files changed, 1475 insertions(+), 208 deletions(-) create mode 100755 config/ccpp_prebuild_config.py create mode 100644 driver/CCPP_driver.F90 create mode 100644 physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 create mode 100644 physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta create mode 100644 suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml create mode 100644 suites/suite_FV3_GFS_v17_p8_ugwpv1.xml diff --git a/config/ccpp_prebuild_config.py b/config/ccpp_prebuild_config.py new file mode 100755 index 000000000..6080e1769 --- /dev/null +++ b/config/ccpp_prebuild_config.py @@ -0,0 +1,250 @@ +#!/usr/bin/env python + +# CCPP prebuild config for GFDL Finite-Volume Cubed-Sphere Model (FV3) + + +############################################################################### +# Definitions # +############################################################################### + +HOST_MODEL_IDENTIFIER = "FV3" + +# Add all files with metadata tables on the host model side and in CCPP, +# relative to basedir = top-level directory of host model. This includes +# kind and type definitions used in CCPP physics. Also add any internal +# dependencies of these files to the list. +VARIABLE_DEFINITION_FILES = [ + # actual variable definition files + 'framework/src/ccpp_types.F90', + 'physics/physics/machine.F', + 'physics/physics/radsw_param.f', + 'physics/physics/radlw_param.f', + 'physics/physics/h2o_def.f', + 'physics/physics/radiation_surface.f', + 'physics/physics/module_ozphys.F90', + 'data/CCPP_typedefs.F90', + 'data/GFS_typedefs.F90', + 'data/CCPP_data.F90', + ] + +TYPEDEFS_NEW_METADATA = { + 'ccpp_types' : { + 'ccpp_t' : 'cdata', + 'ccpp_types' : '', + }, + 'machine' : { + 'machine' : '', + }, + 'module_radlw_parameters' : { + 'module_radsw_parameters' : '', + }, + 'module_radlw_parameters' : { + 'module_radlw_parameters' : '', + }, + 'module_ozphys' : { + 'module_ozphys' : '', + 'ty_ozphys' : '', + }, + 'CCPP_typedefs' : { + 'GFS_interstitial_type' : 'GFS_Interstitial(cdata%thrd_no)', + 'GFDL_interstitial_type' : 'GFDL_interstitial', + 'CCPP_typedefs' : '', + }, + 'CCPP_data' : { + 'CCPP_data' : '', + }, + 'GFS_typedefs' : { + 'GFS_control_type' : 'GFS_Control', + 'GFS_data_type' : 'GFS_Data(cdata%blk_no)', + 'GFS_diag_type' : 'GFS_Data(cdata%blk_no)%Intdiag', + 'GFS_tbd_type' : 'GFS_Data(cdata%blk_no)%Tbd', + 'GFS_sfcprop_type' : 'GFS_Data(cdata%blk_no)%Sfcprop', + 'GFS_coupling_type' : 'GFS_Data(cdata%blk_no)%Coupling', + 'GFS_statein_type' : 'GFS_Data(cdata%blk_no)%Statein', + 'GFS_cldprop_type' : 'GFS_Data(cdata%blk_no)%Cldprop', + 'GFS_radtend_type' : 'GFS_Data(cdata%blk_no)%Radtend', + 'GFS_grid_type' : 'GFS_Data(cdata%blk_no)%Grid', + 'GFS_stateout_type' : 'GFS_Data(cdata%blk_no)%Stateout', + 'GFS_typedefs' : '', + }, + } + +# Add all physics scheme files relative to basedir +SCHEME_FILES = [ + # Relative path to source (from where ccpp_prebuild.py is called) : [ list of physics sets in which scheme may be called ]; + # current restrictions are that each scheme can only belong to one physics set, and all schemes within one group in the + # suite definition file have to belong to the same physics set + 'physics/physics/GFS_DCNV_generic_pre.F90', + 'physics/physics/GFS_DCNV_generic_post.F90', + 'physics/physics/GFS_GWD_generic_pre.F90', + 'physics/physics/GFS_GWD_generic_post.F90', + 'physics/physics/GFS_MP_generic_pre.F90', + 'physics/physics/GFS_MP_generic_post.F90', + 'physics/physics/GFS_PBL_generic_pre.F90', + 'physics/physics/GFS_PBL_generic_post.F90', + 'physics/physics/GFS_SCNV_generic_pre.F90', + 'physics/physics/GFS_SCNV_generic_post.F90', + 'physics/physics/GFS_debug.F90', + 'physics/physics/GFS_phys_time_vary.fv3.F90', + 'physics/physics/GFS_rad_time_vary.fv3.F90', + 'physics/physics/GFS_radiation_surface.F90', + 'physics/physics/GFS_rrtmg_post.F90', + 'physics/physics/GFS_rrtmg_pre.F90', + 'physics/physics/GFS_rrtmg_setup.F90', + 'physics/physics/GFS_stochastics.F90', + 'physics/physics/GFS_suite_interstitial_rad_reset.F90', + 'physics/physics/GFS_suite_interstitial_phys_reset.F90', + 'physics/physics/GFS_suite_interstitial_1.F90', + 'physics/physics/GFS_suite_interstitial_2.F90', + 'physics/physics/GFS_suite_stateout_reset.F90', + 'physics/physics/GFS_suite_stateout_update.F90', + 'physics/physics/GFS_suite_interstitial_3.F90', + 'physics/physics/GFS_suite_interstitial_4.F90', + 'physics/physics/GFS_suite_interstitial_5.F90', + 'physics/physics/GFS_surface_generic_pre.F90', + 'physics/physics/GFS_surface_generic_post.F90', + 'physics/physics/GFS_surface_composites_pre.F90', + 'physics/physics/GFS_surface_composites_inter.F90', + 'physics/physics/GFS_surface_composites_post.F90', + 'physics/physics/GFS_surface_loop_control_part1.F90', + 'physics/physics/GFS_surface_loop_control_part2.F90', + 'physics/physics/GFS_time_vary_pre.fv3.F90', + 'physics/physics/GFS_physics_post.F90', + 'physics/physics/cires_ugwp.F90', + 'physics/physics/cires_ugwp_post.F90', + 'physics/physics/unified_ugwp.F90', + 'physics/physics/unified_ugwp_post.F90', + 'physics/physics/ugwpv1_gsldrag.F90', + 'physics/physics/ugwpv1_gsldrag_post.F90', + 'physics/physics/cnvc90.f', + 'physics/physics/cs_conv_pre.F90', + 'physics/physics/cs_conv.F90', + 'physics/physics/cs_conv_post.F90', + 'physics/physics/cs_conv_aw_adj.F90', + 'physics/physics/cu_ntiedtke_pre.F90', + 'physics/physics/cu_ntiedtke.F90', + 'physics/physics/cu_ntiedtke_post.F90', + 'physics/physics/dcyc2t3.f', + 'physics/physics/drag_suite.F90', + 'physics/physics/shoc.F90', + 'physics/physics/get_prs_fv3.F90', + 'physics/physics/get_phi_fv3.F90', + 'physics/physics/gfdl_cloud_microphys.F90', + 'physics/physics/fv_sat_adj.F90', + 'physics/physics/gfdl_sfc_layer.F90', + 'physics/physics/zhaocarr_gscond.f', + 'physics/physics/gwdc_pre.f', + 'physics/physics/gwdc.f', + 'physics/physics/gwdc_post.f', + 'physics/physics/gwdps.f', + 'physics/physics/h2ophys.f', + 'physics/physics/samfdeepcnv.f', + 'physics/physics/samfshalcnv.f', + 'physics/physics/sascnvn.F', + 'physics/physics/shalcnv.F', + 'physics/physics/maximum_hourly_diagnostics.F90', + 'physics/physics/m_micro.F90', + 'physics/physics/m_micro_pre.F90', + 'physics/physics/m_micro_post.F90', + 'physics/physics/cu_gf_driver_pre.F90', + 'physics/physics/cu_gf_driver.F90', + 'physics/physics/cu_gf_driver_post.F90', + 'physics/physics/cu_c3_driver_pre.F90', + 'physics/physics/cu_c3_driver.F90', + 'physics/physics/cu_c3_driver_post.F90', + 'physics/physics/hedmf.f', + 'physics/physics/moninshoc.f', + 'physics/physics/satmedmfvdif.F', + 'physics/physics/satmedmfvdifq.F', + 'physics/physics/shinhongvdif.F90', + 'physics/physics/ysuvdif.F90', + 'physics/physics/mynnedmf_wrapper.F90', + 'physics/physics/mynnsfc_wrapper.F90', + 'physics/physics/sgscloud_radpre.F90', + 'physics/physics/sgscloud_radpost.F90', + 'physics/physics/myjsfc_wrapper.F90', + 'physics/physics/myjpbl_wrapper.F90', + 'physics/physics/mp_thompson_pre.F90', + 'physics/physics/mp_thompson.F90', + 'physics/physics/mp_thompson_post.F90', + 'physics/physics/mp_nssl.F90', + 'physics/physics/zhaocarr_precpd.f', + 'physics/physics/radlw_main.F90', + 'physics/physics/radsw_main.F90', + 'physics/physics/rascnv.F90', + 'physics/physics/rayleigh_damp.f', + 'physics/physics/rrtmg_lw_post.F90', + 'physics/physics/rrtmg_lw_pre.F90', + 'physics/physics/rrtmg_sw_post.F90', + 'physics/physics/rad_sw_pre.F90', + 'physics/physics/sfc_diag.f', + 'physics/physics/sfc_diag_post.F90', + 'physics/physics/lsm_ruc.F90', + 'physics/physics/sfc_cice.f', + 'physics/physics/sfc_diff.f', + 'physics/physics/lsm_noah.f', + 'physics/physics/noahmpdrv.F90', + 'physics/physics/noahmpdrv_time_vary.F90', + 'physics/physics/flake_driver.F90', + 'physics/physics/clm_lake.f90', + 'physics/physics/sfc_nst_pre.f90', + 'physics/physics/sfc_nst.f90', + 'physics/physics/sfc_nst_post.f90', + 'physics/physics/sfc_ocean.F', + 'physics/physics/sfc_sice.f', + # HAFS FER_HIRES + 'physics/physics/mp_fer_hires.F90', + # SMOKE + 'physics/physics/smoke_dust/rrfs_smoke_wrapper.F90', + 'physics/physics/smoke_dust/rrfs_smoke_postpbl.F90', + # RRTMGP + 'physics/physics/rrtmgp_aerosol_optics.F90', + 'physics/physics/rrtmgp_lw_main.F90', + 'physics/physics/rrtmgp_sw_main.F90', + 'physics/physics/GFS_rrtmgp_setup.F90', + 'physics/physics/GFS_rrtmgp_pre.F90', + 'physics/physics/GFS_cloud_diagnostics.F90', + 'physics/physics/GFS_rrtmgp_cloud_mp.F90', + 'physics/physics/GFS_rrtmgp_cloud_overlap.F90', + 'physics/physics/GFS_rrtmgp_post.F90' + ] + +# Default build dir, relative to current working directory, +# if not specified as command-line argument +DEFAULT_BUILD_DIR = 'build' + +# Auto-generated makefile/cmakefile snippets that contain all type definitions +TYPEDEFS_MAKEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.mk' +TYPEDEFS_CMAKEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.cmake' +TYPEDEFS_SOURCEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.sh' + +# Auto-generated makefile/cmakefile snippets that contain all schemes +SCHEMES_MAKEFILE = '{build_dir}/physics/CCPP_SCHEMES.mk' +SCHEMES_CMAKEFILE = '{build_dir}/physics/CCPP_SCHEMES.cmake' +SCHEMES_SOURCEFILE = '{build_dir}/physics/CCPP_SCHEMES.sh' + +# Auto-generated makefile/cmakefile snippets that contain all caps +CAPS_MAKEFILE = '{build_dir}/physics/CCPP_CAPS.mk' +CAPS_CMAKEFILE = '{build_dir}/physics/CCPP_CAPS.cmake' +CAPS_SOURCEFILE = '{build_dir}/physics/CCPP_CAPS.sh' + +# Directory where to put all auto-generated physics caps +CAPS_DIR = '{build_dir}/physics' + +# Directory where the suite definition files are stored +SUITES_DIR = 'suites' + +# Directory where to write static API to +STATIC_API_DIR = '{build_dir}/physics' +STATIC_API_CMAKEFILE = '{build_dir}/physics/CCPP_STATIC_API.cmake' +STATIC_API_SOURCEFILE = '{build_dir}/physics/CCPP_STATIC_API.sh' + +# Directory for writing HTML pages generated from metadata files +# used by metadata2html.py for generating scientific documentation +METADATA_HTML_OUTPUT_DIR = '{build_dir}/physics/physics/docs' + +# HTML document containing the model-defined CCPP variables +HTML_VARTABLE_FILE = '{build_dir}/physics/CCPP_VARIABLES_FV3.html' + +# LaTeX document containing the provided vs requested CCPP variables +LATEX_VARTABLE_FILE = '{build_dir}/framework/doc/DevelopersGuide/CCPP_VARIABLES_FV3.tex' diff --git a/driver/CCPP_driver.F90 b/driver/CCPP_driver.F90 new file mode 100644 index 000000000..6c633fc4d --- /dev/null +++ b/driver/CCPP_driver.F90 @@ -0,0 +1,254 @@ +module CCPP_driver + + use ccpp_types, only: ccpp_t + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + use CCPP_data, only: cdata_tile, & + cdata_domain, & + cdata_block, & + ccpp_suite, & + GFS_control, & + GFS_data + + implicit none + +!--------------------------------------------------------! +! Pointer to CCPP containers defined in CCPP_data ! +!--------------------------------------------------------! + type(ccpp_t), pointer :: cdata => null() + +!--------------------------------------------------------! +! Flag for non-uniform block sizes (last block smaller) ! +! and number of OpenMP threads (with special thread ! +! number nthrdsX in case of non-uniform block sizes) ! +!--------------------------------------------------------! + logical :: non_uniform_blocks + integer :: nthrds, nthrdsX + +!---------------- +! Public Entities +!---------------- +! functions + public CCPP_step +! module variables + public non_uniform_blocks + + CONTAINS +!******************************************************************************************* + +!------------------------------- +! CCPP step +!------------------------------- + subroutine CCPP_step (step, nblks, ierr) + +#ifdef _OPENMP + use omp_lib +#endif + + implicit none + + character(len=*), intent(in) :: step + integer, intent(in) :: nblks + integer, intent(out) :: ierr + ! Local variables + integer :: nb, nt, ntX + integer :: ierr2 + ! DH* 20210104 - remove kdt_rad when code to clear diagnostic buckets is removed + integer :: kdt_rad + + ierr = 0 + + if (trim(step)=="init") then + + ! Get and set number of OpenMP threads (module + ! variable) that are available to run physics +#ifdef _OPENMP + nthrds = omp_get_max_threads() +#else + nthrds = 1 +#endif + + ! For non-uniform blocksizes, we use index nthrds+1 + ! for the interstitial data type with different length + if (non_uniform_blocks) then + nthrdsX = nthrds+1 + else + nthrdsX = nthrds + end if + + ! For physics running over the entire domain, block and thread + ! number are not used; set to safe values + cdata_domain%blk_no = 1 + cdata_domain%thrd_no = 1 + + ! Allocate cdata structures for blocks and threads + if (.not.allocated(cdata_block)) allocate(cdata_block(1:nblks,1:nthrdsX)) + + ! Loop over all blocks and threads + do nt=1,nthrdsX + do nb=1,nblks + ! Assign the correct block and thread numbers + cdata_block(nb,nt)%blk_no = nb + cdata_block(nb,nt)%thrd_no = nt + end do + end do + + else if (trim(step)=="physics_init") then + + ! Since the physics init step is independent of the blocking structure, + ! we can use cdata_domain. And since we don't use threading on the host + ! model side, we can allow threading inside the physics init routines. + GFS_control%nthreads = nthrds + + call ccpp_physics_init(cdata_domain, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_init" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + ! Timestep init = time_vary + else if (trim(step)=="timestep_init") then + + ! Since the physics timestep init step is independent of the blocking structure, + ! we can use cdata_domain. And since we don't use threading on the host + ! model side, we can allow threading inside the timestep init (time_vary) routines. + GFS_control%nthreads = nthrds + + call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite), group_name="time_vary", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group time_vary" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + ! call timestep_init for "physics" + call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="physics", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group physics" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! DH* 20210104 - this block of code will be removed once the CCPP framework ! + ! fully supports handling diagnostics through its metadata, work in progress ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !--- determine if radiation diagnostics buckets need to be cleared + if (nint(GFS_control%fhzero*3600) >= nint(max(GFS_control%fhswr,GFS_control%fhlwr))) then + if (mod(GFS_control%kdt,GFS_control%nszero) == 1) then + do nb = 1,nblks + call GFS_data(nb)%Intdiag%rad_zero(GFS_control) + end do + endif + else + kdt_rad = nint(min(GFS_control%fhswr,GFS_control%fhlwr)/GFS_control%dtp) + if (mod(GFS_control%kdt,kdt_rad) == 1) then + do nb = 1,nblks + call GFS_data(nb)%Intdiag%rad_zero(GFS_control) + enddo + endif + endif + + !--- determine if physics diagnostics buckets need to be cleared + if ((mod(GFS_control%kdt-1,GFS_control%nszero)) == 0) then + do nb = 1,nblks + call GFS_data(nb)%Intdiag%phys_zero(GFS_control) + end do + endif + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! *DH 20210104 ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Radiation, physics and and stochastic physics - threaded regions using blocked data structures + else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then + + ! Set number of threads available to physics schemes to one, + ! because threads are used on the host model side for blocking + GFS_control%nthreads = 1 + +!$OMP parallel num_threads (nthrds) & +!$OMP default (shared) & +!$OMP private (nb,nt,ntX,ierr2) & +!$OMP reduction (+:ierr) +#ifdef _OPENMP + nt = omp_get_thread_num()+1 +#else + nt = 1 +#endif +!$OMP do schedule (dynamic,1) + do nb = 1,nblks + ! For non-uniform blocks, the last block has a different (shorter) + ! length than the other blocks; use special CCPP_Interstitial(nthrdsX) + if (non_uniform_blocks .and. nb==nblks) then + ntX = nthrdsX + else + ntX = nt + end if + !--- Call CCPP radiation/physics/stochastics group + call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name=trim(step), ierr=ierr2) + if (ierr2/=0) then + write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", trim(step), & + ", block ", nb, " and thread ", nt, " (ntX=", ntX, "):" + write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) + ierr = ierr + ierr2 + end if + end do +!$OMP end do + +!$OMP end parallel + if (ierr/=0) return + + ! Timestep finalize = time_vary + else if (trim(step)=="timestep_finalize") then + + ! Since the physics timestep finalize step is independent of the blocking structure, + ! we can use cdata_domain. And since we don't use threading on the host model side, + ! we can allow threading inside the timestep finalize (time_vary) routines. + GFS_control%nthreads = nthrds + + call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="time_vary", ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group time_vary" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + ! Physics finalize + else if (trim(step)=="physics_finalize") then + + ! Since the physics finalize step is independent of the blocking structure, + ! we can use cdata_domain. And since we don't use threading on the host + ! model side, we can allow threading inside the physics finalize routines. + GFS_control%nthreads = nthrds + + call ccpp_physics_finalize(cdata_domain, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(0,'(a)') "An error occurred in ccpp_physics_finalize" + write(0,'(a)') trim(cdata_domain%errmsg) + return + end if + + ! Finalize + else if (trim(step)=="finalize") then + ! Deallocate cdata structure for blocks and threads + if (allocated(cdata_block)) deallocate(cdata_block) + + else + + write(0,'(2a)') 'Error, undefined CCPP step ', trim(step) + ierr = 1 + return + + end if + + end subroutine CCPP_step + +end module CCPP_driver diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 69228e926..cb92724c0 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -13,8 +13,8 @@ module noahmpdrv use module_sf_noahmplsm ! 3.5.24 for use in IAU - use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& - lnd_iau_mod_set_control, lnd_iau_mod_init,lnd_iau_mod_getiauforcing +! use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& +! lnd_iau_mod_set_control, lnd_iau_mod_init,lnd_iau_mod_getiauforcing implicit none @@ -22,11 +22,11 @@ module noahmpdrv private - public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_timestep_init + public :: noahmpdrv_init, noahmpdrv_run !, noahmpdrv_timestep_init ! IAU data and control - type (lnd_iau_control_type) :: LND_IAU_Control - type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks +! type (lnd_iau_control_type) :: LND_IAU_Control +! type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks contains @@ -125,14 +125,16 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & resid (:) = drysmc (:) ! 3.7.24 init iau for land - call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & - lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) +! call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & +! lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) + ! print*, 'proc errmsg, errflg after set control', me, errmsg, errflg ! print*, 'proc iau_control isc, nx, dtp fhour', me, LND_IAU_Control%isc, LND_IAU_Control%nx, & ! LND_IAU_Control%dtp, LND_IAU_Control%fhour ! print*, 'proc iau_control incfiles(1)', me, LND_IAU_Control%iau_inc_files(1) ! stop - call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) + +! call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval ! print*, 'proc nblks blksize(1) after set init', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) @@ -144,141 +146,141 @@ end subroutine noahmpdrv_init !! \section arg_table_noahmpdrv_timestep_init Argument Table !! \htmlinclude noahmpdrv_timestep_init.html !! - subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, - stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, - ! lsnow_lsm, lsnowl, & - ! ncols, isc, jsc, nx, ny, nblks, - ! & - ! blksz, xlon, xlat, - ! & !& garea, iyrlen, julian, - ! vegtype, idveg, & - ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, - - use machine, only: kind_phys - - implicit none - - ! integer, intent(in) :: me !mpi_rank - ! integer, intent(in) :: mpi_root ! = GFS_Control%master - integer , intent(in) :: itime !current forecast iteration - real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) - real(kind=kind_phys) , intent(in) :: delt ! time interval [s] - integer , intent(in) :: km !vertical soil layer dimension - real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] - real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! integer, intent(in) :: lsnow_lsm - ! integer , intent(in) :: lsnowl ! lower bound for snow level arrays - ! integer, intent(in) :: ncols, isc, jsc, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks - ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz - ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude - !integer , dimension(:) , intent(in) :: vegtype !vegetation type (integer index) - ! real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] - ! real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] - ! real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! - ! ground surface skin temperature [K] - ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! - ! total soil moisture content [m3/m3] - ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! - ! soil temp [K] - ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc ! - ! liquid soil moisture [m3/m3] - ! real(kind=kind_phys), dimension(:) , intent(out) :: t2mmp ! - ! combined T2m from tiles - ! real(kind=kind_phys), dimension(:) , intent(out) :: q2mp ! - ! combined q2m from tiles - ! character(len=*), intent(out) :: errmsg - ! integer, intent(out) :: errflg - - ! --- local variable - ! integer :: nb, im ! vertical soil layer dimension - - ! IAU update - real,allocatable :: stc_inc_flat(:,:) - real,allocatable :: slc_inc_flat(:,:) - ! real,allocatable :: tmp2m_inc_flat(:) - ! real,allocatable :: spfh2m_inc_flat(:) - integer :: j, k, ib - ! --- end declaration - - ! --- Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - !> update current forecast hour - ! GFS_control%jdat(:) = jdat(:) - LND_IAU_Control%fhour=fhour - - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & - " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp - endif - - !> 3.7.24 read iau increments - call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) - if (errflg .ne. 0) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" - print*, errmsg - endif - return - endif - - !> update with iau increments - if (LND_IAU_Data%in_interval) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "adding land iau increments " - endif - - if (LND_IAU_Control%lsoil .ne. km) then - write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km - errflg = 1 - return - endif - - ! local variable to copy blocked data LND_IAU_Data%stc_inc - allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols - ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols - ib = 1 - do j = 1, LND_IAU_Control%ny !ny - do k = 1, km - stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) - slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) - enddo - ! ib = 1 - ! do j = 1, LND_IAU_Control%ny !ny - ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) - ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) - - ib = ib + LND_IAU_Control%nx !nlon - enddo - - ! delt=GFS_Control%dtf - if ((LND_IAU_Control%dtp - delt) > 0.0001) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp - endif - endif - !IAU increments are in units of 1/sec !LND_IAU_Control%dtp - do k = 1, km - stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp - slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp - enddo - ! t2mmp = t2mmp + & - ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp - ! q2mp = q2mp + & - ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp - - deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) - - endif - - end subroutine noahmpdrv_timestep_init +! subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, +! stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, +! ! lsnow_lsm, lsnowl, & +! ! ncols, isc, jsc, nx, ny, nblks, +! ! & +! ! blksz, xlon, xlat, +! ! & !& garea, iyrlen, julian, +! ! vegtype, idveg, & +! ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, +! +! use machine, only: kind_phys +! +! implicit none +! +! ! integer, intent(in) :: me !mpi_rank +! ! integer, intent(in) :: mpi_root ! = GFS_Control%master +! integer , intent(in) :: itime !current forecast iteration +! real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) +! real(kind=kind_phys) , intent(in) :: delt ! time interval [s] +! integer , intent(in) :: km !vertical soil layer dimension +! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] +! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' +! character(len=*), intent(out) :: errmsg +! integer, intent(out) :: errflg +! +! ! integer, intent(in) :: lsnow_lsm +! ! integer , intent(in) :: lsnowl ! lower bound for snow level arrays +! ! integer, intent(in) :: ncols, isc, jsc, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks +! ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz +! ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon +! ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude +! !integer , dimension(:) , intent(in) :: vegtype !vegetation type (integer index) +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! +! ! ground surface skin temperature [K] +! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! +! ! total soil moisture content [m3/m3] +! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! +! ! soil temp [K] +! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc ! +! ! liquid soil moisture [m3/m3] +! ! real(kind=kind_phys), dimension(:) , intent(out) :: t2mmp ! +! ! combined T2m from tiles +! ! real(kind=kind_phys), dimension(:) , intent(out) :: q2mp ! +! ! combined q2m from tiles +! ! character(len=*), intent(out) :: errmsg +! ! integer, intent(out) :: errflg +! +! ! --- local variable +! ! integer :: nb, im ! vertical soil layer dimension +! +! ! IAU update +! real,allocatable :: stc_inc_flat(:,:) +! real,allocatable :: slc_inc_flat(:,:) +! ! real,allocatable :: tmp2m_inc_flat(:) +! ! real,allocatable :: spfh2m_inc_flat(:) +! integer :: j, k, ib +! ! --- end declaration +! +! ! --- Initialize CCPP error handling variables +! errmsg = '' +! errflg = 0 +! +! !> update current forecast hour +! ! GFS_control%jdat(:) = jdat(:) +! LND_IAU_Control%fhour=fhour +! +! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then +! print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & +! " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp +! endif +! +! !> 3.7.24 read iau increments +! call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) +! if (errflg .ne. 0) then +! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then +! print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" +! print*, errmsg +! endif +! return +! endif +! +! !> update with iau increments +! if (LND_IAU_Data%in_interval) then +! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then +! print*, "adding land iau increments " +! endif +! +! if (LND_IAU_Control%lsoil .ne. km) then +! write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km +! errflg = 1 +! return +! endif +! +! ! local variable to copy blocked data LND_IAU_Data%stc_inc +! allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols +! allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols +! ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols +! ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols +! ib = 1 +! do j = 1, LND_IAU_Control%ny !ny +! do k = 1, km +! stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) +! slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) +! enddo +! ! ib = 1 +! ! do j = 1, LND_IAU_Control%ny !ny +! ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) +! ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) +! +! ib = ib + LND_IAU_Control%nx !nlon +! enddo +! +! ! delt=GFS_Control%dtf +! if ((LND_IAU_Control%dtp - delt) > 0.0001) then +! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then +! print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp +! endif +! endif +! !IAU increments are in units of 1/sec !LND_IAU_Control%dtp +! do k = 1, km +! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp +! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp +! enddo +! ! t2mmp = t2mmp + & +! ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp +! ! q2mp = q2mp + & +! ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp +! +! deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) +! +! endif +! +! end subroutine noahmpdrv_timestep_init !> \ingroup NoahMP_LSM diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 2f037467f..4cb7792c9 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -215,71 +215,71 @@ intent = in ######################################################################## -[ccpp-arg-table] - name = noahmpdrv_timestep_init - type = scheme -[itime] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in -[delt] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[km] - standard_name = vertical_dimension_of_soil - long_name = soil vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[stc] - standard_name = soil_temperature - long_name = soil temperature - units = K - dimensions = (horizontal_dimension,vertical_dimension_of_soil) - type = real - kind = kind_phys - intent = inout -[slc] - standard_name = volume_fraction_of_unfrozen_water_in_soil - long_name = liquid soil moisture - units = frac - dimensions = (horizontal_dimension,vertical_dimension_of_soil) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - +#[ccpp-arg-table] +# name = noahmpdrv_timestep_init +# type = scheme +#[itime] +# standard_name = index_of_timestep +# long_name = current forecast iteration +# units = index +# dimensions = () +# type = integer +# intent = in +#[fhour] +# standard_name = forecast_time +# long_name = current forecast time +# units = h +# dimensions = () +# type = real +# kind = kind_phys +# intent = in +#[delt] +# standard_name = timestep_for_dynamics +# long_name = dynamics timestep +# units = s +# dimensions = () +# type = real +# kind = kind_phys +# intent = in +#[km] +# standard_name = vertical_dimension_of_soil +# long_name = soil vertical layer dimension +# units = count +# dimensions = () +# type = integer +# intent = in +#[stc] +# standard_name = soil_temperature +# long_name = soil temperature +# units = K +# dimensions = (horizontal_dimension,vertical_dimension_of_soil) +# type = real +# kind = kind_phys +# intent = inout +#[slc] +# standard_name = volume_fraction_of_unfrozen_water_in_soil +# long_name = liquid soil moisture +# units = frac +# dimensions = (horizontal_dimension,vertical_dimension_of_soil) +# type = real +# kind = kind_phys +# intent = inout +#[errmsg] +# standard_name = ccpp_error_message +# long_name = error message for error handling in CCPP +# units = none +# dimensions = () +# type = character +# kind = len=* +# intent = out +#[errflg] +# standard_name = ccpp_error_code +# long_name = error code for error handling in CCPP +# units = 1 +# dimensions = () +# type = integer +# intent = out +# ######################################################################## [ccpp-arg-table] name = noahmpdrv_run diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 new file mode 100644 index 000000000..ea9805cd4 --- /dev/null +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 @@ -0,0 +1,340 @@ +#define CCPP +!> \file noahmpdrv_time_vary.F90 +!! This file contains the IAU Updates for the NoahMP land surface scheme driver. + +!>\defgroup NoahMP_LSM NoahMP LSM Model +!! \brief This is the NoahMP LSM the IAU Updates module + +!> This module contains the CCPP-compliant IAU Update module for NoahMP land surface model driver. +!> The noahmpdrv_time_vary module is an alternative to calling the IAU updates directly from within the noahmpdrv module +!> The current "CCPP_driver" module's ccpp_step(step="timestep_init") function call only handles group="time_vary" and not "physics" +! +module noahmpdrv_time_vary + + ! use module_sf_noahmplsm + ! 3.5.24 for use in IAU + use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& + lnd_iau_mod_set_control, lnd_iau_mod_init,lnd_iau_mod_getiauforcing + + implicit none + + private + + public :: noahmpdrv_time_vary_init, noahmpdrv_time_vary_timestep_init !, noahmpdrv_time_vary_run +! public :: noahmpdrv_time_vary_timestep_finalize, noahmpdrv_time_vary_finalize + + ! IAU data and control + type (lnd_iau_control_type) :: LND_IAU_Control + type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks + + contains + +!> \ingroup NoahMP_LSM +!! \brief This subroutine is called during the CCPP initialization phase to +!! initialize Land IAU Control and Land IAU Data structures. +!! \section arg_table_noahmpdrv_time_vary_init Argument Table +!! \htmlinclude noahmpdrv_time_vary_init.html +!! + subroutine noahmpdrv_time_vary_init(lsm, lsm_noahmp, me, mpi_root, & + fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, nblks, & + blksz, xlon, xlat, & + lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) + + use machine, only: kind_phys + !use GFS_typedefs, only: GFS_control_type + ! use GFS_typedefs, only: GFS_data_type + + implicit none + + integer, intent(in) :: lsm + integer, intent(in) :: lsm_noahmp + integer, intent(in) :: me ! mpi_rank + integer, intent(in) :: mpi_root ! = GFS_Control%master + character(*), intent(in) :: fn_nml + character(len=:), intent(in), dimension(:), pointer :: input_nml_file + integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks + integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + integer, intent(in) :: lsoil, lsnow_lsm + real(kind=kind_phys), intent(in) :: dtp, fhour + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! type(gfs_data_type), dimension(:), intent(inout) :: GFS_Data ! !(one:) + ! type(gfs_control_type), intent(in) :: GFS_Control + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! 3.7.24 init iau for land + call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & + lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) +! print*, 'proc errmsg, errflg after set control', me, errmsg, errflg +! print*, 'proc iau_control isc, nx, dtp fhour', me, LND_IAU_Control%isc, LND_IAU_Control%nx, & +! LND_IAU_Control%dtp, LND_IAU_Control%fhour +! print*, 'proc iau_control incfiles(1)', me, LND_IAU_Control%iau_inc_files(1) +! stop + call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) + !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval + print*, 'proc nblks blksize(1) after lnd_iau_mod_init ', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) + + end subroutine noahmpdrv_time_vary_init + +!> \ingroup NoahMP_LSM +!! \brief This subroutine is called before noahmpdrv_run timestep to update +!! states with iau increments +!! \section arg_table_noahmpdrv_time_vary_timestep_init Argument Table +!! \htmlinclude noahmpdrv_time_vary_timestep_init.html +!! + subroutine noahmpdrv_time_vary_timestep_init (itime, fhour, delt, km, & !me, mpi_root, + stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, + + use machine, only: kind_phys + + implicit none + + ! integer, intent(in) :: me !mpi_rank + ! integer, intent(in) :: mpi_root ! = GFS_Control%master + integer , intent(in) :: itime !current forecast iteration + real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) + real(kind=kind_phys) , intent(in) :: delt ! time interval [s] + integer , intent(in) :: km !vertical soil layer dimension + real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] + real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! --- local variable + ! integer :: nb, im ! vertical soil layer dimension + + ! IAU update + real,allocatable :: stc_inc_flat(:,:) + real,allocatable :: slc_inc_flat(:,:) + ! real,allocatable :: tmp2m_inc_flat(:) + ! real,allocatable :: spfh2m_inc_flat(:) + integer :: j, k, ib + ! --- end declaration + + ! --- Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + !> update current forecast hour + ! GFS_control%jdat(:) = jdat(:) + LND_IAU_Control%fhour=fhour + + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & + " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp + endif + + !> 3.7.24 read iau increments + call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) + if (errflg .ne. 0) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" + print*, errmsg + endif + return + endif + + !> update with iau increments + if (LND_IAU_Data%in_interval) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "adding land iau increments " + endif + + if (LND_IAU_Control%lsoil .ne. km) then + write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km + errflg = 1 + return + endif + + ! local variable to copy blocked data LND_IAU_Data%stc_inc + allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ib = 1 + do j = 1, LND_IAU_Control%ny !ny + do k = 1, km + stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) + slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) + enddo + ! ib = 1 + ! do j = 1, LND_IAU_Control%ny !ny + ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) + ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) + + ib = ib + LND_IAU_Control%nx !nlon + enddo + + ! delt=GFS_Control%dtf + if ((LND_IAU_Control%dtp - delt) > 0.0001) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "Warning noahmpdrv_timevary_tstep delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp + endif + endif + !IAU increments are in units of 1/sec !LND_IAU_Control%dtp + do k = 1, km + stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + enddo + ! t2mmp = t2mmp + & + ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp + ! q2mp = q2mp + & + ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp + + deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + + endif + + end subroutine noahmpdrv_time_vary_timestep_init + + +! !> \ingroup NoahMP_LSM +! !! \brief +! !! \section arg_table_noahmpdrv_time_vary_run Argument Table +! !! \htmlinclude noahmpdrv_time_vary_run.html +! !! +! !! \section general_noahmpdrv_time_vary_run +! !! @{ +! !! - Initialize CCPP error handling variables. + +! subroutine noahmpdrv_time_vary_run(nb, im, km, lsnowl, itime, fhour, errmsg, errflg) +! ! ! --- inputs: +! ! ! --- in/outs: +! ! weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & +! ! ! --- Noah MP specific +! ! ! --- outputs: +! ! ) + +! use machine , only : kind_phys + +! implicit none + +! ! +! ! --- CCPP interface fields (in call order) +! ! +! integer , intent(in) :: nb !=cdata%blk_no, +! integer , intent(in) :: im ! horiz dimension and num of used pts +! integer , intent(in) :: km ! vertical soil layer dimension +! integer , intent(in) :: lsnowl ! lower bound for snow level arrays +! integer , intent(in) :: itime ! NOT USED current forecast iteration +! real(kind=kind_phys) , intent(in) :: fhour ! currentforecast time (hr) + +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! ground surface skin temperature [K] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tprcp ! total precipitation [m] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: srflag ! snow/rain flag for precipitation +! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! total soil moisture content [m3/m3] +! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soil temp [K] +! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc ! liquid soil moisture [m3/m3] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: canopy ! canopy moisture content [mm] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: trans ! total plant transpiration [m/s] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tsurf ! surface skin temperature [K] +! ! real(kind=kind_phys), dimension(:) , intent(inout) :: zorl ! surface roughness [cm] + +! character(len=*) , intent(out) :: errmsg +! integer , intent(out) :: errflg +! ! +! ! --- end declaration +! ! + +! ! +! ! --- Initialize CCPP error handling variables +! ! +! errmsg = '' +! errflg = 0 + +! ! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then +! ! print*,"nb ",nb," itime ",itime," GFScont%fhour ",fhour," iauCon%fhour",LND_IAU_Control%fhour," delt ",delt," iauCont%dtp",LND_IAU_Control%dtp +! ! endif +! ! ! 3.7.24 read iau increments +! ! call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) +! ! if (errflg .ne. 0) return +! ! ! update with iau increments +! ! if (LND_IAU_Data%in_interval) then +! ! if (LND_IAU_Control%lsoil .ne. km) then +! ! write(errmsg, *)'in noahmpdrv_run, lnd_iau_mod update increments:LND_IAU_Control%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km +! ! errflg = 1 +! ! return +! ! endif +! ! ! LND_IAU_Data%stc_inc(is:ie, js:je, km)) size of (nx, ny) +! ! ! xlatin(im) stc(im,km) slc() t2mmp(:) q2mp(im) km=n_soill, im = +! ! ! GFS_Control%blksz(cdata%blk_no) +! ! ! >> need to get (cdata%blk_no from function call + +! ! ! local variable to copy blocked data LND_IAU_Data%stc_inc +! ! allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols +! ! allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols +! ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols +! ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols +! ! ib = 1 +! ! do j = 1, LND_IAU_Control%ny !ny +! ! do k = 1, km +! ! stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%stc_inc(:,j,k) +! ! slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j,k) +! ! enddo +! ! ! ib = 1 +! ! ! do j = 1, LND_IAU_Control%ny !ny +! ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%tmp2m_inc(:,j,1) +! ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%spfh2m_inc(:,j,1) +! ! ib = ib + LND_IAU_Control%nx !nlon +! ! enddo + +! ! !IAU increments are in units of 1/sec !LND_IAU_Control%dtp +! ! ! delt=GFS_Control%dtf +! ! if ((LND_IAU_Control%dtp - delt) > 0.0001) then +! ! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then +! ! print*, "Warning time step used in noahmpdrv_run delt ",delt," different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp +! ! endif +! ! endif +! ! do k = 1, km +! ! stc(:,k)=stc(:,k)+stc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp +! ! slc(:,k)=slc(:,k)+slc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp +! ! enddo +! ! t2mmp = t2mmp+tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp +! ! q2mp = q2mp +spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp + +! ! deallocate(stc_inc_flat, slc_inc_flat, tmp2m_inc_flat, spfh2m_inc_flat) + +! ! end if +! end subroutine noahmpdrv_time_vary_run + +! subroutine noahmpdrv_time_vary_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, + + +! use machine, only: kind_phys + +! implicit none + +! character(len=*), intent(out) :: errmsg +! integer, intent(out) :: errflg + +! ! --- Initialize CCPP error handling variables +! errmsg = '' +! errflg = 0 + +! end subroutine noahmpdrv_time_vary_timestep_finalize + +! subroutine noahmpdrv_time_vary_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, + + +! use machine, only: kind_phys + +! implicit none + +! character(len=*), intent(out) :: errmsg +! integer, intent(out) :: errflg + +! ! --- Initialize CCPP error handling variables +! errmsg = '' +! errflg = 0 + +! end subroutine noahmpdrv_time_vary_finalize + +end module noahmpdrv_time_vary diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta new file mode 100644 index 000000000..246fe1f5e --- /dev/null +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta @@ -0,0 +1,230 @@ +[ccpp-table-properties] + name = noahmpdrv_time_vary + type = scheme + dependencies = funcphys.f90, machine.F + dependencies = sim_nc_mod_lnd.F90, lnd_iau_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = noahmpdrv_time_vary_init + type = scheme +[lsm] + standard_name = control_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in +[lsm_noahmp] + standard_name = identifier_for_noahmp_land_surface_scheme + long_name = flag for NOAH MP land surface model + units = flag + dimensions = () + type = integer + intent = in +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpi_root] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[fn_nml] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + type = character + dimensions = () + kind = len=* + intent = in +[input_nml_file] + standard_name = filename_of_internal_namelist + long_name = amelist filename for internal file reads + units = none + type = character + dimensions = (ccpp_constant_one:number_of_lines_in_internal_namelist) + kind = len=256 + intent = in +[isc] + standard_name = starting_x_index_for_this_mpi_rank + long_name = starting index in the x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[jsc] + standard_name = starting_y_index_for_this_mpi_rank + long_name = starting index in the y direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[ncols] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nx] + standard_name = number_of_points_in_x_direction_for_this_mpi_rank + long_name = number of points in x direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[ny] + standard_name = number_of_points_in_y_direction_for_this_mpi_rank + long_name = number of points in y direction for this MPI rank + units = count + dimensions = () + type = integer + intent = in +[nblks] + standard_name = ccpp_block_count + long_name = for explicit data blocking: number of blocks + units = count + dimensions = () + type = integer + intent = in +[blksz] + standard_name = ccpp_block_sizes + long_name = for explicit data blocking: block sizes of all blocks + units = count + dimensions = (ccpp_constant_one:ccpp_block_count) + type = integer + intent = in +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[lsoil] + standard_name = vertical_dimension_of_soil + long_name = number of soil layers + units = count + dimensions = () + type = integer + intent = in +[lsnow_lsm] + standard_name = vertical_dimension_of_surface_snow + long_name = maximum number of snow layers for land surface model + units = count + dimensions = () + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = noahmpdrv_time_vary_timestep_init + type = scheme +[itime] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[delt] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[km] + standard_name = vertical_dimension_of_soil + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[slc] + standard_name = volume_fraction_of_unfrozen_water_in_soil + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml b/suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml new file mode 100644 index 000000000..011a93867 --- /dev/null +++ b/suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml @@ -0,0 +1,96 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + noahmpdrv_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + noahmpdrv + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + satmedmfvdifq + GFS_PBL_generic_post + GFS_GWD_generic_pre + ugwpv1_gsldrag + ugwpv1_gsldrag_post + GFS_GWD_generic_post + GFS_suite_stateout_update + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + mp_thompson_pre + + + mp_thompson + + + mp_thompson_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + GFS_physics_post + + + + diff --git a/suites/suite_FV3_GFS_v17_p8_ugwpv1.xml b/suites/suite_FV3_GFS_v17_p8_ugwpv1.xml new file mode 100644 index 000000000..bca1b018d --- /dev/null +++ b/suites/suite_FV3_GFS_v17_p8_ugwpv1.xml @@ -0,0 +1,95 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + noahmpdrv_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + GFS_radiation_surface + rad_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + noahmpdrv + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + satmedmfvdifq + GFS_PBL_generic_post + GFS_GWD_generic_pre + ugwpv1_gsldrag + ugwpv1_gsldrag_post + GFS_GWD_generic_post + GFS_suite_stateout_update + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + mp_thompson_pre + + + mp_thompson + + + mp_thompson_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + GFS_physics_post + + + + From 2b576f0c42ba4f67d8afcd4f37ceca0ff4eab7b9 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 24 Mar 2024 12:11:15 -0400 Subject: [PATCH 016/154] revert to using noahmpdrv_timestep_init --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 484 +++++++++--------- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 152 +++--- 2 files changed, 334 insertions(+), 302 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index cb92724c0..6493332d1 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -9,26 +9,26 @@ !! as diagnotics calculation. !> This module contains the CCPP-compliant NoahMP land surface model driver. - module noahmpdrv +module noahmpdrv - use module_sf_noahmplsm - ! 3.5.24 for use in IAU -! use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& -! lnd_iau_mod_set_control, lnd_iau_mod_init,lnd_iau_mod_getiauforcing + use module_sf_noahmplsm + ! 3.5.24 for use in IAU + use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& + lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing !, & lnd_iau_mod_finalize - implicit none + implicit none - integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS + integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS - private + private - public :: noahmpdrv_init, noahmpdrv_run !, noahmpdrv_timestep_init - - ! IAU data and control -! type (lnd_iau_control_type) :: LND_IAU_Control -! type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks + public :: noahmpdrv_init, noahmpdrv_run !, noahmpdrv_timestep_init + + ! IAU data and control + type (lnd_iau_control_type) :: LND_IAU_Control + type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks - contains + contains !> \ingroup NoahMP_LSM !! \brief This subroutine is called during the CCPP initialization phase and calls set_soilveg() to @@ -36,7 +36,7 @@ module noahmpdrv !! \section arg_table_noahmpdrv_init Argument Table !! \htmlinclude noahmpdrv_init.html !! - subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & + subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & isot, ivegsrc, & nlunit, pores, resid, & do_mynnsfclay,do_mynnedmf, & @@ -46,242 +46,254 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & blksz, xlon, xlat, & lsoil, lsnow_lsm, dtp, fhour) - use machine, only: kind_phys - use set_soilveg_mod, only: set_soilveg - use namelist_soilveg - use noahmp_tables - !use GFS_typedefs, only: GFS_control_type - ! use GFS_typedefs, only: GFS_data_type - - implicit none - - integer, intent(in) :: lsm - integer, intent(in) :: lsm_noahmp - integer, intent(in) :: me ! mpi_rank - integer, intent(in) :: isot, ivegsrc, nlunit - real (kind=kind_phys), dimension(:), intent(out) :: pores, resid - logical, intent(in) :: do_mynnsfclay - logical, intent(in) :: do_mynnedmf - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! land iau mod - integer, intent(in) :: mpi_root ! = GFS_Control%master - character(*), intent(in) :: fn_nml - character(len=:), intent(in), dimension(:), pointer :: input_nml_file - integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks - integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz - real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - real(kind_phys), dimension(:), intent(in) :: xlat ! latitude - integer, intent(in) :: lsoil, lsnow_lsm - real(kind=kind_phys), intent(in) :: dtp, fhour - ! type(gfs_data_type), dimension(:), intent(inout) :: GFS_Data ! !(one:) - !type(gfs_control_type), intent(in) :: GFS_Control - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Consistency checks - if (lsm/=lsm_noahmp) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of ', & - & 'LSM is different from Noah' - errflg = 1 - return - end if - - if (ivegsrc /= 1) then - errmsg = 'The NOAHMP LSM expects that the ivegsrc physics '// & - 'namelist parameter is 1. Exiting...' - errflg = 1 - return - end if - if (isot /= 1) then - errmsg = 'The NOAHMP LSM expects that the isot physics '// & - 'namelist parameter is 1. Exiting...' - errflg = 1 - return - end if + use machine, only: kind_phys + use set_soilveg_mod, only: set_soilveg + use namelist_soilveg + use noahmp_tables + !use GFS_typedefs, only: GFS_control_type + ! use GFS_typedefs, only: GFS_data_type + + implicit none + + integer, intent(in) :: lsm + integer, intent(in) :: lsm_noahmp + integer, intent(in) :: me ! mpi_rank + integer, intent(in) :: isot, ivegsrc, nlunit + real (kind=kind_phys), dimension(:), intent(out) :: pores, resid + logical, intent(in) :: do_mynnsfclay + logical, intent(in) :: do_mynnedmf + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! land iau mod + integer, intent(in) :: mpi_root ! = GFS_Control%master + character(*), intent(in) :: fn_nml + character(len=:), intent(in), dimension(:), pointer :: input_nml_file + integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks + integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + integer, intent(in) :: lsoil, lsnow_lsm + real(kind=kind_phys), intent(in) :: dtp, fhour + ! type(gfs_data_type), dimension(:), intent(inout) :: GFS_Data ! !(one:) + !type(gfs_control_type), intent(in) :: GFS_Control + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Consistency checks + if (lsm/=lsm_noahmp) then + write(errmsg,'(*(a))') 'Logic error: namelist choice of ', & + & 'LSM is different from Noah' + errflg = 1 + return + end if - if ( do_mynnsfclay .and. .not. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .true.' // & - 'but mynnpbl is .false.. Exiting ...' - errflg = 1 - return - end if + if (ivegsrc /= 1) then + errmsg = 'The NOAHMP LSM expects that the ivegsrc physics '// & + 'namelist parameter is 1. Exiting...' + errflg = 1 + return + end if + if (isot /= 1) then + errmsg = 'The NOAHMP LSM expects that the isot physics '// & + 'namelist parameter is 1. Exiting...' + errflg = 1 + return + end if - !--- initialize soil vegetation - call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) + if ( do_mynnsfclay .and. .not. do_mynnedmf) then + errmsg = 'Problem : do_mynnsfclay = .true.' // & + 'but mynnpbl is .false.. Exiting ...' + errflg = 1 + return + end if - !--- read in noahmp table - call read_mp_table_parameters(errmsg, errflg) + !--- initialize soil vegetation + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) - ! initialize psih and psim + !--- read in noahmp table + call read_mp_table_parameters(errmsg, errflg) - if ( do_mynnsfclay ) then - call psi_init(psi_opt,errmsg,errflg) - endif + ! initialize psih and psim - pores (:) = maxsmc (:) - resid (:) = drysmc (:) + if ( do_mynnsfclay ) then + call psi_init(psi_opt,errmsg,errflg) + endif - ! 3.7.24 init iau for land -! call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & -! lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) + pores (:) = maxsmc (:) + resid (:) = drysmc (:) -! print*, 'proc errmsg, errflg after set control', me, errmsg, errflg -! print*, 'proc iau_control isc, nx, dtp fhour', me, LND_IAU_Control%isc, LND_IAU_Control%nx, & -! LND_IAU_Control%dtp, LND_IAU_Control%fhour -! print*, 'proc iau_control incfiles(1)', me, LND_IAU_Control%iau_inc_files(1) -! stop + ! 3.7.24 init iau for land + call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & + lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) + ! print*, 'proc errmsg, errflg after set control', me, errmsg, errflg + ! print*, 'proc iau_control isc, nx, dtp fhour', me, LND_IAU_Control%isc, LND_IAU_Control%nx, & + ! LND_IAU_Control%dtp, LND_IAU_Control%fhour + ! print*, 'proc iau_control incfiles(1)', me, LND_IAU_Control%iau_inc_files(1) -! call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) - !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval - ! print*, 'proc nblks blksize(1) after set init', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) + call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) + !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval + ! print*, 'proc nblks blksize(1) after set init', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) - end subroutine noahmpdrv_init + end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM -!! \brief This subroutine is called before noahmpdrv_run timestep to update -!! states with iau increments +!! \brief This subroutine is called before noahmpdrv_run +!! to update states with iau increments !! \section arg_table_noahmpdrv_timestep_init Argument Table !! \htmlinclude noahmpdrv_timestep_init.html !! -! subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, -! stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, -! ! lsnow_lsm, lsnowl, & -! ! ncols, isc, jsc, nx, ny, nblks, -! ! & -! ! blksz, xlon, xlat, -! ! & !& garea, iyrlen, julian, -! ! vegtype, idveg, & -! ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, -! -! use machine, only: kind_phys -! -! implicit none -! -! ! integer, intent(in) :: me !mpi_rank -! ! integer, intent(in) :: mpi_root ! = GFS_Control%master -! integer , intent(in) :: itime !current forecast iteration -! real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) -! real(kind=kind_phys) , intent(in) :: delt ! time interval [s] -! integer , intent(in) :: km !vertical soil layer dimension -! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] -! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' -! character(len=*), intent(out) :: errmsg -! integer, intent(out) :: errflg -! -! ! integer, intent(in) :: lsnow_lsm -! ! integer , intent(in) :: lsnowl ! lower bound for snow level arrays -! ! integer, intent(in) :: ncols, isc, jsc, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks -! ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz -! ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon -! ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude -! !integer , dimension(:) , intent(in) :: vegtype !vegetation type (integer index) -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! -! ! ground surface skin temperature [K] -! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! -! ! total soil moisture content [m3/m3] -! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! -! ! soil temp [K] -! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc ! -! ! liquid soil moisture [m3/m3] -! ! real(kind=kind_phys), dimension(:) , intent(out) :: t2mmp ! -! ! combined T2m from tiles -! ! real(kind=kind_phys), dimension(:) , intent(out) :: q2mp ! -! ! combined q2m from tiles -! ! character(len=*), intent(out) :: errmsg -! ! integer, intent(out) :: errflg -! -! ! --- local variable -! ! integer :: nb, im ! vertical soil layer dimension -! -! ! IAU update -! real,allocatable :: stc_inc_flat(:,:) -! real,allocatable :: slc_inc_flat(:,:) -! ! real,allocatable :: tmp2m_inc_flat(:) -! ! real,allocatable :: spfh2m_inc_flat(:) -! integer :: j, k, ib -! ! --- end declaration -! -! ! --- Initialize CCPP error handling variables -! errmsg = '' -! errflg = 0 -! -! !> update current forecast hour -! ! GFS_control%jdat(:) = jdat(:) -! LND_IAU_Control%fhour=fhour -! -! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then -! print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & -! " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp -! endif -! -! !> 3.7.24 read iau increments -! call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) -! if (errflg .ne. 0) then -! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then -! print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" -! print*, errmsg -! endif -! return -! endif -! -! !> update with iau increments -! if (LND_IAU_Data%in_interval) then -! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then -! print*, "adding land iau increments " -! endif -! -! if (LND_IAU_Control%lsoil .ne. km) then -! write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km -! errflg = 1 -! return -! endif -! -! ! local variable to copy blocked data LND_IAU_Data%stc_inc -! allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols -! allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols -! ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols -! ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols -! ib = 1 -! do j = 1, LND_IAU_Control%ny !ny -! do k = 1, km -! stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) -! slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) -! enddo -! ! ib = 1 -! ! do j = 1, LND_IAU_Control%ny !ny -! ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) -! ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) -! -! ib = ib + LND_IAU_Control%nx !nlon -! enddo -! -! ! delt=GFS_Control%dtf -! if ((LND_IAU_Control%dtp - delt) > 0.0001) then -! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then -! print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp -! endif -! endif -! !IAU increments are in units of 1/sec !LND_IAU_Control%dtp -! do k = 1, km -! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp -! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp -! enddo -! ! t2mmp = t2mmp + & -! ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp -! ! q2mp = q2mp + & -! ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp -! -! deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) -! -! endif -! -! end subroutine noahmpdrv_timestep_init + subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, + stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, + ! lsnow_lsm, lsnowl, & + ! ncols, isc, jsc, nx, ny, nblks, + ! & + ! blksz, xlon, xlat, + ! & !& garea, iyrlen, julian, + ! vegtype, idveg, & + ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, + + use machine, only: kind_phys + + implicit none + + ! integer, intent(in) :: me !mpi_rank + ! integer, intent(in) :: mpi_root ! = GFS_Control%master + integer , intent(in) :: itime !current forecast iteration + real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) + real(kind=kind_phys) , intent(in) :: delt ! time interval [s] + integer , intent(in) :: km !vertical soil layer dimension + real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] + real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! integer, intent(in) :: lsnow_lsm + ! integer , intent(in) :: lsnowl ! lower bound for snow level arrays + ! integer, intent(in) :: ncols, isc, jsc, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks + ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + + ! --- local variable + ! integer :: nb, im ! vertical soil layer dimension + + ! IAU update + real,allocatable :: stc_inc_flat(:,:) + real,allocatable :: slc_inc_flat(:,:) + ! real,allocatable :: tmp2m_inc_flat(:) + ! real,allocatable :: spfh2m_inc_flat(:) + integer :: j, k, ib + ! --- end declaration + + ! --- Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + !> update current forecast hour + ! GFS_control%jdat(:) = jdat(:) + LND_IAU_Control%fhour=fhour + + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & + " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp + endif + + !> 3.7.24 read iau increments + call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) + if (errflg .ne. 0) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" + print*, errmsg + endif + return + endif + + !> update with iau increments + if (LND_IAU_Data%in_interval) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "adding land iau increments " + endif + + if (LND_IAU_Control%lsoil .ne. km) then + write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km + errflg = 1 + return + endif + + ! local variable to copy blocked data LND_IAU_Data%stc_inc + allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ib = 1 + do j = 1, LND_IAU_Control%ny !ny + do k = 1, km + stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) + slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) + enddo + ! ib = 1 + ! do j = 1, LND_IAU_Control%ny !ny + ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) + ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) + + ib = ib + LND_IAU_Control%nx !nlon + enddo + + ! delt=GFS_Control%dtf + if ((LND_IAU_Control%dtp - delt) > 0.0001) then + if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp + endif + endif + !IAU increments are in units of 1/sec !LND_IAU_Control%dtp + do k = 1, km + stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + enddo + ! t2mmp = t2mmp + & + ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp + ! q2mp = q2mp + & + ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp + + deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + + endif + + end subroutine noahmpdrv_timestep_init + + !> \ingroup NoahMP_LSM +!! \brief This subroutine is called after noahmpdrv_run +!! to free up allocated memory +!! \section arg_table_noahmpdrv_timestep_finalize Argument Table +!! \htmlinclude noahmpdrv_timestep_init.html +!! + subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, + + use machine, only: kind_phys + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: j, k, ib + + ! --- Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! ! delt=GFS_Control%dtf + ! if ((LND_IAU_Control%dtp - delt) > 0.0001) then + ! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + ! print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp + ! endif + ! endif + + ! call lnd_iau_mod_finalize() !LND_IAU_Control%finalize() + end subroutine noahmpdrv_timestep_finalize !> \ingroup NoahMP_LSM !! \brief This subroutine is the main CCPP entry point for the NoahMP LSM. @@ -1905,4 +1917,4 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! ---------------------------------------------------------------------- end subroutine penman - end module noahmpdrv +end module noahmpdrv diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 4cb7792c9..e99535399 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -215,72 +215,92 @@ intent = in ######################################################################## -#[ccpp-arg-table] -# name = noahmpdrv_timestep_init -# type = scheme -#[itime] -# standard_name = index_of_timestep -# long_name = current forecast iteration -# units = index -# dimensions = () -# type = integer -# intent = in -#[fhour] -# standard_name = forecast_time -# long_name = current forecast time -# units = h -# dimensions = () -# type = real -# kind = kind_phys -# intent = in -#[delt] -# standard_name = timestep_for_dynamics -# long_name = dynamics timestep -# units = s -# dimensions = () -# type = real -# kind = kind_phys -# intent = in -#[km] -# standard_name = vertical_dimension_of_soil -# long_name = soil vertical layer dimension -# units = count -# dimensions = () -# type = integer -# intent = in -#[stc] -# standard_name = soil_temperature -# long_name = soil temperature -# units = K -# dimensions = (horizontal_dimension,vertical_dimension_of_soil) -# type = real -# kind = kind_phys -# intent = inout -#[slc] -# standard_name = volume_fraction_of_unfrozen_water_in_soil -# long_name = liquid soil moisture -# units = frac -# dimensions = (horizontal_dimension,vertical_dimension_of_soil) -# type = real -# kind = kind_phys -# intent = inout -#[errmsg] -# standard_name = ccpp_error_message -# long_name = error message for error handling in CCPP -# units = none -# dimensions = () -# type = character -# kind = len=* -# intent = out -#[errflg] -# standard_name = ccpp_error_code -# long_name = error code for error handling in CCPP -# units = 1 -# dimensions = () -# type = integer -# intent = out -# -######################################################################## +[ccpp-arg-table] + name = noahmpdrv_timestep_init + type = scheme +[itime] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[delt] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[km] + standard_name = vertical_dimension_of_soil + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[slc] + standard_name = volume_fraction_of_unfrozen_water_in_soil + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +####################################################################### +[ccpp-arg-table] + name = noahmpdrv_timestep_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +####################################################################### [ccpp-arg-table] name = noahmpdrv_run type = scheme From d61f9dcab94937e374d39c49d5fdf3a01ecde3d4 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 24 Mar 2024 15:54:49 -0400 Subject: [PATCH 017/154] read all increment files at _init time --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 571 +++++++++++------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 7 +- 2 files changed, 344 insertions(+), 234 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 2b53edd81..bb2592319 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -88,6 +88,7 @@ module lnd_iau_mod real :: deg2rad,dt,rdt integer :: im,jm,km,nfiles,ncid + integer:: jbeg, jend integer :: n_soill, n_snowl !1.27.24 soil and snow layers logical :: do_lnd_iau_inc !do_lnd_iau_inc @@ -97,7 +98,8 @@ module lnd_iau_mod ! character(len=32), allocatable :: tracer_names(:) ! integer, allocatable :: tracer_indicies(:) - real(kind=4), allocatable:: wk3(:,:,:) +! real(kind=4), allocatable:: wk3(:, :,:,:) + real(kind=4), allocatable:: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :), wk3_t2m(:, :, :, :), wk3_q2m(:, :, :, :) type iau_internal_data_type ! real,allocatable :: ua_inc(:,:,:) @@ -323,7 +325,6 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, integer:: ib, i, j, k, nstep, kstep integer:: i1, i2, j1 - integer:: jbeg, jend logical:: found integer nfilesall @@ -369,11 +370,11 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, ! call get_tracer_names(MODEL_ATMOS, i, tracer_names(i)) ! tracer_indicies(i) = get_tracer_index(MODEL_ATMOS,tracer_names(i)) ! enddo - allocate(s2c(is:ie,js:je,4)) - allocate(id1(is:ie,js:je)) - allocate(id2(is:ie,js:je)) - allocate(jdc(is:ie,js:je)) - allocate(agrid(is:ie,js:je,2)) + allocate(s2c(is:ie,js:je,4)) + allocate(id1(is:ie,js:je)) + allocate(id2(is:ie,js:je)) + allocate(jdc(is:ie,js:je)) + allocate(agrid(is:ie,js:je,2)) ! determine number of increment files to read, and the valid forecast hours nfilesall = size(LND_IAU_Control%iau_inc_files) @@ -381,9 +382,9 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print*,'in lnd_iau_init incfile1 iaufhr1 ', & trim(LND_IAU_Control%iau_inc_files(1)),LND_IAU_Control%iaufhrs(1) do k=1,nfilesall - if (trim(LND_IAU_Control%iau_inc_files(k)) .eq. '' .or. LND_IAU_Control%iaufhrs(k) .lt. 0) exit + if (trim(LND_IAU_Control%iau_inc_files(k)) .eq. '' .or. LND_IAU_Control%iaufhrs(k) .lt. 0) exit if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print *,k,trim(adjustl(LND_IAU_Control%iau_inc_files(k))) + print *,k, " ", trim(adjustl(LND_IAU_Control%iau_inc_files(k))) endif nfiles = nfiles + 1 enddo @@ -410,12 +411,12 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, rdt = 1.0/dt ! set up interpolation weights to go from GSI's gaussian grid to cubed sphere - deg2rad = pi/180. + deg2rad = pi/180. ! npz = LND_IAU_Control%levs - fname = 'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)) - inquire (file=trim(fname), exist=exists) - if (exists) then + fname = 'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)) + inquire (file=trim(fname), exist=exists) + if (exists) then ! if( file_exist(fname) ) then call open_ncfile( fname, ncid ) ! open the file !TODO !change to Latitude @@ -446,32 +447,32 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, do j=1,jm lat(j) = lat(j) * deg2rad enddo - else + else ! call mpp_error(FATAL,'==> Error in IAU_initialize: Expected file '& ! //trim(fname)//' for DA increment does not exist') errmsg = 'FATAL Error in IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' errflg = 1 return - endif + endif - ! Initialize lat-lon to Cubed bi-linear interpolation coeff: - ! populate agrid +! Initialize lat-lon to Cubed bi-linear interpolation coeff: +! populate agrid ! print*,'is,ie,js,je=',is,ie,js,ie ! print*,'size xlon=',size(Init_parm%xlon(:,1)),size(Init_parm%xlon(1,:)) ! print*,'size agrid=',size(agrid(:,1,1)),size(agrid(1,:,1)),size(agrid(1,1,:)) - do j = 1,size(Init_parm_xlon,2) + do j = 1,size(Init_parm_xlon,2) do i = 1,size(Init_parm_xlon,1) -! print*,i,j,is-1+j,js-1+j + ! print*,i,j,is-1+j,js-1+j agrid(is-1+i,js-1+j,1)=Init_parm_xlon(i,j) agrid(is-1+i,js-1+j,2)=Init_parm_xlat(i,j) enddo - enddo - call remap_coef( is, ie, js, je, is, ie, js, je, & - im, jm, lon, lat, id1, id2, jdc, s2c, & - agrid) - deallocate ( lon, lat,agrid ) - if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) - if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) + enddo + call remap_coef( is, ie, js, je, is, ie, js, je, & + im, jm, lon, lat, id1, id2, jdc, s2c, & + agrid) + deallocate ( lon, lat,agrid ) + if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) + if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) ! allocate(LND_IAU_Data%ua_inc(is:ie, js:je, km)) ! allocate(LND_IAU_Data%va_inc(is:ie, js:je, km)) @@ -479,69 +480,116 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, ! allocate(LND_IAU_Data%delp_inc(is:ie, js:je, km)) ! allocate(LND_IAU_Data%delz_inc(is:ie, js:je, km)) ! allocate(LND_IAU_Data%tracer_inc(is:ie, js:je, km,ntracers)) - allocate(LND_IAU_Data%stc_inc(is:ie, js:je, km)) - allocate(LND_IAU_Data%slc_inc(is:ie, js:je, km)) - allocate(LND_IAU_Data%tmp2m_inc(is:ie, js:je, 1)) - allocate(LND_IAU_Data%spfh2m_inc(is:ie, js:je, 1)) + allocate(LND_IAU_Data%stc_inc(is:ie, js:je, km)) + allocate(LND_IAU_Data%slc_inc(is:ie, js:je, km)) + allocate(LND_IAU_Data%tmp2m_inc(is:ie, js:je, 1)) + allocate(LND_IAU_Data%spfh2m_inc(is:ie, js:je, 1)) ! allocate arrays that will hold iau state - allocate (iau_state%inc1%stc_inc(is:ie, js:je, km)) - allocate (iau_state%inc1%slc_inc(is:ie, js:je, km)) - allocate (iau_state%inc1%tmp2m_inc(is:ie, js:je, 1)) - allocate (iau_state%inc1%spfh2m_inc (is:ie, js:je, 1)) - iau_state%hr1=LND_IAU_Control%iaufhrs(1) - iau_state%wt = 1.0 ! IAU increment filter weights (default 1.0) - iau_state%wt_normfact = 1.0 - if (LND_IAU_Control%iau_filter_increments) then - ! compute increment filter weights, sum to obtain normalization factor - dtp=LND_IAU_Control%dtp - nstep = 0.5*LND_IAU_Control%iau_delthrs*3600/dtp - ! compute normalization factor for filter weights - normfact = 0. - do k=1,2*nstep+1 - kstep = k-1-nstep - sx = acos(-1.)*kstep/nstep - wx = acos(-1.)*kstep/(nstep+1) - if (kstep .ne. 0) then - wt = sin(wx)/wx*sin(sx)/sx - else - wt = 1.0 - endif - normfact = normfact + wt - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt - enddo - iau_state%wt_normfact = (2*nstep+1)/normfact - endif - ! if (do_lnd_iau_inc) then - ! call read_iau_forcing(LND_IAU_Control,iau_state%inc1,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)), errmsg, errflg, & - ! 'INPUT/'//trim(LND_IAU_Control%iau_inc_files_sfc(1))) - ! else - call read_iau_forcing(LND_IAU_Control,iau_state%inc1,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)), errmsg, errflg) - ! endif - if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window - call setiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) - endif - if (nfiles.GT.1) then !have multiple files, but only read in 2 at a time and interpoalte between them - allocate (iau_state%inc2%stc_inc(is:ie, js:je, km)) - allocate (iau_state%inc2%slc_inc(is:ie, js:je, km)) - allocate (iau_state%inc2%tmp2m_inc(is:ie, js:je, 1)) - allocate (iau_state%inc2%spfh2m_inc(is:ie, js:je, 1)) - iau_state%hr2=LND_IAU_Control%iaufhrs(2) - ! if (do_lnd_iau_inc) then - ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(2)),errmsg,errflg, & - ! 'INPUT/'//trim(LND_IAU_Control%iau_inc_files_sfc(2))) - ! else - call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(2)), errmsg, errflg) - ! endif - endif -! print*,'in IAU init',dt,rdt -! LND_IAU_Data%drymassfixer = LND_IAU_Control%iau_drymassfixer + allocate (iau_state%inc1%stc_inc(is:ie, js:je, km)) + allocate (iau_state%inc1%slc_inc(is:ie, js:je, km)) + allocate (iau_state%inc1%tmp2m_inc(is:ie, js:je, 1)) + allocate (iau_state%inc1%spfh2m_inc (is:ie, js:je, 1)) + iau_state%hr1=LND_IAU_Control%iaufhrs(1) + iau_state%wt = 1.0 ! IAU increment filter weights (default 1.0) + iau_state%wt_normfact = 1.0 + if (LND_IAU_Control%iau_filter_increments) then + ! compute increment filter weights, sum to obtain normalization factor + dtp=LND_IAU_Control%dtp + nstep = 0.5*LND_IAU_Control%iau_delthrs*3600/dtp + ! compute normalization factor for filter weights + normfact = 0. + do k=1,2*nstep+1 + kstep = k-1-nstep + sx = acos(-1.)*kstep/nstep + wx = acos(-1.)*kstep/(nstep+1) + if (kstep .ne. 0) then + wt = sin(wx)/wx*sin(sx)/sx + else + wt = 1.0 + endif + normfact = normfact + wt + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt + enddo + iau_state%wt_normfact = (2*nstep+1)/normfact + endif + +!3.22.24 MB wants to read all increments files at iau init + ! Find bounding latitudes: + jbeg = jm-1 + jend = 2 + do j=js,je + do i=is,ie + j1 = jdc(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + ! call read_iau_forcing(LND_IAU_Control,iau_state%inc1,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)), errmsg, errflg) + allocate (wk3_stc(nfiles, 1:im,jbeg:jend, 1:km)) + allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) + allocate (wk3_t2m(nfiles, 1:im,jbeg:jend, 1:1)) + allocate (wk3_q2m(nfiles, 1:im,jbeg:jend, 1:1)) + do k=1, nfiles + call read_iau_forcing_all_timesteps(LND_IAU_Control, 'INPUT/'//trim(LND_IAU_Control%iau_inc_files(k)), errmsg, errflg, & + wk3_stc(k, :, :, :), wk3_slc(k, :, :, :), wk3_t2m(k, :, :, :), wk3_q2m(k, :, :, :)) + enddo + ! call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) + ! call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) + call interp_inc_at_timestep(LND_IAU_Control, km, wk3_stc(1, :, :, :), iau_state%inc1%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, km, wk3_slc(1, :, :, :), iau_state%inc1%slc_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_t2m(1, :, :, :), iau_state%inc1%tmp2m_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_q2m(1, :, :, :), iau_state%inc1%spfh2m_inc, errmsg, errflg) + + if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window + call setiauforcing(LND_IAU_Control, LND_IAU_Data, iau_state%wt) + endif + if (nfiles.GT.1) then !have multiple files, but only read in 2 at a time and interpoalte between them + allocate (iau_state%inc2%stc_inc(is:ie, js:je, km)) + allocate (iau_state%inc2%slc_inc(is:ie, js:je, km)) + allocate (iau_state%inc2%tmp2m_inc(is:ie, js:je, 1)) + allocate (iau_state%inc2%spfh2m_inc(is:ie, js:je, 1)) + iau_state%hr2=LND_IAU_Control%iaufhrs(2) + + ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(2)), errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, km, wk3_stc(2, :, :, :), iau_state%inc2%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, km, wk3_slc(2, :, :, :), iau_state%inc2%slc_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_t2m(2, :, :, :), iau_state%inc2%tmp2m_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_q2m(2, :, :, :), iau_state%inc2%spfh2m_inc, errmsg, errflg) + endif +! print*,'end of IAU init',dt,rdt end subroutine lnd_iau_mod_init -subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control,LND_IAU_Data, errmsg, errflg) +subroutine lnd_iau_mod_finalize() + + implicit none + + if (allocated (wk3_stc)) deallocate (wk3_stc) + if (allocated (wk3_slc)) deallocate (wk3_slc) + if (allocated (wk3_t2m)) deallocate (wk3_t2m) + if (allocated (wk3_q2m)) deallocate (wk3_q2m) + + if (allocated(LND_IAU_Data%stc_inc)) deallocate (LND_IAU_Data%stc_inc) + if (allocated(LND_IAU_Data%slc_inc)) deallocate (LND_IAU_Data%slc_inc) + if (allocated(LND_IAU_Data%tmp2m_inc)) deallocate (LND_IAU_Data%tmp2m_inc) + if (allocated(LND_IAU_Data%spfh2m_inc)) deallocate (LND_IAU_Data%spfh2m_inc) + + if (allocated(iau_state%inc1%stc_inc)) deallocate(iau_state%inc1%stc_inc) + if (allocated(iau_state%inc1%slc_inc)) deallocate(iau_state%inc1%slc_inc) + if (allocated(iau_state%inc1%tmp2m_inc)) deallocate(iau_state%inc1%tmp2m_inc) + if (allocated(iau_state%inc1%spfh2m_inc)) deallocate(iau_state%inc1%spfh2m_inc) + + if (allocated(iau_state%inc2%stc_inc)) deallocate(iau_state%inc2%stc_inc) + if (allocated(iau_state%inc2%slc_inc)) deallocate(iau_state%inc2%slc_inc) + if (allocated(iau_state%inc2%tmp2m_inc)) deallocate(iau_state%inc2%tmp2m_inc) + if (allocated(iau_state%inc2%spfh2m_inc)) deallocate(iau_state%inc2%spfh2m_inc) + +end subroutine lnd_iau_mod_finalize + + subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) implicit none - ! integer, intent(in) :: me, mpi_root type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data character(len=*), intent(out) :: errmsg @@ -594,7 +642,7 @@ subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control,LND_IAU_Data, errmsg, errfl LND_IAU_Data%in_interval=.false. else if (LND_IAU_Control%iau_filter_increments) call setiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt=',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact LND_IAU_Data%in_interval=.true. endif return @@ -606,9 +654,9 @@ subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control,LND_IAU_Data, errmsg, errfl ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'no iau forcing',LND_IAU_Control%iaufhrs(1),LND_IAU_Control%fhour,LND_IAU_Control%iaufhrs(nfiles) LND_IAU_Data%in_interval=.false. else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt=',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact LND_IAU_Data%in_interval=.true. - do k=nfiles,1,-1 + do k=nfiles, 1, -1 if (LND_IAU_Control%iaufhrs(k) > LND_IAU_Control%fhour) then itnext=k endif @@ -618,15 +666,14 @@ subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control,LND_IAU_Data, errmsg, errfl iau_state%hr1=iau_state%hr2 iau_state%hr2=LND_IAU_Control%iaufhrs(itnext) iau_state%inc1=iau_state%inc2 - ! if (do_lnd_iau_inc) then - ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'reading next increment files',trim(LND_IAU_Control%iau_inc_files(itnext)), & - ! trim(LND_IAU_Control%iau_inc_files_sfc(itnext)) - ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(itnext)), errmsg, errflg, & - ! 'INPUT/'//trim(LND_IAU_Control%iau_inc_files_sfc(itnext))) - ! else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(LND_IAU_Control%iau_inc_files(itnext)) - call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(itnext)), errmsg, errflg) - ! endif + + ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(LND_IAU_Control%iau_inc_files(itnext)) + ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(itnext)), errmsg, errflg) + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'interpolating next lnd iau increment ', itnext !trim(LND_IAU_Control%iau_inc_files(itnext)) + call interp_inc_at_timestep(LND_IAU_Control, km, wk3_stc(itnext, :, :, :), iau_state%inc2%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, km, wk3_slc(itnext, :, :, :), iau_state%inc2%slc_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_t2m(itnext, :, :, :), iau_state%inc2%tmp2m_inc, errmsg, errflg) + call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_q2m(itnext, :, :, :), iau_state%inc2%spfh2m_inc, errmsg, errflg) endif call updateiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) endif @@ -635,12 +682,12 @@ subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control,LND_IAU_Data, errmsg, errfl end subroutine lnd_iau_mod_getiauforcing -subroutine updateiauforcing(LND_IAU_Control,LND_IAU_Data,wt) +subroutine updateiauforcing(LND_IAU_Control, LND_IAU_Data, wt) implicit none type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data - real(kind_phys) delt,wt + real(kind_phys) delt, wt integer i,j,k,l ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'in updateiauforcing',nfiles,LND_IAU_Control%iaufhrs(1:nfiles) @@ -648,15 +695,6 @@ subroutine updateiauforcing(LND_IAU_Control,LND_IAU_Data,wt) do j = js,je do i = is,ie do k = 1,npz - ! LND_IAU_Data%ua_inc(i,j,k) =(delt*IAU_state%inc1%ua_inc(i,j,k) + (1.-delt)* IAU_state%inc2%ua_inc(i,j,k))*rdt*wt - ! LND_IAU_Data%va_inc(i,j,k) =(delt*IAU_state%inc1%va_inc(i,j,k) + (1.-delt)* IAU_state%inc2%va_inc(i,j,k))*rdt*wt - ! LND_IAU_Data%temp_inc(i,j,k) =(delt*IAU_state%inc1%temp_inc(i,j,k) + (1.-delt)* IAU_state%inc2%temp_inc(i,j,k))*rdt*wt - ! LND_IAU_Data%delp_inc(i,j,k) =(delt*IAU_state%inc1%delp_inc(i,j,k) + (1.-delt)* IAU_state%inc2%delp_inc(i,j,k))*rdt*wt - ! LND_IAU_Data%delz_inc(i,j,k) =(delt*IAU_state%inc1%delz_inc(i,j,k) + (1.-delt)* IAU_state%inc2%delz_inc(i,j,k))*rdt*wt - ! do l=1,ntracers - ! LND_IAU_Data%tracer_inc(i,j,k,l) =(delt*IAU_state%inc1%tracer_inc(i,j,k,l) + (1.-delt)* IAU_state%inc2%tracer_inc(i,j,k,l))*rdt*wt - ! enddo - ! enddo ! do k = 1,n_soill ! LND_IAU_Data%stc_inc(i,j,k) =(delt*IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* IAU_state%inc2%stc_inc(i,j,k))*rdt*wt LND_IAU_Data%slc_inc(i,j,k) =(delt*IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* IAU_state%inc2%slc_inc(i,j,k))*rdt*wt @@ -668,148 +706,219 @@ subroutine updateiauforcing(LND_IAU_Control,LND_IAU_Data,wt) end subroutine updateiauforcing - subroutine setiauforcing(LND_IAU_Control,LND_IAU_Data,wt) - - implicit none - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data - real(kind_phys) delt, dt,wt - integer i,j,k,l,sphum -! this is only called if using 1 increment file - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'in lnd_iau setiauforcing',rdt - do j = js,je - do i = is,ie - do k = 1,npz - ! LND_IAU_Data%ua_inc(i,j,k) =wt*IAU_state%inc1%ua_inc(i,j,k)*rdt - ! LND_IAU_Data%va_inc(i,j,k) =wt*IAU_state%inc1%va_inc(i,j,k)*rdt - ! LND_IAU_Data%temp_inc(i,j,k) =wt*IAU_state%inc1%temp_inc(i,j,k)*rdt - ! LND_IAU_Data%delp_inc(i,j,k) =wt*IAU_state%inc1%delp_inc(i,j,k)*rdt - ! LND_IAU_Data%delz_inc(i,j,k) =wt*IAU_state%inc1%delz_inc(i,j,k)*rdt - ! do l = 1,ntracers - ! LND_IAU_Data%tracer_inc(i,j,k,l) =wt*IAU_state%inc1%tracer_inc(i,j,k,l)*rdt - ! enddo - ! enddo - ! do k = 1,n_soill ! - LND_IAU_Data%stc_inc(i,j,k) = wt*IAU_state%inc1%stc_inc(i,j,k)*rdt - LND_IAU_Data%slc_inc(i,j,k) = wt*IAU_state%inc1%slc_inc(i,j,k)*rdt - end do - LND_IAU_Data%tmp2m_inc(i,j,1) = wt*IAU_state%inc1%tmp2m_inc(i,j,1)*rdt - LND_IAU_Data%spfh2m_inc(i,j,1) = wt*IAU_state%inc1%spfh2m_inc(i,j,1)*rdt - enddo - enddo -! sphum=get_tracer_index(MODEL_ATMOS,'sphum') - - end subroutine setiauforcing - -subroutine read_iau_forcing(LND_IAU_Control, increments, fname, errmsg, errflg) !, fname_sfc) - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - type(iau_internal_data_type), intent(inout):: increments - character(len=*), intent(in) :: fname - ! character(len=*), intent(in), optional :: fname_sfc - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -!locals - ! real, dimension(:,:,:), allocatable:: u_inc, v_inc - - integer:: i, j, k, l, npz - integer:: i1, i2, j1 - integer:: jbeg, jend - ! real(kind=R_GRID), dimension(2):: p1, p2, p3 - ! real(kind=R_GRID), dimension(3):: e1, e2, ex, ey + subroutine setiauforcing(LND_IAU_Control, LND_IAU_Data, wt) - ! logical :: found - integer :: is, ie, js, je, km_store - logical :: exists + implicit none + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + real(kind_phys) delt, dt,wt + integer i,j,k,l,sphum + ! this is only called if using 1 increment file + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'in lnd_iau setiauforcing rdt = ',rdt + do j = js,je + do i = is,ie + do k = 1,npz + ! do k = 1,n_soill ! + LND_IAU_Data%stc_inc(i,j,k) = wt*IAU_state%inc1%stc_inc(i,j,k)*rdt + LND_IAU_Data%slc_inc(i,j,k) = wt*IAU_state%inc1%slc_inc(i,j,k)*rdt + end do + LND_IAU_Data%tmp2m_inc(i,j,1) = wt*IAU_state%inc1%tmp2m_inc(i,j,1)*rdt + LND_IAU_Data%spfh2m_inc(i,j,1) = wt*IAU_state%inc1%spfh2m_inc(i,j,1)*rdt + enddo + enddo + ! sphum=get_tracer_index(MODEL_ATMOS,'sphum') - !Errors messages handled through CCPP error handling variables - errmsg = '' - errflg = 0 + end subroutine setiauforcing - is = LND_IAU_Control%isc - ie = is + LND_IAU_Control%nx-1 - js = LND_IAU_Control%jsc - je = js + LND_IAU_Control%ny-1 +subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg, & + wk3_out_stc, wk3_out_slc, wk3_out_t2m, wk3_out_q2m) !, fname_sfc) is, ie, js, je, ks,ke, + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + character(len=*), intent(in) :: fname + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! integer, intent(in) :: is, ie, js, je, ks,ke + ! real(kind=4), intent(out) :: wk3_out(is:ie,js:je,ks:ke) + real(kind=4), intent(out) :: wk3_out_stc(1:im, jbeg:jend, 1:km) + real(kind=4), intent(out) :: wk3_out_slc(1:im, jbeg:jend, 1:km) + real(kind=4), intent(out) :: wk3_out_t2m(1:im, jbeg:jend, 1:1) + real(kind=4), intent(out) :: wk3_out_q2m(1:im, jbeg:jend, 1:1) + + integer:: i, j, k, l, npz + integer:: i1, i2, j1 + logical :: exists + integer :: ncid - deg2rad = pi/180. + character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] + character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] + character(len=32), :: t2m_vars = 'tmp2m_inc' + character(len=32), :: q2m_vars = 'spfh2m_inc' - npz = LND_IAU_Control%lsoil - - inquire (file=trim(fname), exist=exists) - if (exists) then - ! if( file_exist(fname) ) then + !Errors messages handled through CCPP error handling variables + errmsg = '' + errflg = 0 + + inquire (file=trim(fname), exist=exists) + if (exists) then +! if( file_exist(fname) ) then call open_ncfile( fname, ncid ) ! open the file - else + else ! call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '& ! //trim(fname)//' for DA increment does not exist') errmsg = 'FATAL Error in read_iau_forcing: Expected file '//trim(fname)//' for DA increment does not exist' errflg = 1 return - endif + endif - ! Find bounding latitudes: - jbeg = jm-1; jend = 2 - do j=js,je - do i=is,ie - j1 = jdc(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) + do i = 1, size(stc_vars) + print *, trim(stc_vars(i)) + call check_var_exists(ncid, trim(stc_vars(i)), ierr) + if (ierr == 0) then + ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) + call get_var3_r4( ncid, trim(stc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i) ) + else + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' + wk3_out = 0. + endif + enddo + do i = 1, size(slc_vars) + print *, trim(slc_vars(i)) + call check_var_exists(ncid, trim(slc_vars(i)), ierr) + if (ierr == 0) then + ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) + call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) + else + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' + wk3_out = 0. + endif + enddo + print *, trim(t2m_vars) + call check_var_exists(ncid, trim(t2m_vars), ierr) + if (ierr == 0) then + ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) + call get_var3_r4( ncid, trim(t2m_vars), 1,im, jbeg,jend, 1,1, wk3_out_t2m(:, :, :) ) + else + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(t2m_vars),' found, assuming zero' + wk3_out = 0. + endif + print *, trim(q2m_vars) + call check_var_exists(ncid, trim(q2m_vars), ierr) + if (ierr == 0) then + ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) + call get_var3_r4( ncid, trim(q2m_vars), 1,im, jbeg,jend, 1,1, wk3_out_q2m(:, :, :) ) + else + if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(q2m_vars),' found, assuming zero' + wk3_out = 0. + endif + + call close_ncfile(ncid) + +end subroutine read_iau_forcing_all_timesteps + +subroutine interp_inc_at_timestep(LND_IAU_Control, km_in, wk3_in, var, errmsg, errflg) !field_name, , jbeg, jend) + ! interpolate increment from GSI gaussian grid to cubed sphere + ! everying is on the A-grid, earth relative + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + ! character(len=*), intent(in) :: field_name + integer, intent(in) :: km_in !jbeg,jend + real(kind=4), intent(in) :: wk3_in(1:im,jbeg:jend, 1:km_in) + real, dimension(is:ie, js:je, 1:km), intent(inout) :: var + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer:: i1, i2, j1, k, j, i + + do k=1,km_in + do j=js,je + do i=is,ie + i1 = id1(i,j) + i2 = id2(i,j) + j1 = jdc(i,j) + var(i,j,k) = s2c(i,j,1)*wk3_in(i1,j1 ,k) + s2c(i,j,2)*wk3_in(i2,j1 ,k)+& + s2c(i,j,3)*wk3_in(i2,j1+1,k) + s2c(i,j,4)*wk3_in(i1,j1+1,k) + enddo enddo - enddo + enddo +end subroutine interp_inc_at_timestep - ! allocate ( wk3(1:im,jbeg:jend, 1:km) ) - ! read in 1 time level -! call interp_inc(LND_IAU_Control, 'T_inc',increments%temp_inc(:,:,:),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'delp_inc',increments%delp_inc(:,:,:),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'delz_inc',increments%delz_inc(:,:,:),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'u_inc',increments%ua_inc(:,:,:),jbeg,jend) ! can these be treated as scalars? -! call interp_inc(LND_IAU_Control, 'v_inc',increments%va_inc(:,:,:),jbeg,jend) -! ! do l=1,ntracers -! ! call interp_inc(trim(tracer_names(l))//'_inc',increments%tracer_inc(:,:,:,l),jbeg,jend) -! ! enddo -! call close_ncfile(ncid) -! deallocate (wk3) - -! ! is_land = .true. -! if ( present(fname_sfc) ) then -! inquire (file=trim(fname_sfc), exist=exists) -! if (exists) then -! ! if( file_exist(fname_sfc) ) then -! call open_ncfile( fname_sfc, ncid ) ! open the file -! else -! ! call mpp_error(FATAL,'==> Error in read_iau_forcing sfc: Expected file '& -! ! //trim(fname_sfc)//' for DA increment does not exist') -! errmsg = 'FATAL Error in read_iau_forcing sfc: Expected file '//trim(fname_sfc)//' for DA increment does not exist' -! errflg = 1 -! return -! endif - km_store = km - km = 1 ! n_soill Currently each soil layer increment is saved separately - allocate ( wk3(1:im,jbeg:jend, 1:km) ) - ! call interp_inc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend) !TODO check var name - call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) - call interp_inc(LND_IAU_Control, 'soilt2_inc',increments%stc_inc(:,:,2),jbeg,jend) - call interp_inc(LND_IAU_Control, 'soilt3_inc',increments%stc_inc(:,:,3),jbeg,jend) - call interp_inc(LND_IAU_Control, 'soilt4_inc',increments%stc_inc(:,:,4),jbeg,jend) - - call interp_inc(LND_IAU_Control, 'slc1_inc',increments%slc_inc(:,:,1),jbeg,jend) - call interp_inc(LND_IAU_Control, 'slc2_inc',increments%slc_inc(:,:,2),jbeg,jend) - call interp_inc(LND_IAU_Control, 'slc3_inc',increments%slc_inc(:,:,3),jbeg,jend) - call interp_inc(LND_IAU_Control, 'slc4_inc',increments%slc_inc(:,:,4),jbeg,jend) - - call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) - call interp_inc(LND_IAU_Control, 'spfh2m_inc',increments%spfh2m_inc(:,:,1),jbeg,jend) - ! call interp_inc_sfc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend, n_soill) - call close_ncfile(ncid) - deallocate (wk3) - km = km_store - ! else - ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'No IAU inc file for sfc, setting stc_inc=0.' - ! increments%stc_inc(:,:,:) = 0. - ! end if +subroutine read_iau_forcing(LND_IAU_Control, increments, fname, errmsg, errflg) !, fname_sfc) + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type(iau_internal_data_type), intent(inout):: increments + character(len=*), intent(in) :: fname +! character(len=*), intent(in), optional :: fname_sfc + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +!locals +! real, dimension(:,:,:), allocatable:: u_inc, v_inc + + integer:: i, j, k, l, npz + integer:: i1, i2, j1 + integer:: jbeg, jend +! real(kind=R_GRID), dimension(2):: p1, p2, p3 +! real(kind=R_GRID), dimension(3):: e1, e2, ex, ey + +! logical :: found + integer :: is, ie, js, je, km_store + logical :: exists + + !Errors messages handled through CCPP error handling variables + errmsg = '' + errflg = 0 + + is = LND_IAU_Control%isc + ie = is + LND_IAU_Control%nx-1 + js = LND_IAU_Control%jsc + je = js + LND_IAU_Control%ny-1 + + deg2rad = pi/180. + + npz = LND_IAU_Control%lsoil + + inquire (file=trim(fname), exist=exists) + if (exists) then +! if( file_exist(fname) ) then + call open_ncfile( fname, ncid ) ! open the file + else + ! call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '& + ! //trim(fname)//' for DA increment does not exist') + errmsg = 'FATAL Error in read_iau_forcing: Expected file '//trim(fname)//' for DA increment does not exist' + errflg = 1 + return + endif + + ! Find bounding latitudes: + jbeg = jm-1; jend = 2 + do j=js,je + do i=is,ie + j1 = jdc(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + + km_store = km + km = 1 ! n_soill Currently each soil layer increment is saved separately + allocate ( wk3(1:im,jbeg:jend, 1:km) ) + ! call interp_inc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend) !TODO check var name + call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) + call interp_inc(LND_IAU_Control, 'soilt2_inc',increments%stc_inc(:,:,2),jbeg,jend) + call interp_inc(LND_IAU_Control, 'soilt3_inc',increments%stc_inc(:,:,3),jbeg,jend) + call interp_inc(LND_IAU_Control, 'soilt4_inc',increments%stc_inc(:,:,4),jbeg,jend) + + call interp_inc(LND_IAU_Control, 'slc1_inc',increments%slc_inc(:,:,1),jbeg,jend) + call interp_inc(LND_IAU_Control, 'slc2_inc',increments%slc_inc(:,:,2),jbeg,jend) + call interp_inc(LND_IAU_Control, 'slc3_inc',increments%slc_inc(:,:,3),jbeg,jend) + call interp_inc(LND_IAU_Control, 'slc4_inc',increments%slc_inc(:,:,4),jbeg,jend) + + call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) + call interp_inc(LND_IAU_Control, 'spfh2m_inc',increments%spfh2m_inc(:,:,1),jbeg,jend) +! call interp_inc_sfc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend, n_soill) + call close_ncfile(ncid) + deallocate (wk3) + km = km_store end subroutine read_iau_forcing -subroutine interp_inc(LND_IAU_Control, field_name,var,jbeg,jend) +subroutine interp_inc(LND_IAU_Control, field_name, var, jbeg, jend) ! interpolate increment from GSI gaussian grid to cubed sphere ! everying is on the A-grid, earth relative type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 6493332d1..06e188364 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -13,8 +13,9 @@ module noahmpdrv use module_sf_noahmplsm ! 3.5.24 for use in IAU - use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& - lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing !, & lnd_iau_mod_finalize + use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type, & + lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing, & + lnd_iau_mod_finalize implicit none @@ -291,7 +292,7 @@ subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp ! endif ! endif - ! call lnd_iau_mod_finalize() !LND_IAU_Control%finalize() + call lnd_iau_mod_finalize() !LND_IAU_Control%finalize() end subroutine noahmpdrv_timestep_finalize From c0b760eff3cabf75717e27d59bb31164ddfbe9b3 Mon Sep 17 00:00:00 2001 From: tsga Date: Wed, 10 Apr 2024 15:00:53 +0000 Subject: [PATCH 018/154] debug --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 248 +++++++++--------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 4 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 4 +- 3 files changed, 132 insertions(+), 124 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index bb2592319..4734468de 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -91,7 +91,7 @@ module lnd_iau_mod integer:: jbeg, jend integer :: n_soill, n_snowl !1.27.24 soil and snow layers - logical :: do_lnd_iau_inc !do_lnd_iau_inc + logical :: do_lnd_iau !do_lnd_iau_inc integer :: is, ie, js, je integer :: npz !, ntracers @@ -145,7 +145,7 @@ module lnd_iau_mod integer :: lsoil !< number of soil layers ! this is the max dim (TBC: check it is consitent for noahmpdrv) integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model - logical :: do_lnd_iau_inc + logical :: do_lnd_iau real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours character(len=240) :: iau_inc_files(7)! list of increment files real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files @@ -187,7 +187,7 @@ module lnd_iau_mod end type lnd_iau_control_type type(iau_state_type) :: IAU_state - public lnd_iau_control_type, lnd_iau_external_data_type, lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing + public lnd_iau_control_type, lnd_iau_external_data_type, lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing, lnd_iau_mod_finalize contains @@ -217,13 +217,13 @@ subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, m !> 3.9.24 these are not available through the CCPP interface so need to read them from namelist file !> vars to read from namelist - logical :: do_lnd_iau_inc = .false. + logical :: do_lnd_iau = .false. real(kind=kind_phys) :: lnd_iau_delthrs = 0 !< iau time interval (to scale increments) character(len=240) :: lnd_iau_inc_files(7) = '' !< list of increment files real(kind=kind_phys) :: lnd_iaufhrs(7) = -1 !< forecast hours associated with increment files logical :: lnd_iau_filter_increments = .false. !< filter IAU increments - NAMELIST /lnd_iau_nml/ do_lnd_iau_inc, lnd_iau_delthrs, lnd_iau_inc_files, lnd_iaufhrs, lnd_iau_filter_increments !, lnd_iau_drymassfixer & + NAMELIST /lnd_iau_nml/ do_lnd_iau, lnd_iau_delthrs, lnd_iau_inc_files, lnd_iaufhrs, lnd_iau_filter_increments !, lnd_iau_drymassfixer & !Errors messages handled through CCPP error handling variables errmsg = '' @@ -270,7 +270,7 @@ subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, m write(6, lnd_iau_nml) endif - LND_IAU_Control%do_lnd_iau_inc = do_lnd_iau_inc + LND_IAU_Control%do_lnd_iau = do_lnd_iau LND_IAU_Control%iau_delthrs = lnd_iau_delthrs LND_IAU_Control%iau_inc_files = lnd_iau_inc_files LND_IAU_Control%iaufhrs = lnd_iaufhrs @@ -340,7 +340,7 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errmsg = '' errflg = 0 - do_lnd_iau_inc = LND_IAU_Control%do_lnd_iau_inc + do_lnd_iau = LND_IAU_Control%do_lnd_iau n_soill = LND_IAU_Control%lsoil !4 for sfc updates ! n_snowl = LND_IAU_Control%lsnowl npz = LND_IAU_Control%lsoil @@ -561,10 +561,15 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, end subroutine lnd_iau_mod_init -subroutine lnd_iau_mod_finalize() +subroutine lnd_iau_mod_finalize(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) implicit none + type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + if (allocated (wk3_stc)) deallocate (wk3_stc) if (allocated (wk3_slc)) deallocate (wk3_slc) if (allocated (wk3_t2m)) deallocate (wk3_t2m) @@ -743,15 +748,16 @@ subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg real(kind=4), intent(out) :: wk3_out_t2m(1:im, jbeg:jend, 1:1) real(kind=4), intent(out) :: wk3_out_q2m(1:im, jbeg:jend, 1:1) - integer:: i, j, k, l, npz - integer:: i1, i2, j1 + integer :: i, j, k, l, npz + integer :: i1, i2, j1 logical :: exists integer :: ncid + integer :: ierr character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] - character(len=32), :: t2m_vars = 'tmp2m_inc' - character(len=32), :: q2m_vars = 'spfh2m_inc' + character(len=32) :: t2m_vars = 'tmp2m_inc' + character(len=32) :: q2m_vars = 'spfh2m_inc' !Errors messages handled through CCPP error handling variables errmsg = '' @@ -777,7 +783,7 @@ subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg call get_var3_r4( ncid, trim(stc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i) ) else if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' - wk3_out = 0. + wk3_out_stc(:, :, i) = 0. endif enddo do i = 1, size(slc_vars) @@ -788,7 +794,7 @@ subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) else if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' - wk3_out = 0. + wk3_out_slc(:, :, i) = 0. endif enddo print *, trim(t2m_vars) @@ -798,7 +804,7 @@ subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg call get_var3_r4( ncid, trim(t2m_vars), 1,im, jbeg,jend, 1,1, wk3_out_t2m(:, :, :) ) else if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(t2m_vars),' found, assuming zero' - wk3_out = 0. + wk3_out_t2m(:, :, :) = 0. endif print *, trim(q2m_vars) call check_var_exists(ncid, trim(q2m_vars), ierr) @@ -807,7 +813,7 @@ subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg call get_var3_r4( ncid, trim(q2m_vars), 1,im, jbeg,jend, 1,1, wk3_out_q2m(:, :, :) ) else if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(q2m_vars),' found, assuming zero' - wk3_out = 0. + wk3_out_q2m(:, :, :) = 0. endif call close_ncfile(ncid) @@ -840,111 +846,111 @@ subroutine interp_inc_at_timestep(LND_IAU_Control, km_in, wk3_in, var, errmsg, e enddo end subroutine interp_inc_at_timestep -subroutine read_iau_forcing(LND_IAU_Control, increments, fname, errmsg, errflg) !, fname_sfc) - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - type(iau_internal_data_type), intent(inout):: increments - character(len=*), intent(in) :: fname -! character(len=*), intent(in), optional :: fname_sfc - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -!locals -! real, dimension(:,:,:), allocatable:: u_inc, v_inc - - integer:: i, j, k, l, npz - integer:: i1, i2, j1 - integer:: jbeg, jend -! real(kind=R_GRID), dimension(2):: p1, p2, p3 -! real(kind=R_GRID), dimension(3):: e1, e2, ex, ey - -! logical :: found - integer :: is, ie, js, je, km_store - logical :: exists - - !Errors messages handled through CCPP error handling variables - errmsg = '' - errflg = 0 - - is = LND_IAU_Control%isc - ie = is + LND_IAU_Control%nx-1 - js = LND_IAU_Control%jsc - je = js + LND_IAU_Control%ny-1 - - deg2rad = pi/180. - - npz = LND_IAU_Control%lsoil - - inquire (file=trim(fname), exist=exists) - if (exists) then -! if( file_exist(fname) ) then - call open_ncfile( fname, ncid ) ! open the file - else - ! call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '& - ! //trim(fname)//' for DA increment does not exist') - errmsg = 'FATAL Error in read_iau_forcing: Expected file '//trim(fname)//' for DA increment does not exist' - errflg = 1 - return - endif - - ! Find bounding latitudes: - jbeg = jm-1; jend = 2 - do j=js,je - do i=is,ie - j1 = jdc(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) - enddo - enddo - - km_store = km - km = 1 ! n_soill Currently each soil layer increment is saved separately - allocate ( wk3(1:im,jbeg:jend, 1:km) ) - ! call interp_inc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend) !TODO check var name - call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) - call interp_inc(LND_IAU_Control, 'soilt2_inc',increments%stc_inc(:,:,2),jbeg,jend) - call interp_inc(LND_IAU_Control, 'soilt3_inc',increments%stc_inc(:,:,3),jbeg,jend) - call interp_inc(LND_IAU_Control, 'soilt4_inc',increments%stc_inc(:,:,4),jbeg,jend) - - call interp_inc(LND_IAU_Control, 'slc1_inc',increments%slc_inc(:,:,1),jbeg,jend) - call interp_inc(LND_IAU_Control, 'slc2_inc',increments%slc_inc(:,:,2),jbeg,jend) - call interp_inc(LND_IAU_Control, 'slc3_inc',increments%slc_inc(:,:,3),jbeg,jend) - call interp_inc(LND_IAU_Control, 'slc4_inc',increments%slc_inc(:,:,4),jbeg,jend) - - call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) - call interp_inc(LND_IAU_Control, 'spfh2m_inc',increments%spfh2m_inc(:,:,1),jbeg,jend) -! call interp_inc_sfc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend, n_soill) - call close_ncfile(ncid) - deallocate (wk3) - km = km_store - -end subroutine read_iau_forcing - -subroutine interp_inc(LND_IAU_Control, field_name, var, jbeg, jend) -! interpolate increment from GSI gaussian grid to cubed sphere -! everying is on the A-grid, earth relative - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - character(len=*), intent(in) :: field_name - real, dimension(is:ie,js:je,1:km), intent(inout) :: var - integer, intent(in) :: jbeg,jend - integer:: i1, i2, j1, k,j,i,ierr - call check_var_exists(ncid, field_name, ierr) - if (ierr == 0) then - call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) - else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(field_name),' found, assuming zero' - wk3 = 0. - endif - do k=1,km - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - var(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+& - s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) - enddo - enddo - enddo -end subroutine interp_inc +!subroutine read_iau_forcing(LND_IAU_Control, increments, fname, errmsg, errflg) !, fname_sfc) +! type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control +! type(iau_internal_data_type), intent(inout):: increments +! character(len=*), intent(in) :: fname +!! character(len=*), intent(in), optional :: fname_sfc +! character(len=*), intent(out) :: errmsg +! integer, intent(out) :: errflg +!!locals +!! real, dimension(:,:,:), allocatable:: u_inc, v_inc +! +! integer:: i, j, k, l, npz +! integer:: i1, i2, j1 +! integer:: jbeg, jend +!! real(kind=R_GRID), dimension(2):: p1, p2, p3 +!! real(kind=R_GRID), dimension(3):: e1, e2, ex, ey +! +!! logical :: found +! integer :: is, ie, js, je, km_store +! logical :: exists +! +! !Errors messages handled through CCPP error handling variables +! errmsg = '' +! errflg = 0 +! +! is = LND_IAU_Control%isc +! ie = is + LND_IAU_Control%nx-1 +! js = LND_IAU_Control%jsc +! je = js + LND_IAU_Control%ny-1 +! +! deg2rad = pi/180. +! +! npz = LND_IAU_Control%lsoil +! +! inquire (file=trim(fname), exist=exists) +! if (exists) then +!! if( file_exist(fname) ) then +! call open_ncfile( fname, ncid ) ! open the file +! else +! ! call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '& +! ! //trim(fname)//' for DA increment does not exist') +! errmsg = 'FATAL Error in read_iau_forcing: Expected file '//trim(fname)//' for DA increment does not exist' +! errflg = 1 +! return +! endif +! +! ! Find bounding latitudes: +! jbeg = jm-1; jend = 2 +! do j=js,je +! do i=is,ie +! j1 = jdc(i,j) +! jbeg = min(jbeg, j1) +! jend = max(jend, j1+1) +! enddo +! enddo +! +! km_store = km +! km = 1 ! n_soill Currently each soil layer increment is saved separately +! allocate ( wk3(1:im,jbeg:jend, 1:km) ) +! ! call interp_inc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend) !TODO check var name +! call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'soilt2_inc',increments%stc_inc(:,:,2),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'soilt3_inc',increments%stc_inc(:,:,3),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'soilt4_inc',increments%stc_inc(:,:,4),jbeg,jend) +! +! call interp_inc(LND_IAU_Control, 'slc1_inc',increments%slc_inc(:,:,1),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'slc2_inc',increments%slc_inc(:,:,2),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'slc3_inc',increments%slc_inc(:,:,3),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'slc4_inc',increments%slc_inc(:,:,4),jbeg,jend) +! +! call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) +! call interp_inc(LND_IAU_Control, 'spfh2m_inc',increments%spfh2m_inc(:,:,1),jbeg,jend) +!! call interp_inc_sfc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend, n_soill) +! call close_ncfile(ncid) +! deallocate (wk3) +! km = km_store +! +!end subroutine read_iau_forcing +! +!subroutine interp_inc(LND_IAU_Control, field_name, var, jbeg, jend) +!! interpolate increment from GSI gaussian grid to cubed sphere +!! everying is on the A-grid, earth relative +! type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control +! character(len=*), intent(in) :: field_name +! real, dimension(is:ie,js:je,1:km), intent(inout) :: var +! integer, intent(in) :: jbeg,jend +! integer:: i1, i2, j1, k,j,i,ierr +! call check_var_exists(ncid, field_name, ierr) +! if (ierr == 0) then +! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) +! else +! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(field_name),' found, assuming zero' +! wk3 = 0. +! endif +! do k=1,km +! do j=js,je +! do i=is,ie +! i1 = id1(i,j) +! i2 = id2(i,j) +! j1 = jdc(i,j) +! var(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+& +! s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) +! enddo +! enddo +! enddo +!end subroutine interp_inc !> This routine is copied from 'fv_treat_da_inc.F90 by Xi.Chen ! copying it here, due to inability to 'include' from the original module when the land iau mod is called through CCPP frameowrk diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 06e188364..3611a3e46 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -23,7 +23,7 @@ module noahmpdrv private - public :: noahmpdrv_init, noahmpdrv_run !, noahmpdrv_timestep_init + public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_timestep_init, noahmpdrv_timestep_finalize ! IAU data and control type (lnd_iau_control_type) :: LND_IAU_Control @@ -292,7 +292,7 @@ subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp ! endif ! endif - call lnd_iau_mod_finalize() !LND_IAU_Control%finalize() + call lnd_iau_mod_finalize(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !LND_IAU_Control%finalize() end subroutine noahmpdrv_timestep_finalize diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index e99535399..e3915e5e2 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -1,7 +1,9 @@ [ccpp-table-properties] name = noahmpdrv type = scheme - dependencies = funcphys.f90,machine.F,sfc_diff.f,module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90,set_soilveg.f + dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F + dependencies = module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90 + dependencies = ../Noah/set_soilveg.f dependencies = sim_nc_mod_lnd.F90,lnd_iau_mod.F90 ######################################################################## From 3afbaa2d75d37ecff0407fe78133fefaa972ad4a Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 18 Apr 2024 12:44:56 -0400 Subject: [PATCH 019/154] deallocate at noahmpdrv_finalize --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 299 ++---------------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 67 ++-- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 20 ++ 3 files changed, 87 insertions(+), 299 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 4734468de..395e2b011 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -1,40 +1,28 @@ !*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . +!> TODO: replace with appropriate licence for CCPP +!* GNU Lesser General Public License +!* . !*********************************************************************** -!> The routine 'remapcoeff is copied from 'fv_treat_da_inc.F90 by Xi.Chen -! and put at the end of this module because, due to the compile order in CCPP framework it wasn't possible to 'include' -! the original module when the land iau mod is called through CCPP frameowrk +!> @brief Land IAU (Incremental Analysis Update) module, +!> adopted from the FV3 IAU mode for the dyamical core +!> to be able to do IAU updates for NoahMP states, soil/snow temperature +! +!> REVISION HISTORY: +!> March, 2024: Tseganeh Z. Gichamo (EMC ): Modify for land ! - - -!------------------------------------------------------------------------------- -!> @brief incremental analysis update module +!> FV3 IAU mod +!> @date 09/13/2017 !> @author Xi.Chen - author of fv_treat_da_inc.F90 !> @author Philip Pegion -!> @date 09/13/2017 -! -!> REVISION HISTORY: !> 09/13/2017 - Initial Version based on fv_treat_da_inc.F90 !------------------------------------------------------------------------------- +!* Note: The routine 'remapcoeff is copied from 'fv_treat_da_inc.F90 by Xi.Chen +!* and put at the end of this module because, due to the compile order in CCPP framework it wasn't possible to 'include' +!* the original module when the land iau mod is called through CCPP frameowrk + + #ifdef OVERLOAD_R4 #define _GET_VAR1 get_var1_real #else @@ -43,35 +31,12 @@ module lnd_iau_mod -! use fms_mod, only: file_exist -! use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe -! use mpp_domains_mod, only: domain2d -! use constants_mod, only: pi=>pi_8 -! use fv_arrays_mod, only: R_GRID !, & - ! fv_atmos_type, & - ! fv_grid_type, & - ! fv_grid_bounds_type, & -! use fv_mp_mod, only: is_master use sim_nc_mod_lnd, only: open_ncfile, & close_ncfile, & get_ncdim1, & get_var1_double, & get_var3_r4, & get_var1_real, check_var_exists -! #ifdef GFS_TYPES -! use GFS_typedefs, only: IPD_init_type => GFS_init_type, & -! LND_IAU_Control_type => GFS_control_type, & -! kind_phys, & -! IPD_Data_type => GFS_data_type -! #else -! use IPD_typedefs, only: IPD_init_type, LND_IAU_Control_type, & -! kind_phys => IPD_kind_phys -! #endif - -! use block_control_mod, only: block_control_type -! use fv_treat_da_inc_mod, only: remap_coef -! use tracer_manager_mod, only: get_tracer_names,get_tracer_index, get_number_tracers -! use field_manager_mod, only: MODEL_ATMOS use machine, only: kind_phys, kind_dyn use physcons, only: pi => con_pi @@ -81,9 +46,7 @@ module lnd_iau_mod private real,allocatable::s2c(:,:,:) -! real:: s2c(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je,4) -! integer, dimension(Atm(1)%bd%is:Atm(1)%bd%ie,Atm(1)%bd%js:Atm(1)%bd%je):: & -! id1, id2, jdc + integer,allocatable,dimension(:,:) :: id1,id2,jdc real :: deg2rad,dt,rdt @@ -91,24 +54,17 @@ module lnd_iau_mod integer:: jbeg, jend integer :: n_soill, n_snowl !1.27.24 soil and snow layers - logical :: do_lnd_iau !do_lnd_iau_inc + logical :: do_lnd_iau integer :: is, ie, js, je integer :: npz !, ntracers -! character(len=32), allocatable :: tracer_names(:) -! integer, allocatable :: tracer_indicies(:) ! real(kind=4), allocatable:: wk3(:, :,:,:) - real(kind=4), allocatable:: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :), wk3_t2m(:, :, :, :), wk3_q2m(:, :, :, :) + real(kind=4), allocatable:: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :), & + wk3_t2m(:, :, :, :), wk3_q2m(:, :, :, :) type iau_internal_data_type - ! real,allocatable :: ua_inc(:,:,:) - ! real,allocatable :: va_inc(:,:,:) - ! real,allocatable :: temp_inc(:,:,:) - ! real,allocatable :: delp_inc(:,:,:) - ! real,allocatable :: delz_inc(:,:,:) - ! real,allocatable :: tracer_inc(:,:,:,:) - real,allocatable :: stc_inc(:,:,:) + real,allocatable :: stc_inc(:,:,:) real,allocatable :: slc_inc(:,:,:) real,allocatable :: tmp2m_inc(:,:, :) real,allocatable :: spfh2m_inc(:,:, :) @@ -120,7 +76,6 @@ module lnd_iau_mod real,allocatable :: tmp2m_inc(:,:,:) real,allocatable :: spfh2m_inc(:,:,:) logical :: in_interval = .false. - ! logical :: drymassfixer = .false. end type lnd_iau_external_data_type type iau_state_type @@ -159,39 +114,17 @@ module lnd_iau_mod character(len=:), pointer, dimension(:) :: input_nml_file => null() ! null() !< character string containing full namelist - ! integer :: logunit - !--- calendars and time parameters and activation triggers - ! real(kind=kind_phys) :: dtf !< dynamics timestep in seconds - ! integer :: idat(1:8) !< initialization date and time - ! !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) - ! integer :: jdat(1:8) !< current forecast date and time - ! !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) - ! real(kind=kind_phys) :: sec !< seconds since model initialization - ! real(kind=kind_phys) :: phour !< previous forecast hour - ! real(kind=kind_phys) :: zhour !< previous hour diagnostic buckets emptied - ! integer :: kdt !< current forecast iteration - ! logical :: first_time_step !< flag signaling first time step for time integration routine end type lnd_iau_control_type type(iau_state_type) :: IAU_state - public lnd_iau_control_type, lnd_iau_external_data_type, lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing, lnd_iau_mod_finalize + public lnd_iau_control_type, lnd_iau_external_data_type, lnd_iau_mod_set_control, & + lnd_iau_mod_init, lnd_iau_mod_getiauforcing, lnd_iau_mod_finalize contains -subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, mpi_root, isc, jsc, nx, ny, nblks, blksz, & +subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, mpi_root, & + isc, jsc, nx, ny, nblks, blksz, & lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) !nlunit type (lnd_iau_control_type), intent(inout) :: LND_IAU_Control @@ -215,7 +148,7 @@ subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, m integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads - !> 3.9.24 these are not available through the CCPP interface so need to read them from namelist file + !> 3.9.24 these are not available through the CCPP interface so need to read from namelist file !> vars to read from namelist logical :: do_lnd_iau = .false. real(kind=kind_phys) :: lnd_iau_delthrs = 0 !< iau time interval (to scale increments) @@ -308,10 +241,7 @@ end subroutine lnd_iau_mod_set_control subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) ! integer, intent(in) :: me, mpi_root type (lnd_iau_control_type), intent(in) :: LND_IAU_Control - type (lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data - ! type (IPD_init_type), intent(in) :: Init_parm - ! type (IPD_Data_type), dimension(:), intent(in) :: IPD_Data - ! integer, intent(in) :: ncols + type (lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon real(kind_phys), dimension(:), intent(in) :: xlat ! latitude character(len=*), intent(out) :: errmsg @@ -319,17 +249,13 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, ! local character(len=128) :: fname - ! real, dimension(:,:,:), allocatable:: u_inc, v_inc real(kind=kind_dyn), allocatable:: lat(:), lon(:),agrid(:,:,:) real(kind=kind_phys) sx,wx,wt,normfact,dtp - integer:: ib, i, j, k, nstep, kstep integer:: i1, i2, j1 - logical:: found integer nfilesall integer, allocatable :: idt(:) - real (kind=kind_phys), allocatable :: Init_parm_xlon (:, :) real (kind=kind_phys), allocatable :: Init_parm_xlat (:, :) integer :: nlon, nlat @@ -363,20 +289,14 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, ib = ib+nlon ! enddo enddo - ! call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers) - ! allocate (tracer_names(ntracers)) - ! allocate (tracer_indicies(ntracers)) - ! do i = 1, ntracers - ! call get_tracer_names(MODEL_ATMOS, i, tracer_names(i)) - ! tracer_indicies(i) = get_tracer_index(MODEL_ATMOS,tracer_names(i)) - ! enddo + allocate(s2c(is:ie,js:je,4)) allocate(id1(is:ie,js:je)) allocate(id2(is:ie,js:je)) allocate(jdc(is:ie,js:je)) allocate(agrid(is:ie,js:je,2)) -! determine number of increment files to read, and the valid forecast hours +! determine number of increment files to read, and the valid forecast hours nfilesall = size(LND_IAU_Control%iau_inc_files) nfiles = 0 if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print*,'in lnd_iau_init incfile1 iaufhr1 ', & @@ -474,12 +394,6 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) - ! allocate(LND_IAU_Data%ua_inc(is:ie, js:je, km)) - ! allocate(LND_IAU_Data%va_inc(is:ie, js:je, km)) - ! allocate(LND_IAU_Data%temp_inc(is:ie, js:je, km)) - ! allocate(LND_IAU_Data%delp_inc(is:ie, js:je, km)) - ! allocate(LND_IAU_Data%delz_inc(is:ie, js:je, km)) - ! allocate(LND_IAU_Data%tracer_inc(is:ie, js:je, km,ntracers)) allocate(LND_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(LND_IAU_Data%slc_inc(is:ie, js:je, km)) allocate(LND_IAU_Data%tmp2m_inc(is:ie, js:je, 1)) @@ -513,7 +427,7 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, iau_state%wt_normfact = (2*nstep+1)/normfact endif -!3.22.24 MB wants to read all increments files at iau init +!3.22.24 Mike B wants to read all increments files at iau init time ! Find bounding latitudes: jbeg = jm-1 jend = 2 @@ -710,7 +624,6 @@ subroutine updateiauforcing(LND_IAU_Control, LND_IAU_Data, wt) enddo end subroutine updateiauforcing - subroutine setiauforcing(LND_IAU_Control, LND_IAU_Data, wt) implicit none @@ -846,123 +759,11 @@ subroutine interp_inc_at_timestep(LND_IAU_Control, km_in, wk3_in, var, errmsg, e enddo end subroutine interp_inc_at_timestep -!subroutine read_iau_forcing(LND_IAU_Control, increments, fname, errmsg, errflg) !, fname_sfc) -! type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control -! type(iau_internal_data_type), intent(inout):: increments -! character(len=*), intent(in) :: fname -!! character(len=*), intent(in), optional :: fname_sfc -! character(len=*), intent(out) :: errmsg -! integer, intent(out) :: errflg -!!locals -!! real, dimension(:,:,:), allocatable:: u_inc, v_inc -! -! integer:: i, j, k, l, npz -! integer:: i1, i2, j1 -! integer:: jbeg, jend -!! real(kind=R_GRID), dimension(2):: p1, p2, p3 -!! real(kind=R_GRID), dimension(3):: e1, e2, ex, ey -! -!! logical :: found -! integer :: is, ie, js, je, km_store -! logical :: exists -! -! !Errors messages handled through CCPP error handling variables -! errmsg = '' -! errflg = 0 -! -! is = LND_IAU_Control%isc -! ie = is + LND_IAU_Control%nx-1 -! js = LND_IAU_Control%jsc -! je = js + LND_IAU_Control%ny-1 -! -! deg2rad = pi/180. -! -! npz = LND_IAU_Control%lsoil -! -! inquire (file=trim(fname), exist=exists) -! if (exists) then -!! if( file_exist(fname) ) then -! call open_ncfile( fname, ncid ) ! open the file -! else -! ! call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '& -! ! //trim(fname)//' for DA increment does not exist') -! errmsg = 'FATAL Error in read_iau_forcing: Expected file '//trim(fname)//' for DA increment does not exist' -! errflg = 1 -! return -! endif -! -! ! Find bounding latitudes: -! jbeg = jm-1; jend = 2 -! do j=js,je -! do i=is,ie -! j1 = jdc(i,j) -! jbeg = min(jbeg, j1) -! jend = max(jend, j1+1) -! enddo -! enddo -! -! km_store = km -! km = 1 ! n_soill Currently each soil layer increment is saved separately -! allocate ( wk3(1:im,jbeg:jend, 1:km) ) -! ! call interp_inc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend) !TODO check var name -! call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'soilt2_inc',increments%stc_inc(:,:,2),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'soilt3_inc',increments%stc_inc(:,:,3),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'soilt4_inc',increments%stc_inc(:,:,4),jbeg,jend) -! -! call interp_inc(LND_IAU_Control, 'slc1_inc',increments%slc_inc(:,:,1),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'slc2_inc',increments%slc_inc(:,:,2),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'slc3_inc',increments%slc_inc(:,:,3),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'slc4_inc',increments%slc_inc(:,:,4),jbeg,jend) -! -! call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) -! call interp_inc(LND_IAU_Control, 'spfh2m_inc',increments%spfh2m_inc(:,:,1),jbeg,jend) -!! call interp_inc_sfc('stc_inc',increments%stc_inc(:,:,:),jbeg,jend, n_soill) -! call close_ncfile(ncid) -! deallocate (wk3) -! km = km_store -! -!end subroutine read_iau_forcing -! -!subroutine interp_inc(LND_IAU_Control, field_name, var, jbeg, jend) -!! interpolate increment from GSI gaussian grid to cubed sphere -!! everying is on the A-grid, earth relative -! type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control -! character(len=*), intent(in) :: field_name -! real, dimension(is:ie,js:je,1:km), intent(inout) :: var -! integer, intent(in) :: jbeg,jend -! integer:: i1, i2, j1, k,j,i,ierr -! call check_var_exists(ncid, field_name, ierr) -! if (ierr == 0) then -! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) -! else -! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(field_name),' found, assuming zero' -! wk3 = 0. -! endif -! do k=1,km -! do j=js,je -! do i=is,ie -! i1 = id1(i,j) -! i2 = id2(i,j) -! j1 = jdc(i,j) -! var(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+& -! s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) -! enddo -! enddo -! enddo -!end subroutine interp_inc - -!> This routine is copied from 'fv_treat_da_inc.F90 by Xi.Chen +!> This subroutine is copied from 'fv_treat_da_inc.F90 by Xi.Chen ! copying it here, due to inability to 'include' from the original module when the land iau mod is called through CCPP frameowrk -! -!> @author Xi.Chen -!> @date 02/12/2016 -! -! REVISION HISTORY: -! 02/12/2016 - Initial Version +!> @author Xi.Chen !> @date 02/12/2016 !============================================================================= !>@brief The subroutine 'remap_coef' calculates the coefficients for horizonal regridding. - subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & im, jm, lon, lat, id1, id2, jdc, s2c, agrid ) @@ -1040,42 +841,6 @@ subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & 5000 continue ! j-loop end subroutine remap_coef - -! subroutine interp_inc_sfc(LND_IAU_Control, field_name,var,jbeg,jend, k_lv) !is_land_in) -! ! interpolate increment from GSI gaussian grid to cubed sphere -! ! everying is on the A-grid, earth relative -! type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control -! character(len=*), intent(in) :: field_name -! integer, intent(in) :: jbeg, jend, k_lv -! real, dimension(is:ie,js:je,1:k_lv), intent(inout) :: var -! ! logical, intent(in), optional :: is_land_in -! ! logical :: is_land -! integer:: i1, i2, j1, k,j,i,ierr -! ! k_lv = km -! ! is_land = .false. -! ! if ( present(is_land_in) ) is_land = is_land_in -! ! if (is_land) k_lv = n_soill -! call check_var_exists(ncid, field_name, ierr) -! if (ierr == 0) then -! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,k_lv, wk3 ) !k, wk3 ) -! else -! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(field_name),' found, assuming zero' -! wk3 = 0. -! endif - -! do k=1,k_lv !km -! do j=js,je -! do i=is,ie -! i1 = id1(i,j) -! i2 = id2(i,j) -! j1 = jdc(i,j) -! var(i,j,k) = s2c(i,j,1)*wk3(i1,j1 ,k) + s2c(i,j,2)*wk3(i2,j1 ,k)+& -! s2c(i,j,3)*wk3(i2,j1+1,k) + s2c(i,j,4)*wk3(i1,j1+1,k) -! enddo -! enddo -! enddo - -! end subroutine interp_inc_sfc end module lnd_iau_mod diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 3611a3e46..e811d57f9 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -12,6 +12,7 @@ module noahmpdrv use module_sf_noahmplsm + ! 3.5.24 for use in IAU use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type, & lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing, & @@ -23,7 +24,8 @@ module noahmpdrv private - public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_timestep_init, noahmpdrv_timestep_finalize + public :: noahmpdrv_init, noahmpdrv_run, & + noahmpdrv_timestep_init, noahmpdrv_timestep_finalize, noahmpdrv_finalize ! IAU data and control type (lnd_iau_control_type) :: LND_IAU_Control @@ -147,13 +149,6 @@ end subroutine noahmpdrv_init !! subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, - ! lsnow_lsm, lsnowl, & - ! ncols, isc, jsc, nx, ny, nblks, - ! & - ! blksz, xlon, xlat, - ! & !& garea, iyrlen, julian, - ! vegtype, idveg, & - ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, use machine, only: kind_phys @@ -170,19 +165,9 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! integer, intent(in) :: lsnow_lsm - ! integer , intent(in) :: lsnowl ! lower bound for snow level arrays - ! integer, intent(in) :: ncols, isc, jsc, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks - ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz - ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude - - ! --- local variable - ! integer :: nb, im ! vertical soil layer dimension - ! IAU update real,allocatable :: stc_inc_flat(:,:) - real,allocatable :: slc_inc_flat(:,:) + ! real,allocatable :: slc_inc_flat(:,:) ! real,allocatable :: tmp2m_inc_flat(:) ! real,allocatable :: spfh2m_inc_flat(:) integer :: j, k, ib @@ -225,20 +210,19 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! local variable to copy blocked data LND_IAU_Data%stc_inc allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols + ! allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols ib = 1 do j = 1, LND_IAU_Control%ny !ny do k = 1, km stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) - slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) + ! slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) enddo ! ib = 1 ! do j = 1, LND_IAU_Control%ny !ny ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) - ib = ib + LND_IAU_Control%nx !nlon enddo @@ -249,16 +233,17 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo endif endif !IAU increments are in units of 1/sec !LND_IAU_Control%dtp +!* only updating soil temp do k = 1, km stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp - slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp enddo ! t2mmp = t2mmp + & ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp ! q2mp = q2mp + & ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp - deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) endif @@ -268,7 +253,7 @@ end subroutine noahmpdrv_timestep_init !! \brief This subroutine is called after noahmpdrv_run !! to free up allocated memory !! \section arg_table_noahmpdrv_timestep_finalize Argument Table -!! \htmlinclude noahmpdrv_timestep_init.html +!! \htmlinclude noahmpdrv_timestep_finalize.html !! subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, @@ -284,17 +269,35 @@ subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp ! --- Initialize CCPP error handling variables errmsg = '' errflg = 0 + + !> note the IAU deallocate happens at the noahmpdrv_finalize - ! ! delt=GFS_Control%dtf - ! if ((LND_IAU_Control%dtp - delt) > 0.0001) then - ! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - ! print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp - ! endif - ! endif + end subroutine noahmpdrv_timestep_finalize + + !> \ingroup NoahMP_LSM +!! \brief This subroutine mirrors noahmpdrv_init +!! to free up allocated memory in IAU_init (noahmdrv_init) +!! \section arg_table_noahmpdrv_finalize Argument Table +!! \htmlinclude noahmpdrv_finalize.html +!! + subroutine noahmpdrv_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, + + use machine, only: kind_phys + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: j, k, ib + + ! --- Initialize CCPP error handling variables + errmsg = '' + errflg = 0 call lnd_iau_mod_finalize(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !LND_IAU_Control%finalize() - end subroutine noahmpdrv_timestep_finalize + end subroutine noahmpdrv_finalize !> \ingroup NoahMP_LSM !! \brief This subroutine is the main CCPP entry point for the NoahMP LSM. diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index e3915e5e2..04a847993 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -302,6 +302,26 @@ type = integer intent = out +####################################################################### +[ccpp-arg-table] + name = noahmpdrv_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + ####################################################################### [ccpp-arg-table] name = noahmpdrv_run From 8a8b17bb830a6b6b4fd4a184ea6b3e54c265329d Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 18 Apr 2024 12:58:00 -0400 Subject: [PATCH 020/154] comment nc mod --- physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 b/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 index 9dcb096ef..6f2bd1ad2 100644 --- a/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 +++ b/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 @@ -19,6 +19,9 @@ !* If not, see . !*********************************************************************** +!> March 2024: This is a copy of S-J Lin's sim_nc_mod +!> renamed it sim_nc_mod_lnd to faciliate compilaton + !>@brief The module 'sim_nc' is a netcdf file reader. !>@details The code is necessary to circumvent issues with the FMS !! 'read_data' utility, which opens too many files and uses excessive From 9d9036f4f7fafcbfeab1b5aae79fd469cc52de06 Mon Sep 17 00:00:00 2001 From: tsga Date: Wed, 22 May 2024 18:30:45 +0000 Subject: [PATCH 021/154] mv config up --- config/ccpp_prebuild_config.py | 250 ----------------- driver/CCPP_driver.F90 | 254 ------------------ .../suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml | 96 ------- suites/suite_FV3_GFS_v17_p8_ugwpv1.xml | 95 ------- 4 files changed, 695 deletions(-) delete mode 100755 config/ccpp_prebuild_config.py delete mode 100644 driver/CCPP_driver.F90 delete mode 100644 suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml delete mode 100644 suites/suite_FV3_GFS_v17_p8_ugwpv1.xml diff --git a/config/ccpp_prebuild_config.py b/config/ccpp_prebuild_config.py deleted file mode 100755 index 6080e1769..000000000 --- a/config/ccpp_prebuild_config.py +++ /dev/null @@ -1,250 +0,0 @@ -#!/usr/bin/env python - -# CCPP prebuild config for GFDL Finite-Volume Cubed-Sphere Model (FV3) - - -############################################################################### -# Definitions # -############################################################################### - -HOST_MODEL_IDENTIFIER = "FV3" - -# Add all files with metadata tables on the host model side and in CCPP, -# relative to basedir = top-level directory of host model. This includes -# kind and type definitions used in CCPP physics. Also add any internal -# dependencies of these files to the list. -VARIABLE_DEFINITION_FILES = [ - # actual variable definition files - 'framework/src/ccpp_types.F90', - 'physics/physics/machine.F', - 'physics/physics/radsw_param.f', - 'physics/physics/radlw_param.f', - 'physics/physics/h2o_def.f', - 'physics/physics/radiation_surface.f', - 'physics/physics/module_ozphys.F90', - 'data/CCPP_typedefs.F90', - 'data/GFS_typedefs.F90', - 'data/CCPP_data.F90', - ] - -TYPEDEFS_NEW_METADATA = { - 'ccpp_types' : { - 'ccpp_t' : 'cdata', - 'ccpp_types' : '', - }, - 'machine' : { - 'machine' : '', - }, - 'module_radlw_parameters' : { - 'module_radsw_parameters' : '', - }, - 'module_radlw_parameters' : { - 'module_radlw_parameters' : '', - }, - 'module_ozphys' : { - 'module_ozphys' : '', - 'ty_ozphys' : '', - }, - 'CCPP_typedefs' : { - 'GFS_interstitial_type' : 'GFS_Interstitial(cdata%thrd_no)', - 'GFDL_interstitial_type' : 'GFDL_interstitial', - 'CCPP_typedefs' : '', - }, - 'CCPP_data' : { - 'CCPP_data' : '', - }, - 'GFS_typedefs' : { - 'GFS_control_type' : 'GFS_Control', - 'GFS_data_type' : 'GFS_Data(cdata%blk_no)', - 'GFS_diag_type' : 'GFS_Data(cdata%blk_no)%Intdiag', - 'GFS_tbd_type' : 'GFS_Data(cdata%blk_no)%Tbd', - 'GFS_sfcprop_type' : 'GFS_Data(cdata%blk_no)%Sfcprop', - 'GFS_coupling_type' : 'GFS_Data(cdata%blk_no)%Coupling', - 'GFS_statein_type' : 'GFS_Data(cdata%blk_no)%Statein', - 'GFS_cldprop_type' : 'GFS_Data(cdata%blk_no)%Cldprop', - 'GFS_radtend_type' : 'GFS_Data(cdata%blk_no)%Radtend', - 'GFS_grid_type' : 'GFS_Data(cdata%blk_no)%Grid', - 'GFS_stateout_type' : 'GFS_Data(cdata%blk_no)%Stateout', - 'GFS_typedefs' : '', - }, - } - -# Add all physics scheme files relative to basedir -SCHEME_FILES = [ - # Relative path to source (from where ccpp_prebuild.py is called) : [ list of physics sets in which scheme may be called ]; - # current restrictions are that each scheme can only belong to one physics set, and all schemes within one group in the - # suite definition file have to belong to the same physics set - 'physics/physics/GFS_DCNV_generic_pre.F90', - 'physics/physics/GFS_DCNV_generic_post.F90', - 'physics/physics/GFS_GWD_generic_pre.F90', - 'physics/physics/GFS_GWD_generic_post.F90', - 'physics/physics/GFS_MP_generic_pre.F90', - 'physics/physics/GFS_MP_generic_post.F90', - 'physics/physics/GFS_PBL_generic_pre.F90', - 'physics/physics/GFS_PBL_generic_post.F90', - 'physics/physics/GFS_SCNV_generic_pre.F90', - 'physics/physics/GFS_SCNV_generic_post.F90', - 'physics/physics/GFS_debug.F90', - 'physics/physics/GFS_phys_time_vary.fv3.F90', - 'physics/physics/GFS_rad_time_vary.fv3.F90', - 'physics/physics/GFS_radiation_surface.F90', - 'physics/physics/GFS_rrtmg_post.F90', - 'physics/physics/GFS_rrtmg_pre.F90', - 'physics/physics/GFS_rrtmg_setup.F90', - 'physics/physics/GFS_stochastics.F90', - 'physics/physics/GFS_suite_interstitial_rad_reset.F90', - 'physics/physics/GFS_suite_interstitial_phys_reset.F90', - 'physics/physics/GFS_suite_interstitial_1.F90', - 'physics/physics/GFS_suite_interstitial_2.F90', - 'physics/physics/GFS_suite_stateout_reset.F90', - 'physics/physics/GFS_suite_stateout_update.F90', - 'physics/physics/GFS_suite_interstitial_3.F90', - 'physics/physics/GFS_suite_interstitial_4.F90', - 'physics/physics/GFS_suite_interstitial_5.F90', - 'physics/physics/GFS_surface_generic_pre.F90', - 'physics/physics/GFS_surface_generic_post.F90', - 'physics/physics/GFS_surface_composites_pre.F90', - 'physics/physics/GFS_surface_composites_inter.F90', - 'physics/physics/GFS_surface_composites_post.F90', - 'physics/physics/GFS_surface_loop_control_part1.F90', - 'physics/physics/GFS_surface_loop_control_part2.F90', - 'physics/physics/GFS_time_vary_pre.fv3.F90', - 'physics/physics/GFS_physics_post.F90', - 'physics/physics/cires_ugwp.F90', - 'physics/physics/cires_ugwp_post.F90', - 'physics/physics/unified_ugwp.F90', - 'physics/physics/unified_ugwp_post.F90', - 'physics/physics/ugwpv1_gsldrag.F90', - 'physics/physics/ugwpv1_gsldrag_post.F90', - 'physics/physics/cnvc90.f', - 'physics/physics/cs_conv_pre.F90', - 'physics/physics/cs_conv.F90', - 'physics/physics/cs_conv_post.F90', - 'physics/physics/cs_conv_aw_adj.F90', - 'physics/physics/cu_ntiedtke_pre.F90', - 'physics/physics/cu_ntiedtke.F90', - 'physics/physics/cu_ntiedtke_post.F90', - 'physics/physics/dcyc2t3.f', - 'physics/physics/drag_suite.F90', - 'physics/physics/shoc.F90', - 'physics/physics/get_prs_fv3.F90', - 'physics/physics/get_phi_fv3.F90', - 'physics/physics/gfdl_cloud_microphys.F90', - 'physics/physics/fv_sat_adj.F90', - 'physics/physics/gfdl_sfc_layer.F90', - 'physics/physics/zhaocarr_gscond.f', - 'physics/physics/gwdc_pre.f', - 'physics/physics/gwdc.f', - 'physics/physics/gwdc_post.f', - 'physics/physics/gwdps.f', - 'physics/physics/h2ophys.f', - 'physics/physics/samfdeepcnv.f', - 'physics/physics/samfshalcnv.f', - 'physics/physics/sascnvn.F', - 'physics/physics/shalcnv.F', - 'physics/physics/maximum_hourly_diagnostics.F90', - 'physics/physics/m_micro.F90', - 'physics/physics/m_micro_pre.F90', - 'physics/physics/m_micro_post.F90', - 'physics/physics/cu_gf_driver_pre.F90', - 'physics/physics/cu_gf_driver.F90', - 'physics/physics/cu_gf_driver_post.F90', - 'physics/physics/cu_c3_driver_pre.F90', - 'physics/physics/cu_c3_driver.F90', - 'physics/physics/cu_c3_driver_post.F90', - 'physics/physics/hedmf.f', - 'physics/physics/moninshoc.f', - 'physics/physics/satmedmfvdif.F', - 'physics/physics/satmedmfvdifq.F', - 'physics/physics/shinhongvdif.F90', - 'physics/physics/ysuvdif.F90', - 'physics/physics/mynnedmf_wrapper.F90', - 'physics/physics/mynnsfc_wrapper.F90', - 'physics/physics/sgscloud_radpre.F90', - 'physics/physics/sgscloud_radpost.F90', - 'physics/physics/myjsfc_wrapper.F90', - 'physics/physics/myjpbl_wrapper.F90', - 'physics/physics/mp_thompson_pre.F90', - 'physics/physics/mp_thompson.F90', - 'physics/physics/mp_thompson_post.F90', - 'physics/physics/mp_nssl.F90', - 'physics/physics/zhaocarr_precpd.f', - 'physics/physics/radlw_main.F90', - 'physics/physics/radsw_main.F90', - 'physics/physics/rascnv.F90', - 'physics/physics/rayleigh_damp.f', - 'physics/physics/rrtmg_lw_post.F90', - 'physics/physics/rrtmg_lw_pre.F90', - 'physics/physics/rrtmg_sw_post.F90', - 'physics/physics/rad_sw_pre.F90', - 'physics/physics/sfc_diag.f', - 'physics/physics/sfc_diag_post.F90', - 'physics/physics/lsm_ruc.F90', - 'physics/physics/sfc_cice.f', - 'physics/physics/sfc_diff.f', - 'physics/physics/lsm_noah.f', - 'physics/physics/noahmpdrv.F90', - 'physics/physics/noahmpdrv_time_vary.F90', - 'physics/physics/flake_driver.F90', - 'physics/physics/clm_lake.f90', - 'physics/physics/sfc_nst_pre.f90', - 'physics/physics/sfc_nst.f90', - 'physics/physics/sfc_nst_post.f90', - 'physics/physics/sfc_ocean.F', - 'physics/physics/sfc_sice.f', - # HAFS FER_HIRES - 'physics/physics/mp_fer_hires.F90', - # SMOKE - 'physics/physics/smoke_dust/rrfs_smoke_wrapper.F90', - 'physics/physics/smoke_dust/rrfs_smoke_postpbl.F90', - # RRTMGP - 'physics/physics/rrtmgp_aerosol_optics.F90', - 'physics/physics/rrtmgp_lw_main.F90', - 'physics/physics/rrtmgp_sw_main.F90', - 'physics/physics/GFS_rrtmgp_setup.F90', - 'physics/physics/GFS_rrtmgp_pre.F90', - 'physics/physics/GFS_cloud_diagnostics.F90', - 'physics/physics/GFS_rrtmgp_cloud_mp.F90', - 'physics/physics/GFS_rrtmgp_cloud_overlap.F90', - 'physics/physics/GFS_rrtmgp_post.F90' - ] - -# Default build dir, relative to current working directory, -# if not specified as command-line argument -DEFAULT_BUILD_DIR = 'build' - -# Auto-generated makefile/cmakefile snippets that contain all type definitions -TYPEDEFS_MAKEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.mk' -TYPEDEFS_CMAKEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.cmake' -TYPEDEFS_SOURCEFILE = '{build_dir}/physics/CCPP_TYPEDEFS.sh' - -# Auto-generated makefile/cmakefile snippets that contain all schemes -SCHEMES_MAKEFILE = '{build_dir}/physics/CCPP_SCHEMES.mk' -SCHEMES_CMAKEFILE = '{build_dir}/physics/CCPP_SCHEMES.cmake' -SCHEMES_SOURCEFILE = '{build_dir}/physics/CCPP_SCHEMES.sh' - -# Auto-generated makefile/cmakefile snippets that contain all caps -CAPS_MAKEFILE = '{build_dir}/physics/CCPP_CAPS.mk' -CAPS_CMAKEFILE = '{build_dir}/physics/CCPP_CAPS.cmake' -CAPS_SOURCEFILE = '{build_dir}/physics/CCPP_CAPS.sh' - -# Directory where to put all auto-generated physics caps -CAPS_DIR = '{build_dir}/physics' - -# Directory where the suite definition files are stored -SUITES_DIR = 'suites' - -# Directory where to write static API to -STATIC_API_DIR = '{build_dir}/physics' -STATIC_API_CMAKEFILE = '{build_dir}/physics/CCPP_STATIC_API.cmake' -STATIC_API_SOURCEFILE = '{build_dir}/physics/CCPP_STATIC_API.sh' - -# Directory for writing HTML pages generated from metadata files -# used by metadata2html.py for generating scientific documentation -METADATA_HTML_OUTPUT_DIR = '{build_dir}/physics/physics/docs' - -# HTML document containing the model-defined CCPP variables -HTML_VARTABLE_FILE = '{build_dir}/physics/CCPP_VARIABLES_FV3.html' - -# LaTeX document containing the provided vs requested CCPP variables -LATEX_VARTABLE_FILE = '{build_dir}/framework/doc/DevelopersGuide/CCPP_VARIABLES_FV3.tex' diff --git a/driver/CCPP_driver.F90 b/driver/CCPP_driver.F90 deleted file mode 100644 index 6c633fc4d..000000000 --- a/driver/CCPP_driver.F90 +++ /dev/null @@ -1,254 +0,0 @@ -module CCPP_driver - - use ccpp_types, only: ccpp_t - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - use CCPP_data, only: cdata_tile, & - cdata_domain, & - cdata_block, & - ccpp_suite, & - GFS_control, & - GFS_data - - implicit none - -!--------------------------------------------------------! -! Pointer to CCPP containers defined in CCPP_data ! -!--------------------------------------------------------! - type(ccpp_t), pointer :: cdata => null() - -!--------------------------------------------------------! -! Flag for non-uniform block sizes (last block smaller) ! -! and number of OpenMP threads (with special thread ! -! number nthrdsX in case of non-uniform block sizes) ! -!--------------------------------------------------------! - logical :: non_uniform_blocks - integer :: nthrds, nthrdsX - -!---------------- -! Public Entities -!---------------- -! functions - public CCPP_step -! module variables - public non_uniform_blocks - - CONTAINS -!******************************************************************************************* - -!------------------------------- -! CCPP step -!------------------------------- - subroutine CCPP_step (step, nblks, ierr) - -#ifdef _OPENMP - use omp_lib -#endif - - implicit none - - character(len=*), intent(in) :: step - integer, intent(in) :: nblks - integer, intent(out) :: ierr - ! Local variables - integer :: nb, nt, ntX - integer :: ierr2 - ! DH* 20210104 - remove kdt_rad when code to clear diagnostic buckets is removed - integer :: kdt_rad - - ierr = 0 - - if (trim(step)=="init") then - - ! Get and set number of OpenMP threads (module - ! variable) that are available to run physics -#ifdef _OPENMP - nthrds = omp_get_max_threads() -#else - nthrds = 1 -#endif - - ! For non-uniform blocksizes, we use index nthrds+1 - ! for the interstitial data type with different length - if (non_uniform_blocks) then - nthrdsX = nthrds+1 - else - nthrdsX = nthrds - end if - - ! For physics running over the entire domain, block and thread - ! number are not used; set to safe values - cdata_domain%blk_no = 1 - cdata_domain%thrd_no = 1 - - ! Allocate cdata structures for blocks and threads - if (.not.allocated(cdata_block)) allocate(cdata_block(1:nblks,1:nthrdsX)) - - ! Loop over all blocks and threads - do nt=1,nthrdsX - do nb=1,nblks - ! Assign the correct block and thread numbers - cdata_block(nb,nt)%blk_no = nb - cdata_block(nb,nt)%thrd_no = nt - end do - end do - - else if (trim(step)=="physics_init") then - - ! Since the physics init step is independent of the blocking structure, - ! we can use cdata_domain. And since we don't use threading on the host - ! model side, we can allow threading inside the physics init routines. - GFS_control%nthreads = nthrds - - call ccpp_physics_init(cdata_domain, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_init" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if - - ! Timestep init = time_vary - else if (trim(step)=="timestep_init") then - - ! Since the physics timestep init step is independent of the blocking structure, - ! we can use cdata_domain. And since we don't use threading on the host - ! model side, we can allow threading inside the timestep init (time_vary) routines. - GFS_control%nthreads = nthrds - - call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite), group_name="time_vary", ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group time_vary" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if - - ! call timestep_init for "physics" - call ccpp_physics_timestep_init(cdata_domain, suite_name=trim(ccpp_suite),group_name="physics", ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_timestep_init for group physics" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! DH* 20210104 - this block of code will be removed once the CCPP framework ! - ! fully supports handling diagnostics through its metadata, work in progress ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !--- determine if radiation diagnostics buckets need to be cleared - if (nint(GFS_control%fhzero*3600) >= nint(max(GFS_control%fhswr,GFS_control%fhlwr))) then - if (mod(GFS_control%kdt,GFS_control%nszero) == 1) then - do nb = 1,nblks - call GFS_data(nb)%Intdiag%rad_zero(GFS_control) - end do - endif - else - kdt_rad = nint(min(GFS_control%fhswr,GFS_control%fhlwr)/GFS_control%dtp) - if (mod(GFS_control%kdt,kdt_rad) == 1) then - do nb = 1,nblks - call GFS_data(nb)%Intdiag%rad_zero(GFS_control) - enddo - endif - endif - - !--- determine if physics diagnostics buckets need to be cleared - if ((mod(GFS_control%kdt-1,GFS_control%nszero)) == 0) then - do nb = 1,nblks - call GFS_data(nb)%Intdiag%phys_zero(GFS_control) - end do - endif - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! *DH 20210104 ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! Radiation, physics and and stochastic physics - threaded regions using blocked data structures - else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then - - ! Set number of threads available to physics schemes to one, - ! because threads are used on the host model side for blocking - GFS_control%nthreads = 1 - -!$OMP parallel num_threads (nthrds) & -!$OMP default (shared) & -!$OMP private (nb,nt,ntX,ierr2) & -!$OMP reduction (+:ierr) -#ifdef _OPENMP - nt = omp_get_thread_num()+1 -#else - nt = 1 -#endif -!$OMP do schedule (dynamic,1) - do nb = 1,nblks - ! For non-uniform blocks, the last block has a different (shorter) - ! length than the other blocks; use special CCPP_Interstitial(nthrdsX) - if (non_uniform_blocks .and. nb==nblks) then - ntX = nthrdsX - else - ntX = nt - end if - !--- Call CCPP radiation/physics/stochastics group - call ccpp_physics_run(cdata_block(nb,ntX), suite_name=trim(ccpp_suite), group_name=trim(step), ierr=ierr2) - if (ierr2/=0) then - write(0,'(2a,3(a,i4),a)') "An error occurred in ccpp_physics_run for group ", trim(step), & - ", block ", nb, " and thread ", nt, " (ntX=", ntX, "):" - write(0,'(a)') trim(cdata_block(nb,ntX)%errmsg) - ierr = ierr + ierr2 - end if - end do -!$OMP end do - -!$OMP end parallel - if (ierr/=0) return - - ! Timestep finalize = time_vary - else if (trim(step)=="timestep_finalize") then - - ! Since the physics timestep finalize step is independent of the blocking structure, - ! we can use cdata_domain. And since we don't use threading on the host model side, - ! we can allow threading inside the timestep finalize (time_vary) routines. - GFS_control%nthreads = nthrds - - call ccpp_physics_timestep_finalize(cdata_domain, suite_name=trim(ccpp_suite), group_name="time_vary", ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_timestep_finalize for group time_vary" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if - - ! Physics finalize - else if (trim(step)=="physics_finalize") then - - ! Since the physics finalize step is independent of the blocking structure, - ! we can use cdata_domain. And since we don't use threading on the host - ! model side, we can allow threading inside the physics finalize routines. - GFS_control%nthreads = nthrds - - call ccpp_physics_finalize(cdata_domain, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(0,'(a)') "An error occurred in ccpp_physics_finalize" - write(0,'(a)') trim(cdata_domain%errmsg) - return - end if - - ! Finalize - else if (trim(step)=="finalize") then - ! Deallocate cdata structure for blocks and threads - if (allocated(cdata_block)) deallocate(cdata_block) - - else - - write(0,'(2a)') 'Error, undefined CCPP step ', trim(step) - ierr = 1 - return - - end if - - end subroutine CCPP_step - -end module CCPP_driver diff --git a/suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml b/suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml deleted file mode 100644 index 011a93867..000000000 --- a/suites/suite_FV3_GFS_v17_coupled_p8_ugwpv1.xml +++ /dev/null @@ -1,96 +0,0 @@ - - - - - - - GFS_time_vary_pre - GFS_rrtmg_setup - GFS_rad_time_vary - GFS_phys_time_vary - noahmpdrv_time_vary - - - - - GFS_suite_interstitial_rad_reset - GFS_rrtmg_pre - GFS_radiation_surface - rad_sw_pre - rrtmg_sw - rrtmg_sw_post - rrtmg_lw_pre - rrtmg_lw - rrtmg_lw_post - GFS_rrtmg_post - - - - - GFS_suite_interstitial_phys_reset - GFS_suite_stateout_reset - get_prs_fv3 - GFS_suite_interstitial_1 - GFS_surface_generic_pre - GFS_surface_composites_pre - dcyc2t3 - GFS_surface_composites_inter - GFS_suite_interstitial_2 - - - - sfc_diff - GFS_surface_loop_control_part1 - sfc_nst_pre - sfc_nst - sfc_nst_post - noahmpdrv - sfc_cice - sfc_sice - GFS_surface_loop_control_part2 - - - - GFS_surface_composites_post - sfc_diag - sfc_diag_post - GFS_surface_generic_post - GFS_PBL_generic_pre - satmedmfvdifq - GFS_PBL_generic_post - GFS_GWD_generic_pre - ugwpv1_gsldrag - ugwpv1_gsldrag_post - GFS_GWD_generic_post - GFS_suite_stateout_update - h2ophys - get_phi_fv3 - GFS_suite_interstitial_3 - GFS_DCNV_generic_pre - samfdeepcnv - GFS_DCNV_generic_post - GFS_SCNV_generic_pre - samfshalcnv - GFS_SCNV_generic_post - GFS_suite_interstitial_4 - cnvc90 - GFS_MP_generic_pre - mp_thompson_pre - - - mp_thompson - - - mp_thompson_post - GFS_MP_generic_post - maximum_hourly_diagnostics - - - - - GFS_stochastics - GFS_physics_post - - - - diff --git a/suites/suite_FV3_GFS_v17_p8_ugwpv1.xml b/suites/suite_FV3_GFS_v17_p8_ugwpv1.xml deleted file mode 100644 index bca1b018d..000000000 --- a/suites/suite_FV3_GFS_v17_p8_ugwpv1.xml +++ /dev/null @@ -1,95 +0,0 @@ - - - - - - - GFS_time_vary_pre - GFS_rrtmg_setup - GFS_rad_time_vary - GFS_phys_time_vary - noahmpdrv_time_vary - - - - - GFS_suite_interstitial_rad_reset - GFS_rrtmg_pre - GFS_radiation_surface - rad_sw_pre - rrtmg_sw - rrtmg_sw_post - rrtmg_lw_pre - rrtmg_lw - rrtmg_lw_post - GFS_rrtmg_post - - - - - GFS_suite_interstitial_phys_reset - GFS_suite_stateout_reset - get_prs_fv3 - GFS_suite_interstitial_1 - GFS_surface_generic_pre - GFS_surface_composites_pre - dcyc2t3 - GFS_surface_composites_inter - GFS_suite_interstitial_2 - - - - sfc_diff - GFS_surface_loop_control_part1 - sfc_nst_pre - sfc_nst - sfc_nst_post - noahmpdrv - sfc_sice - GFS_surface_loop_control_part2 - - - - GFS_surface_composites_post - sfc_diag - sfc_diag_post - GFS_surface_generic_post - GFS_PBL_generic_pre - satmedmfvdifq - GFS_PBL_generic_post - GFS_GWD_generic_pre - ugwpv1_gsldrag - ugwpv1_gsldrag_post - GFS_GWD_generic_post - GFS_suite_stateout_update - h2ophys - get_phi_fv3 - GFS_suite_interstitial_3 - GFS_DCNV_generic_pre - samfdeepcnv - GFS_DCNV_generic_post - GFS_SCNV_generic_pre - samfshalcnv - GFS_SCNV_generic_post - GFS_suite_interstitial_4 - cnvc90 - GFS_MP_generic_pre - mp_thompson_pre - - - mp_thompson - - - mp_thompson_post - GFS_MP_generic_post - maximum_hourly_diagnostics - - - - - GFS_stochastics - GFS_physics_post - - - - From f04a01dd238d2d0d0d8fd1d5d0a87c79094999fc Mon Sep 17 00:00:00 2001 From: tsga Date: Wed, 22 May 2024 20:12:23 +0000 Subject: [PATCH 022/154] delte _time_vary mods --- .../Land/Noahmp/noahmpdrv_time_vary.F90 | 340 ------------------ .../Land/Noahmp/noahmpdrv_time_vary.meta | 230 ------------ 2 files changed, 570 deletions(-) delete mode 100644 physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 delete mode 100644 physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 deleted file mode 100644 index ea9805cd4..000000000 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.F90 +++ /dev/null @@ -1,340 +0,0 @@ -#define CCPP -!> \file noahmpdrv_time_vary.F90 -!! This file contains the IAU Updates for the NoahMP land surface scheme driver. - -!>\defgroup NoahMP_LSM NoahMP LSM Model -!! \brief This is the NoahMP LSM the IAU Updates module - -!> This module contains the CCPP-compliant IAU Update module for NoahMP land surface model driver. -!> The noahmpdrv_time_vary module is an alternative to calling the IAU updates directly from within the noahmpdrv module -!> The current "CCPP_driver" module's ccpp_step(step="timestep_init") function call only handles group="time_vary" and not "physics" -! -module noahmpdrv_time_vary - - ! use module_sf_noahmplsm - ! 3.5.24 for use in IAU - use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type,& - lnd_iau_mod_set_control, lnd_iau_mod_init,lnd_iau_mod_getiauforcing - - implicit none - - private - - public :: noahmpdrv_time_vary_init, noahmpdrv_time_vary_timestep_init !, noahmpdrv_time_vary_run -! public :: noahmpdrv_time_vary_timestep_finalize, noahmpdrv_time_vary_finalize - - ! IAU data and control - type (lnd_iau_control_type) :: LND_IAU_Control - type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks - - contains - -!> \ingroup NoahMP_LSM -!! \brief This subroutine is called during the CCPP initialization phase to -!! initialize Land IAU Control and Land IAU Data structures. -!! \section arg_table_noahmpdrv_time_vary_init Argument Table -!! \htmlinclude noahmpdrv_time_vary_init.html -!! - subroutine noahmpdrv_time_vary_init(lsm, lsm_noahmp, me, mpi_root, & - fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, nblks, & - blksz, xlon, xlat, & - lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) - - use machine, only: kind_phys - !use GFS_typedefs, only: GFS_control_type - ! use GFS_typedefs, only: GFS_data_type - - implicit none - - integer, intent(in) :: lsm - integer, intent(in) :: lsm_noahmp - integer, intent(in) :: me ! mpi_rank - integer, intent(in) :: mpi_root ! = GFS_Control%master - character(*), intent(in) :: fn_nml - character(len=:), intent(in), dimension(:), pointer :: input_nml_file - integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks - integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz - real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - real(kind_phys), dimension(:), intent(in) :: xlat ! latitude - integer, intent(in) :: lsoil, lsnow_lsm - real(kind=kind_phys), intent(in) :: dtp, fhour - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! type(gfs_data_type), dimension(:), intent(inout) :: GFS_Data ! !(one:) - ! type(gfs_control_type), intent(in) :: GFS_Control - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! 3.7.24 init iau for land - call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & - lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) -! print*, 'proc errmsg, errflg after set control', me, errmsg, errflg -! print*, 'proc iau_control isc, nx, dtp fhour', me, LND_IAU_Control%isc, LND_IAU_Control%nx, & -! LND_IAU_Control%dtp, LND_IAU_Control%fhour -! print*, 'proc iau_control incfiles(1)', me, LND_IAU_Control%iau_inc_files(1) -! stop - call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) - !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval - print*, 'proc nblks blksize(1) after lnd_iau_mod_init ', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) - - end subroutine noahmpdrv_time_vary_init - -!> \ingroup NoahMP_LSM -!! \brief This subroutine is called before noahmpdrv_run timestep to update -!! states with iau increments -!! \section arg_table_noahmpdrv_time_vary_timestep_init Argument Table -!! \htmlinclude noahmpdrv_time_vary_timestep_init.html -!! - subroutine noahmpdrv_time_vary_timestep_init (itime, fhour, delt, km, & !me, mpi_root, - stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, - - use machine, only: kind_phys - - implicit none - - ! integer, intent(in) :: me !mpi_rank - ! integer, intent(in) :: mpi_root ! = GFS_Control%master - integer , intent(in) :: itime !current forecast iteration - real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) - real(kind=kind_phys) , intent(in) :: delt ! time interval [s] - integer , intent(in) :: km !vertical soil layer dimension - real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] - real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! --- local variable - ! integer :: nb, im ! vertical soil layer dimension - - ! IAU update - real,allocatable :: stc_inc_flat(:,:) - real,allocatable :: slc_inc_flat(:,:) - ! real,allocatable :: tmp2m_inc_flat(:) - ! real,allocatable :: spfh2m_inc_flat(:) - integer :: j, k, ib - ! --- end declaration - - ! --- Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - !> update current forecast hour - ! GFS_control%jdat(:) = jdat(:) - LND_IAU_Control%fhour=fhour - - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & - " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp - endif - - !> 3.7.24 read iau increments - call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) - if (errflg .ne. 0) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" - print*, errmsg - endif - return - endif - - !> update with iau increments - if (LND_IAU_Data%in_interval) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "adding land iau increments " - endif - - if (LND_IAU_Control%lsoil .ne. km) then - write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km - errflg = 1 - return - endif - - ! local variable to copy blocked data LND_IAU_Data%stc_inc - allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols - ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols - ib = 1 - do j = 1, LND_IAU_Control%ny !ny - do k = 1, km - stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) - slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) - enddo - ! ib = 1 - ! do j = 1, LND_IAU_Control%ny !ny - ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) - ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) - - ib = ib + LND_IAU_Control%nx !nlon - enddo - - ! delt=GFS_Control%dtf - if ((LND_IAU_Control%dtp - delt) > 0.0001) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_timevary_tstep delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp - endif - endif - !IAU increments are in units of 1/sec !LND_IAU_Control%dtp - do k = 1, km - stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp - slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp - enddo - ! t2mmp = t2mmp + & - ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp - ! q2mp = q2mp + & - ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp - - deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) - - endif - - end subroutine noahmpdrv_time_vary_timestep_init - - -! !> \ingroup NoahMP_LSM -! !! \brief -! !! \section arg_table_noahmpdrv_time_vary_run Argument Table -! !! \htmlinclude noahmpdrv_time_vary_run.html -! !! -! !! \section general_noahmpdrv_time_vary_run -! !! @{ -! !! - Initialize CCPP error handling variables. - -! subroutine noahmpdrv_time_vary_run(nb, im, km, lsnowl, itime, fhour, errmsg, errflg) -! ! ! --- inputs: -! ! ! --- in/outs: -! ! weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & -! ! ! --- Noah MP specific -! ! ! --- outputs: -! ! ) - -! use machine , only : kind_phys - -! implicit none - -! ! -! ! --- CCPP interface fields (in call order) -! ! -! integer , intent(in) :: nb !=cdata%blk_no, -! integer , intent(in) :: im ! horiz dimension and num of used pts -! integer , intent(in) :: km ! vertical soil layer dimension -! integer , intent(in) :: lsnowl ! lower bound for snow level arrays -! integer , intent(in) :: itime ! NOT USED current forecast iteration -! real(kind=kind_phys) , intent(in) :: fhour ! currentforecast time (hr) - -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! ground surface skin temperature [K] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tprcp ! total precipitation [m] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: srflag ! snow/rain flag for precipitation -! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! total soil moisture content [m3/m3] -! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soil temp [K] -! ! real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc ! liquid soil moisture [m3/m3] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: canopy ! canopy moisture content [mm] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: trans ! total plant transpiration [m/s] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: tsurf ! surface skin temperature [K] -! ! real(kind=kind_phys), dimension(:) , intent(inout) :: zorl ! surface roughness [cm] - -! character(len=*) , intent(out) :: errmsg -! integer , intent(out) :: errflg -! ! -! ! --- end declaration -! ! - -! ! -! ! --- Initialize CCPP error handling variables -! ! -! errmsg = '' -! errflg = 0 - -! ! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then -! ! print*,"nb ",nb," itime ",itime," GFScont%fhour ",fhour," iauCon%fhour",LND_IAU_Control%fhour," delt ",delt," iauCont%dtp",LND_IAU_Control%dtp -! ! endif -! ! ! 3.7.24 read iau increments -! ! call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) -! ! if (errflg .ne. 0) return -! ! ! update with iau increments -! ! if (LND_IAU_Data%in_interval) then -! ! if (LND_IAU_Control%lsoil .ne. km) then -! ! write(errmsg, *)'in noahmpdrv_run, lnd_iau_mod update increments:LND_IAU_Control%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km -! ! errflg = 1 -! ! return -! ! endif -! ! ! LND_IAU_Data%stc_inc(is:ie, js:je, km)) size of (nx, ny) -! ! ! xlatin(im) stc(im,km) slc() t2mmp(:) q2mp(im) km=n_soill, im = -! ! ! GFS_Control%blksz(cdata%blk_no) -! ! ! >> need to get (cdata%blk_no from function call - -! ! ! local variable to copy blocked data LND_IAU_Data%stc_inc -! ! allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols -! ! allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols -! ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols -! ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols -! ! ib = 1 -! ! do j = 1, LND_IAU_Control%ny !ny -! ! do k = 1, km -! ! stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%stc_inc(:,j,k) -! ! slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j,k) -! ! enddo -! ! ! ib = 1 -! ! ! do j = 1, LND_IAU_Control%ny !ny -! ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%tmp2m_inc(:,j,1) -! ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) = LND_IAU_Data%spfh2m_inc(:,j,1) -! ! ib = ib + LND_IAU_Control%nx !nlon -! ! enddo - -! ! !IAU increments are in units of 1/sec !LND_IAU_Control%dtp -! ! ! delt=GFS_Control%dtf -! ! if ((LND_IAU_Control%dtp - delt) > 0.0001) then -! ! if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then -! ! print*, "Warning time step used in noahmpdrv_run delt ",delt," different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp -! ! endif -! ! endif -! ! do k = 1, km -! ! stc(:,k)=stc(:,k)+stc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp -! ! slc(:,k)=slc(:,k)+slc_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1, k)*delt !LND_IAU_Control%dtp -! ! enddo -! ! t2mmp = t2mmp+tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp -! ! q2mp = q2mp +spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+im-1)*delt !LND_IAU_Control%dtp - -! ! deallocate(stc_inc_flat, slc_inc_flat, tmp2m_inc_flat, spfh2m_inc_flat) - -! ! end if -! end subroutine noahmpdrv_time_vary_run - -! subroutine noahmpdrv_time_vary_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, - - -! use machine, only: kind_phys - -! implicit none - -! character(len=*), intent(out) :: errmsg -! integer, intent(out) :: errflg - -! ! --- Initialize CCPP error handling variables -! errmsg = '' -! errflg = 0 - -! end subroutine noahmpdrv_time_vary_timestep_finalize - -! subroutine noahmpdrv_time_vary_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, - - -! use machine, only: kind_phys - -! implicit none - -! character(len=*), intent(out) :: errmsg -! integer, intent(out) :: errflg - -! ! --- Initialize CCPP error handling variables -! errmsg = '' -! errflg = 0 - -! end subroutine noahmpdrv_time_vary_finalize - -end module noahmpdrv_time_vary diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta deleted file mode 100644 index 246fe1f5e..000000000 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv_time_vary.meta +++ /dev/null @@ -1,230 +0,0 @@ -[ccpp-table-properties] - name = noahmpdrv_time_vary - type = scheme - dependencies = funcphys.f90, machine.F - dependencies = sim_nc_mod_lnd.F90, lnd_iau_mod.F90 - -######################################################################## -[ccpp-arg-table] - name = noahmpdrv_time_vary_init - type = scheme -[lsm] - standard_name = control_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in -[lsm_noahmp] - standard_name = identifier_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in -[mpi_root] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in -[fn_nml] - standard_name = filename_of_namelist - long_name = namelist filename - units = none - type = character - dimensions = () - kind = len=* - intent = in -[input_nml_file] - standard_name = filename_of_internal_namelist - long_name = amelist filename for internal file reads - units = none - type = character - dimensions = (ccpp_constant_one:number_of_lines_in_internal_namelist) - kind = len=256 - intent = in -[isc] - standard_name = starting_x_index_for_this_mpi_rank - long_name = starting index in the x direction for this MPI rank - units = count - dimensions = () - type = integer - intent = in -[jsc] - standard_name = starting_y_index_for_this_mpi_rank - long_name = starting index in the y direction for this MPI rank - units = count - dimensions = () - type = integer - intent = in -[ncols] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nx] - standard_name = number_of_points_in_x_direction_for_this_mpi_rank - long_name = number of points in x direction for this MPI rank - units = count - dimensions = () - type = integer - intent = in -[ny] - standard_name = number_of_points_in_y_direction_for_this_mpi_rank - long_name = number of points in y direction for this MPI rank - units = count - dimensions = () - type = integer - intent = in -[nblks] - standard_name = ccpp_block_count - long_name = for explicit data blocking: number of blocks - units = count - dimensions = () - type = integer - intent = in -[blksz] - standard_name = ccpp_block_sizes - long_name = for explicit data blocking: block sizes of all blocks - units = count - dimensions = (ccpp_constant_one:ccpp_block_count) - type = integer - intent = in -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[xlat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[lsoil] - standard_name = vertical_dimension_of_soil - long_name = number of soil layers - units = count - dimensions = () - type = integer - intent = in -[lsnow_lsm] - standard_name = vertical_dimension_of_surface_snow - long_name = maximum number of snow layers for land surface model - units = count - dimensions = () - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = noahmpdrv_time_vary_timestep_init - type = scheme -[itime] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in -[delt] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[km] - standard_name = vertical_dimension_of_soil - long_name = soil vertical layer dimension - units = count - dimensions = () - type = integer - intent = in -[stc] - standard_name = soil_temperature - long_name = soil temperature - units = K - dimensions = (horizontal_dimension,vertical_dimension_of_soil) - type = real - kind = kind_phys - intent = inout -[slc] - standard_name = volume_fraction_of_unfrozen_water_in_soil - long_name = liquid soil moisture - units = frac - dimensions = (horizontal_dimension,vertical_dimension_of_soil) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out From f8b96b546e914a9e2afec97c7284784505661ddd Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 25 May 2024 15:30:16 -0400 Subject: [PATCH 023/154] add nc90 funcs, cleanup, add comments --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 726 +++++++++--------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 137 ++-- 2 files changed, 425 insertions(+), 438 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 395e2b011..d25aa3877 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -5,102 +5,78 @@ !*********************************************************************** !> @brief Land IAU (Incremental Analysis Update) module, -!> adopted from the FV3 IAU mode for the dyamical core -!> to be able to do IAU updates for NoahMP states, soil/snow temperature -! -!> REVISION HISTORY: -!> March, 2024: Tseganeh Z. Gichamo (EMC ): Modify for land -! -!> FV3 IAU mod -!> @date 09/13/2017 -!> @author Xi.Chen - author of fv_treat_da_inc.F90 -!> @author Philip Pegion -!> 09/13/2017 - Initial Version based on fv_treat_da_inc.F90 -!------------------------------------------------------------------------------- - -!* Note: The routine 'remapcoeff is copied from 'fv_treat_da_inc.F90 by Xi.Chen -!* and put at the end of this module because, due to the compile order in CCPP framework it wasn't possible to 'include' -!* the original module when the land iau mod is called through CCPP frameowrk +!> for the NoahMP soil/snow temperature (can be extended to include soil moisture) +!! \section land_iau_mod +!> - reads settings from namelist file (which indicates if IAU increments are available or not) +!> - reads in DA increments from GSI/JEDI DA at the start of (the DA) cycle +!> - interpolates increments to FV3 grid points (if increments are in Gaussian grid) +!> - interpolates temporally (with filter, weights if required by configuration) +!> - updates states with the interpolated increments -#ifdef OVERLOAD_R4 -#define _GET_VAR1 get_var1_real -#else -#define _GET_VAR1 get_var1_double -#endif - -module lnd_iau_mod +!> March, 2024: Tseganeh Z. Gichamo, (EMC) based on the FV3 IAU mod +!> by Xi.Chen and Philip Pegion, PSL +!------------------------------------------------------------------------------- - use sim_nc_mod_lnd, only: open_ncfile, & - close_ncfile, & - get_ncdim1, & - get_var1_double, & - get_var3_r4, & - get_var1_real, check_var_exists +module land_iau_mod use machine, only: kind_phys, kind_dyn use physcons, only: pi => con_pi + use netcdf implicit none private - real,allocatable::s2c(:,:,:) + real(kind=kind_phys),allocatable::s2c(:,:,:) integer,allocatable,dimension(:,:) :: id1,id2,jdc - real :: deg2rad,dt,rdt + real(kind=kind_phys) :: deg2rad,dt,rdt integer :: im,jm,km,nfiles,ncid integer:: jbeg, jend - integer :: n_soill, n_snowl !1.27.24 soil and snow layers - logical :: do_lnd_iau + integer :: n_soill, n_snowl !soil and snow layers + logical :: do_land_iau integer :: is, ie, js, je - integer :: npz !, ntracers - -! real(kind=4), allocatable:: wk3(:, :,:,:) - real(kind=4), allocatable:: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :), & - wk3_t2m(:, :, :, :), wk3_q2m(:, :, :, :) - - type iau_internal_data_type - real,allocatable :: stc_inc(:,:,:) - real,allocatable :: slc_inc(:,:,:) - real,allocatable :: tmp2m_inc(:,:, :) - real,allocatable :: spfh2m_inc(:,:, :) - end type iau_internal_data_type - - type lnd_iau_external_data_type - real,allocatable :: stc_inc(:,:,:) - real,allocatable :: slc_inc(:,:,:) - real,allocatable :: tmp2m_inc(:,:,:) - real,allocatable :: spfh2m_inc(:,:,:) + integer :: npz + + real(kind=kind_phys), allocatable:: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) + + type land_iau_internal_data_type + real(kind=kind_phys),allocatable :: stc_inc(:,:,:) + real(kind=kind_phys),allocatable :: slc_inc(:,:,:) + end type land_iau_internal_data_type + + type land_iau_external_data_type + real(kind=kind_phys),allocatable :: stc_inc(:,:,:) + real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. - end type lnd_iau_external_data_type + end type land_iau_external_data_type - type iau_state_type - type(iau_internal_data_type):: inc1 - type(iau_internal_data_type):: inc2 + type land_iau_state_type + type(land_iau_internal_data_type):: inc1 + type(land_iau_internal_data_type):: inc2 real(kind=kind_phys) :: hr1 real(kind=kind_phys) :: hr2 real(kind=kind_phys) :: wt real(kind=kind_phys) :: wt_normfact - end type iau_state_type + end type land_iau_state_type - type lnd_iau_control_type + type land_iau_control_type integer :: isc integer :: jsc integer :: nx integer :: ny integer :: nblks - ! integer :: blksz ! this could vary for the last block - integer, allocatable :: blksz(:) + integer, allocatable :: blksz(:) ! this could vary for the last block integer, allocatable :: blk_strt_indx(:) integer :: lsoil !< number of soil layers ! this is the max dim (TBC: check it is consitent for noahmpdrv) integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model - logical :: do_lnd_iau + logical :: do_land_iau real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours character(len=240) :: iau_inc_files(7)! list of increment files real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files @@ -115,19 +91,19 @@ module lnd_iau_mod !< for use with internal file reads integer :: input_nml_file_length ! 3.9.24 these are not available through the CCPP interface so need to read from namelist file + !> these are not available through the CCPP interface so need to read them from namelist file !> vars to read from namelist - logical :: do_lnd_iau = .false. - real(kind=kind_phys) :: lnd_iau_delthrs = 0 !< iau time interval (to scale increments) - character(len=240) :: lnd_iau_inc_files(7) = '' !< list of increment files - real(kind=kind_phys) :: lnd_iaufhrs(7) = -1 !< forecast hours associated with increment files - logical :: lnd_iau_filter_increments = .false. !< filter IAU increments + logical :: do_land_iau = .false. + real(kind=kind_phys) :: land_iau_delthrs = 0 !< iau time interval (to scale increments) + character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files + real(kind=kind_phys) :: land_iaufhrs(7) = -1 !< forecast hours associated with increment files + logical :: land_iau_filter_increments = .false. !< filter IAU increments - NAMELIST /lnd_iau_nml/ do_lnd_iau, lnd_iau_delthrs, lnd_iau_inc_files, lnd_iaufhrs, lnd_iau_filter_increments !, lnd_iau_drymassfixer & + NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iaufhrs, land_iau_filter_increments !, lnd_iau_drymassfixer & !Errors messages handled through CCPP error handling variables errmsg = '' @@ -181,7 +157,7 @@ subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, m errflg = 1 return else - LND_IAU_Control%fn_nml = trim(fn_nml) ! maynot need this + Land_IAU_Control%fn_nml = trim(fn_nml) ! maynot need this open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios, iomsg=ioerrmsg) rewind(nlunit) read (nlunit, nml=lnd_iau_nml) @@ -203,53 +179,54 @@ subroutine lnd_iau_mod_set_control(LND_IAU_Control,fn_nml,input_nml_file_i,me, m write(6, lnd_iau_nml) endif - LND_IAU_Control%do_lnd_iau = do_lnd_iau - LND_IAU_Control%iau_delthrs = lnd_iau_delthrs - LND_IAU_Control%iau_inc_files = lnd_iau_inc_files - LND_IAU_Control%iaufhrs = lnd_iaufhrs - LND_IAU_Control%iau_filter_increments = lnd_iau_filter_increments - ! LND_IAU_Control%iau_drymassfixer = lnd_iau_drymassfixer - LND_IAU_Control%me = me - LND_IAU_Control%mpi_root = mpi_root - LND_IAU_Control%isc = isc - LND_IAU_Control%jsc = jsc - LND_IAU_Control%nx = nx - LND_IAU_Control%ny = ny - LND_IAU_Control%nblks = nblks - LND_IAU_Control%lsoil = lsoil - LND_IAU_Control%lsnow_lsm = lsnow_lsm - LND_IAU_Control%dtp = dtp - LND_IAU_Control%fhour = fhour - - LND_IAU_Control%input_nml_file = input_nml_file - LND_IAU_Control%input_nml_file_length = input_nml_file_length - - allocate(LND_IAU_Control%blksz(nblks)) - allocate(LND_IAU_Control%blk_strt_indx(nblks)) - !start index of each block, for flattened (ncol=nx*ny) arrays + Land_IAU_Control%do_land_iau = do_land_iau + Land_IAU_Control%iau_delthrs = land_iau_delthrs + Land_IAU_Control%iau_inc_files = land_iau_inc_files + Land_IAU_Control%iaufhrs = land_iaufhrs + Land_IAU_Control%iau_filter_increments = land_iau_filter_increments + ! Land_IAU_Control%iau_drymassfixer = lnd_iau_drymassfixer + Land_IAU_Control%me = me + Land_IAU_Control%mpi_root = mpi_root + Land_IAU_Control%isc = isc + Land_IAU_Control%jsc = jsc + Land_IAU_Control%nx = nx + Land_IAU_Control%ny = ny + Land_IAU_Control%nblks = nblks + Land_IAU_Control%lsoil = lsoil + Land_IAU_Control%lsnow_lsm = lsnow_lsm + Land_IAU_Control%dtp = dtp + Land_IAU_Control%fhour = fhour + + Land_IAU_Control%input_nml_file = input_nml_file + Land_IAU_Control%input_nml_file_length = input_nml_file_length + + allocate(Land_IAU_Control%blksz(nblks)) + allocate(Land_IAU_Control%blk_strt_indx(nblks)) + + ! Land_IAU_Control%blk_strt_indx: start index of each block, for flattened (ncol=nx*ny) arrays ! required in noahmpdriv_run to get subsection of the stc array for each - ! proc/thread + ! proces/thread ix = 1 do nb=1, nblks - LND_IAU_Control%blksz(nb) = blksz(nb) - LND_IAU_Control%blk_strt_indx(nb) = ix + Land_IAU_Control%blksz(nb) = blksz(nb) + Land_IAU_Control%blk_strt_indx(nb) = ix ix = ix + blksz(nb) enddo -end subroutine lnd_iau_mod_set_control +end subroutine land_iau_mod_set_control -subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) +subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) ! integer, intent(in) :: me, mpi_root - type (lnd_iau_control_type), intent(in) :: LND_IAU_Control - type (lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data - real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + type (land_iau_control_type), intent(in) :: Land_IAU_Control + type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data + real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! local character(len=128) :: fname - real(kind=kind_dyn), allocatable:: lat(:), lon(:),agrid(:,:,:) + real(kind=kind_phys), allocatable:: lat(:), lon(:),agrid(:,:,:) real(kind=kind_phys) sx,wx,wt,normfact,dtp integer:: ib, i, j, k, nstep, kstep integer:: i1, i2, j1 @@ -261,24 +238,26 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, integer :: nlon, nlat ! integer :: nb, ix, nblks, blksz logical :: exists + ! necdf vars + integer :: ncid, dimid, varid, status, IDIM !Errors messages handled through CCPP error handling variables errmsg = '' errflg = 0 - do_lnd_iau = LND_IAU_Control%do_lnd_iau - n_soill = LND_IAU_Control%lsoil !4 for sfc updates -! n_snowl = LND_IAU_Control%lsnowl - npz = LND_IAU_Control%lsoil + do_land_iau = Land_IAU_Control%do_land_iau + n_soill = Land_IAU_Control%lsoil !4 for sfc updates +! n_snowl = Land_IAU_Control%lsnowl + npz = Land_IAU_Control%lsoil - is = LND_IAU_Control%isc - ie = is + LND_IAU_Control%nx-1 - js = LND_IAU_Control%jsc - je = js + LND_IAU_Control%ny-1 - nlon = LND_IAU_Control%nx - nlat = LND_IAU_Control%ny - !nblks = LND_IAU_Control%nblks - !blksz = LND_IAU_Control%blksz(1) + is = Land_IAU_Control%isc + ie = is + Land_IAU_Control%nx-1 + js = Land_IAU_Control%jsc + je = js + Land_IAU_Control%ny-1 + nlon = Land_IAU_Control%nx + nlat = Land_IAU_Control%ny + !nblks = Land_IAU_Control%nblks + !blksz = Land_IAU_Control%blksz(1) allocate(Init_parm_xlon(nlon,nlat), Init_parm_xlat(nlon,nlat)) ib = 1 @@ -297,69 +276,65 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, allocate(agrid(is:ie,js:je,2)) ! determine number of increment files to read, and the valid forecast hours - nfilesall = size(LND_IAU_Control%iau_inc_files) + nfilesall = size(Land_IAU_Control%iau_inc_files) nfiles = 0 - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print*,'in lnd_iau_init incfile1 iaufhr1 ', & - trim(LND_IAU_Control%iau_inc_files(1)),LND_IAU_Control%iaufhrs(1) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,'in land_iau_init incfile1 iaufhr1 ', & + trim(Land_IAU_Control%iau_inc_files(1)),Land_IAU_Control%iaufhrs(1) do k=1,nfilesall - if (trim(LND_IAU_Control%iau_inc_files(k)) .eq. '' .or. LND_IAU_Control%iaufhrs(k) .lt. 0) exit - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print *,k, " ", trim(adjustl(LND_IAU_Control%iau_inc_files(k))) + if (trim(Land_IAU_Control%iau_inc_files(k)) .eq. '' .or. Land_IAU_Control%iaufhrs(k) .lt. 0) exit + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,k, " ", trim(adjustl(Land_IAU_Control%iau_inc_files(k))) endif nfiles = nfiles + 1 enddo - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'nfiles = ',nfiles + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'nfiles = ',nfiles if (nfiles < 1) then return endif if (nfiles > 1) then allocate(idt(nfiles-1)) - idt = LND_IAU_Control%iaufhrs(2:nfiles)-LND_IAU_Control%iaufhrs(1:nfiles-1) + idt = Land_IAU_Control%iaufhrs(2:nfiles)-Land_IAU_Control%iaufhrs(1:nfiles-1) do k=1,nfiles-1 - if (idt(k) .ne. LND_IAU_Control%iaufhrs(2)-LND_IAU_Control%iaufhrs(1)) then - print *,'in lnd_iau_init: forecast intervals in iaufhrs must be constant' + if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then + print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') - errmsg = 'Fatal error in lnd_iau_init. forecast intervals in iaufhrs must be constant' + errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' errflg = 1 return endif enddo deallocate(idt) endif - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'lnd_iau interval = ',LND_IAU_Control%iau_delthrs,' hours' - dt = (LND_IAU_Control%iau_delthrs*3600.) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' + dt = (Land_IAU_Control%iau_delthrs*3600.) rdt = 1.0/dt ! set up interpolation weights to go from GSI's gaussian grid to cubed sphere deg2rad = pi/180. - ! npz = LND_IAU_Control%levs - fname = 'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)) + ! npz = Land_IAU_Control%levs + fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1)) inquire (file=trim(fname), exist=exists) - if (exists) then - ! if( file_exist(fname) ) then - call open_ncfile( fname, ncid ) ! open the file -!TODO !change to Latitude - call get_ncdim1( ncid, 'longitude', im) - call get_ncdim1( ncid, 'latitude', jm) - ! call get_ncdim1( ncid, 'nsoill', km) + if (exists) then ! if( file_exist(fname) ) then + ! call open_ncfile( fname, ncid ) + status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file + call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) + if (errflg .ne. 0) return + call get_nc_dimlen(ncid, "longitude", im, errflg, errmsg) + if (errflg .ne. 0) return + call get_nc_dimlen(ncid, "latitude", jm, errflg, errmsg) + if (errflg .ne. 0) return km = n_soill - ! if (km.ne.npz) then - ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *, 'km = ', km - ! ! call mpp_error(FATAL, '==> Error in IAU_initialize: km is not equal to npz') - ! errmsg = 'Fatal Error in IAU_initialize: km is not equal to npz' - ! errflg = 1 - ! return - ! endif - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) write(*,*) fname, ' DA increment dimensions:', im,jm,km - - allocate ( lon(im) ) - allocate ( lat(jm) ) - - call _GET_VAR1 (ncid, 'longitude', im, lon ) - call _GET_VAR1 (ncid, 'latitude', jm, lat ) - call close_ncfile(ncid) - + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) write(*,*) fname, ' DA increment dimensions:', im,jm,km + allocate (lon(im) ) + allocate (lat(jm) ) + call get_var1d(ncid, im, "longitude", lon, errflg, errmsg) + if (errflg .ne. 0) return + call get_var1d(ncid, jm, "latitude", lat, errflg, errmsg) + if (errflg .ne. 0) return + status = nf90_close(ncid) + CALL netcdf_err(status, 'closing file: '//trim(fname) , errflg, errmsg) + if (errflg .ne. 0) return ! Convert to radians do i=1,im lon(i) = lon(i) * deg2rad @@ -368,18 +343,12 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, lat(j) = lat(j) * deg2rad enddo else - ! call mpp_error(FATAL,'==> Error in IAU_initialize: Expected file '& - ! //trim(fname)//' for DA increment does not exist') - errmsg = 'FATAL Error in IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' + errmsg = 'FATAL Error in Land_IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' errflg = 1 return endif ! Initialize lat-lon to Cubed bi-linear interpolation coeff: -! populate agrid -! print*,'is,ie,js,je=',is,ie,js,ie -! print*,'size xlon=',size(Init_parm%xlon(:,1)),size(Init_parm%xlon(1,:)) -! print*,'size agrid=',size(agrid(:,1,1)),size(agrid(1,:,1)),size(agrid(1,1,:)) do j = 1,size(Init_parm_xlon,2) do i = 1,size(Init_parm_xlon,1) ! print*,i,j,is-1+j,js-1+j @@ -394,22 +363,18 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) - allocate(LND_IAU_Data%stc_inc(is:ie, js:je, km)) - allocate(LND_IAU_Data%slc_inc(is:ie, js:je, km)) - allocate(LND_IAU_Data%tmp2m_inc(is:ie, js:je, 1)) - allocate(LND_IAU_Data%spfh2m_inc(is:ie, js:je, 1)) + allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) + allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) ! allocate arrays that will hold iau state - allocate (iau_state%inc1%stc_inc(is:ie, js:je, km)) - allocate (iau_state%inc1%slc_inc(is:ie, js:je, km)) - allocate (iau_state%inc1%tmp2m_inc(is:ie, js:je, 1)) - allocate (iau_state%inc1%spfh2m_inc (is:ie, js:je, 1)) - iau_state%hr1=LND_IAU_Control%iaufhrs(1) - iau_state%wt = 1.0 ! IAU increment filter weights (default 1.0) - iau_state%wt_normfact = 1.0 - if (LND_IAU_Control%iau_filter_increments) then + allocate (Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + allocate (Land_IAU_state%inc1%slc_inc(is:ie, js:je, km)) + Land_IAU_state%hr1=Land_IAU_Control%iaufhrs(1) + Land_IAU_state%wt = 1.0 ! IAU increment filter weights (default 1.0) + Land_IAU_state%wt_normfact = 1.0 + if (Land_IAU_Control%iau_filter_increments) then ! compute increment filter weights, sum to obtain normalization factor - dtp=LND_IAU_Control%dtp - nstep = 0.5*LND_IAU_Control%iau_delthrs*3600/dtp + dtp=Land_IAU_Control%dtp + nstep = 0.5*Land_IAU_Control%iau_delthrs*3600/dtp ! compute normalization factor for filter weights normfact = 0. do k=1,2*nstep+1 @@ -422,12 +387,11 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, wt = 1.0 endif normfact = normfact + wt - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt enddo - iau_state%wt_normfact = (2*nstep+1)/normfact + Land_IAU_state%wt_normfact = (2*nstep+1)/normfact endif -!3.22.24 Mike B wants to read all increments files at iau init time ! Find bounding latitudes: jbeg = jm-1 jend = 2 @@ -438,107 +402,88 @@ subroutine lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, jend = max(jend, j1+1) enddo enddo - - ! call read_iau_forcing(LND_IAU_Control,iau_state%inc1,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(1)), errmsg, errflg) + + ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid allocate (wk3_stc(nfiles, 1:im,jbeg:jend, 1:km)) - allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) - allocate (wk3_t2m(nfiles, 1:im,jbeg:jend, 1:1)) - allocate (wk3_q2m(nfiles, 1:im,jbeg:jend, 1:1)) + allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) do k=1, nfiles - call read_iau_forcing_all_timesteps(LND_IAU_Control, 'INPUT/'//trim(LND_IAU_Control%iau_inc_files(k)), errmsg, errflg, & - wk3_stc(k, :, :, :), wk3_slc(k, :, :, :), wk3_t2m(k, :, :, :), wk3_q2m(k, :, :, :)) + call read_iau_forcing_all_timesteps(Land_IAU_Control, & + 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(k)), errmsg, errflg, & + wk3_stc(k, :, :, :), wk3_slc(k, :, :, :)) enddo - ! call interp_inc(LND_IAU_Control, 'soilt1_inc',increments%stc_inc(:,:,1),jbeg,jend) - ! call interp_inc(LND_IAU_Control, 'tmp2m_inc',increments%tmp2m_inc(:,:,1),jbeg,jend) - call interp_inc_at_timestep(LND_IAU_Control, km, wk3_stc(1, :, :, :), iau_state%inc1%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, km, wk3_slc(1, :, :, :), iau_state%inc1%slc_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_t2m(1, :, :, :), iau_state%inc1%tmp2m_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_q2m(1, :, :, :), iau_state%inc1%spfh2m_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window - call setiauforcing(LND_IAU_Control, LND_IAU_Data, iau_state%wt) + call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%wt) endif - if (nfiles.GT.1) then !have multiple files, but only read in 2 at a time and interpoalte between them - allocate (iau_state%inc2%stc_inc(is:ie, js:je, km)) - allocate (iau_state%inc2%slc_inc(is:ie, js:je, km)) - allocate (iau_state%inc2%tmp2m_inc(is:ie, js:je, 1)) - allocate (iau_state%inc2%spfh2m_inc(is:ie, js:je, 1)) - iau_state%hr2=LND_IAU_Control%iaufhrs(2) - - ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(2)), errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, km, wk3_stc(2, :, :, :), iau_state%inc2%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, km, wk3_slc(2, :, :, :), iau_state%inc2%slc_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_t2m(2, :, :, :), iau_state%inc2%tmp2m_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_q2m(2, :, :, :), iau_state%inc2%spfh2m_inc, errmsg, errflg) + if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them + allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) + allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) + Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) endif ! print*,'end of IAU init',dt,rdt -end subroutine lnd_iau_mod_init +end subroutine land_iau_mod_init -subroutine lnd_iau_mod_finalize(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) +subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) implicit none - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + type (land_iau_control_type), intent(in) :: Land_IAU_Control + type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg if (allocated (wk3_stc)) deallocate (wk3_stc) if (allocated (wk3_slc)) deallocate (wk3_slc) - if (allocated (wk3_t2m)) deallocate (wk3_t2m) - if (allocated (wk3_q2m)) deallocate (wk3_q2m) - if (allocated(LND_IAU_Data%stc_inc)) deallocate (LND_IAU_Data%stc_inc) - if (allocated(LND_IAU_Data%slc_inc)) deallocate (LND_IAU_Data%slc_inc) - if (allocated(LND_IAU_Data%tmp2m_inc)) deallocate (LND_IAU_Data%tmp2m_inc) - if (allocated(LND_IAU_Data%spfh2m_inc)) deallocate (LND_IAU_Data%spfh2m_inc) + if (allocated(Land_IAU_Data%stc_inc)) deallocate (Land_IAU_Data%stc_inc) + if (allocated(Land_IAU_Data%slc_inc)) deallocate (Land_IAU_Data%slc_inc) - if (allocated(iau_state%inc1%stc_inc)) deallocate(iau_state%inc1%stc_inc) - if (allocated(iau_state%inc1%slc_inc)) deallocate(iau_state%inc1%slc_inc) - if (allocated(iau_state%inc1%tmp2m_inc)) deallocate(iau_state%inc1%tmp2m_inc) - if (allocated(iau_state%inc1%spfh2m_inc)) deallocate(iau_state%inc1%spfh2m_inc) + if (allocated(Land_IAU_state%inc1%stc_inc)) deallocate(Land_IAU_state%inc1%stc_inc) + if (allocated(Land_IAU_state%inc1%slc_inc)) deallocate(Land_IAU_state%inc1%slc_inc) - if (allocated(iau_state%inc2%stc_inc)) deallocate(iau_state%inc2%stc_inc) - if (allocated(iau_state%inc2%slc_inc)) deallocate(iau_state%inc2%slc_inc) - if (allocated(iau_state%inc2%tmp2m_inc)) deallocate(iau_state%inc2%tmp2m_inc) - if (allocated(iau_state%inc2%spfh2m_inc)) deallocate(iau_state%inc2%spfh2m_inc) + if (allocated(Land_IAU_state%inc2%stc_inc)) deallocate(Land_IAU_state%inc2%stc_inc) + if (allocated(Land_IAU_state%inc2%slc_inc)) deallocate(Land_IAU_state%inc2%slc_inc) -end subroutine lnd_iau_mod_finalize +end subroutine land_iau_mod_finalize - subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) + subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) implicit none - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data + type (land_iau_control_type), intent(in) :: Land_IAU_Control + type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys) t1,t2,sx,wx,wt,dtp - integer n,i,j,k,sphum,kstep,nstep,itnext + integer n,i,j,k,kstep,nstep,itnext - LND_IAU_Data%in_interval=.false. + Land_IAU_Data%in_interval=.false. if (nfiles.LE.0) then return endif if (nfiles .eq. 1) then - t1 = LND_IAU_Control%iaufhrs(1)-0.5*LND_IAU_Control%iau_delthrs - t2 = LND_IAU_Control%iaufhrs(1)+0.5*LND_IAU_Control%iau_delthrs + t1 = Land_IAU_Control%iaufhrs(1)-0.5*Land_IAU_Control%iau_delthrs + t2 = Land_IAU_Control%iaufhrs(1)+0.5*Land_IAU_Control%iau_delthrs else - t1 = LND_IAU_Control%iaufhrs(1) - t2 = LND_IAU_Control%iaufhrs(nfiles) + t1 = Land_IAU_Control%iaufhrs(1) + t2 = Land_IAU_Control%iaufhrs(nfiles) endif - if (LND_IAU_Control%iau_filter_increments) then + if (Land_IAU_Control%iau_filter_increments) then ! compute increment filter weight ! t1 is beginning of window, t2 end of window - ! LND_IAU_Control%fhour current time + ! Land_IAU_Control%fhour current time ! in window kstep=-nstep,nstep (2*nstep+1 total) - ! time step LND_IAU_Control%dtp - dtp=LND_IAU_Control%dtp - nstep = 0.5*LND_IAU_Control%iau_delthrs*3600/dtp + ! time step Land_IAU_Control%dtp + dtp=Land_IAU_Control%dtp + nstep = 0.5*Land_IAU_Control%iau_delthrs*3600/dtp ! compute normalized filter weight - kstep = ((LND_IAU_Control%fhour-t1) - 0.5*LND_IAU_Control%iau_delthrs)*3600./dtp - if (LND_IAU_Control%fhour >= t1 .and. LND_IAU_Control%fhour < t2) then + kstep = ((Land_IAU_Control%fhour-t1) - 0.5*Land_IAU_Control%iau_delthrs)*3600./dtp + if (Land_IAU_Control%fhour >= t1 .and. Land_IAU_Control%fhour < t2) then sx = acos(-1.)*kstep/nstep wx = acos(-1.)*kstep/(nstep+1) if (kstep .ne. 0) then @@ -546,131 +491,120 @@ subroutine lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errf else wt = 1. endif - iau_state%wt = iau_state%wt_normfact*wt - !if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact + Land_IAU_state%wt = Land_IAU_state%wt_normfact*wt + !if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact else - iau_state%wt = 0. + Land_IAU_state%wt = 0. endif endif if (nfiles.EQ.1) then -! on check to see if we are in the IAU window, no need to update the -! tendencies since they are fixed over the window - if ( LND_IAU_Control%fhour < t1 .or. LND_IAU_Control%fhour >= t2 ) then -! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'no iau forcing',t1,LND_IAU_Control%fhour,t2 - LND_IAU_Data%in_interval=.false. + ! check to see if we are in the IAU window, + ! no need to update the states since they are fixed over the window + if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then +! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 + Land_IAU_Data%in_interval=.false. else - if (LND_IAU_Control%iau_filter_increments) call setiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact - LND_IAU_Data%in_interval=.true. + if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control,Land_IAU_Data,Land_IAU_state%wt) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact + Land_IAU_Data%in_interval=.true. endif return endif if (nfiles > 1) then itnext=2 - if (LND_IAU_Control%fhour < t1 .or. LND_IAU_Control%fhour >= t2) then -! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'no iau forcing',LND_IAU_Control%iaufhrs(1),LND_IAU_Control%fhour,LND_IAU_Control%iaufhrs(nfiles) - LND_IAU_Data%in_interval=.false. + if (Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2) then +! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',Land_IAU_Control%iaufhrs(1),Land_IAU_Control%fhour,Land_IAU_Control%iaufhrs(nfiles) + Land_IAU_Data%in_interval=.false. else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,LND_IAU_Control%fhour,t2,iau_state%wt/iau_state%wt_normfact - LND_IAU_Data%in_interval=.true. + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact + Land_IAU_Data%in_interval=.true. do k=nfiles, 1, -1 - if (LND_IAU_Control%iaufhrs(k) > LND_IAU_Control%fhour) then + if (Land_IAU_Control%iaufhrs(k) > Land_IAU_Control%fhour) then itnext=k endif enddo -! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'itnext=',itnext - if (LND_IAU_Control%fhour >= iau_state%hr2) then ! need to read in next increment file - iau_state%hr1=iau_state%hr2 - iau_state%hr2=LND_IAU_Control%iaufhrs(itnext) - iau_state%inc1=iau_state%inc2 +! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'itnext=',itnext + if (Land_IAU_Control%fhour >= Land_IAU_state%hr2) then ! need to read in next increment file + Land_IAU_state%hr1=Land_IAU_state%hr2 + Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(itnext) + Land_IAU_state%inc1=Land_IAU_state%inc2 - ! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(LND_IAU_Control%iau_inc_files(itnext)) - ! call read_iau_forcing(LND_IAU_Control,iau_state%inc2,'INPUT/'//trim(LND_IAU_Control%iau_inc_files(itnext)), errmsg, errflg) - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'interpolating next lnd iau increment ', itnext !trim(LND_IAU_Control%iau_inc_files(itnext)) - call interp_inc_at_timestep(LND_IAU_Control, km, wk3_stc(itnext, :, :, :), iau_state%inc2%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, km, wk3_slc(itnext, :, :, :), iau_state%inc2%slc_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_t2m(itnext, :, :, :), iau_state%inc2%tmp2m_inc, errmsg, errflg) - call interp_inc_at_timestep(LND_IAU_Control, 1, wk3_q2m(itnext, :, :, :), iau_state%inc2%spfh2m_inc, errmsg, errflg) + ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(Land_IAU_Control%iau_inc_files(itnext)) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'interpolating next lnd iau increment ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(itnext, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(itnext, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, 1, wk3_t2m(itnext, :, :, :), Land_IAU_state%inc2%tmp2m_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, 1, wk3_q2m(itnext, :, :, :), Land_IAU_state%inc2%spfh2m_inc, errmsg, errflg) endif - call updateiauforcing(LND_IAU_Control,LND_IAU_Data,iau_state%wt) + call updateiauforcing(Land_IAU_Control,Land_IAU_Data,Land_IAU_state%wt) endif endif - ! sphum=get_tracer_index(MODEL_ATMOS,'sphum') - end subroutine lnd_iau_mod_getiauforcing + end subroutine land_iau_mod_getiauforcing -subroutine updateiauforcing(LND_IAU_Control, LND_IAU_Data, wt) +subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, wt) implicit none - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data - real(kind_phys) delt, wt + type (land_iau_control_type), intent(in) :: Land_IAU_Control + type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data + real(kind=kind_phys) delt, wt integer i,j,k,l -! if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'in updateiauforcing',nfiles,LND_IAU_Control%iaufhrs(1:nfiles) - delt = (iau_state%hr2-(LND_IAU_Control%fhour))/(IAU_state%hr2-IAU_state%hr1) +! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in updateiauforcing',nfiles,Land_IAU_Control%iaufhrs(1:nfiles) + delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) do j = js,je do i = is,ie - do k = 1,npz - ! do k = 1,n_soill ! - LND_IAU_Data%stc_inc(i,j,k) =(delt*IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* IAU_state%inc2%stc_inc(i,j,k))*rdt*wt - LND_IAU_Data%slc_inc(i,j,k) =(delt*IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* IAU_state%inc2%slc_inc(i,j,k))*rdt*wt + do k = 1,npz ! do k = 1,n_soill ! + Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%stc_inc(i,j,k))*rdt*wt + Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%slc_inc(i,j,k))*rdt*wt end do - LND_IAU_Data%tmp2m_inc(i,j,1) =(delt*IAU_state%inc1%tmp2m_inc(i,j,1) + (1.-delt)* IAU_state%inc2%tmp2m_inc(i,j,1))*rdt*wt - LND_IAU_Data%spfh2m_inc(i,j,1) =(delt*IAU_state%inc1%spfh2m_inc(i,j,1) + (1.-delt)* IAU_state%inc2%spfh2m_inc(i,j,1))*rdt*wt + Land_IAU_Data%tmp2m_inc(i,j,1) =(delt*Land_IAU_state%inc1%tmp2m_inc(i,j,1) + (1.-delt)* Land_IAU_state%inc2%tmp2m_inc(i,j,1))*rdt*wt + Land_IAU_Data%spfh2m_inc(i,j,1) =(delt*Land_IAU_state%inc1%spfh2m_inc(i,j,1) + (1.-delt)* Land_IAU_state%inc2%spfh2m_inc(i,j,1))*rdt*wt enddo enddo end subroutine updateiauforcing - subroutine setiauforcing(LND_IAU_Control, LND_IAU_Data, wt) + subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, wt) implicit none - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control - type(lnd_iau_external_data_type), intent(inout) :: LND_IAU_Data - real(kind_phys) delt, dt,wt - integer i,j,k,l,sphum + type (land_iau_control_type), intent(in) :: Land_IAU_Control + type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data + real(kind=kind_phys) delt, dt,wt + integer i,j,k,l ! this is only called if using 1 increment file - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'in lnd_iau setiauforcing rdt = ',rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',rdt do j = js,je do i = is,ie - do k = 1,npz - ! do k = 1,n_soill ! - LND_IAU_Data%stc_inc(i,j,k) = wt*IAU_state%inc1%stc_inc(i,j,k)*rdt - LND_IAU_Data%slc_inc(i,j,k) = wt*IAU_state%inc1%slc_inc(i,j,k)*rdt + do k = 1,npz ! do k = 1,n_soill ! + Land_IAU_Data%stc_inc(i,j,k) = wt*Land_IAU_state%inc1%stc_inc(i,j,k)*rdt + Land_IAU_Data%slc_inc(i,j,k) = wt*Land_IAU_state%inc1%slc_inc(i,j,k)*rdt end do - LND_IAU_Data%tmp2m_inc(i,j,1) = wt*IAU_state%inc1%tmp2m_inc(i,j,1)*rdt - LND_IAU_Data%spfh2m_inc(i,j,1) = wt*IAU_state%inc1%spfh2m_inc(i,j,1)*rdt + Land_IAU_Data%tmp2m_inc(i,j,1) = wt*Land_IAU_state%inc1%tmp2m_inc(i,j,1)*rdt + Land_IAU_Data%spfh2m_inc(i,j,1) = wt*Land_IAU_state%inc1%spfh2m_inc(i,j,1)*rdt enddo enddo - ! sphum=get_tracer_index(MODEL_ATMOS,'sphum') end subroutine setiauforcing -subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg, & - wk3_out_stc, wk3_out_slc, wk3_out_t2m, wk3_out_q2m) !, fname_sfc) is, ie, js, je, ks,ke, - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control +subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errflg, & + wk3_out_stc, wk3_out_slc) !, fname_sfc) is, ie, js, je, ks,ke, + type (land_iau_control_type), intent(in) :: Land_IAU_Control character(len=*), intent(in) :: fname character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! integer, intent(in) :: is, ie, js, je, ks,ke - ! real(kind=4), intent(out) :: wk3_out(is:ie,js:je,ks:ke) - real(kind=4), intent(out) :: wk3_out_stc(1:im, jbeg:jend, 1:km) - real(kind=4), intent(out) :: wk3_out_slc(1:im, jbeg:jend, 1:km) - real(kind=4), intent(out) :: wk3_out_t2m(1:im, jbeg:jend, 1:1) - real(kind=4), intent(out) :: wk3_out_q2m(1:im, jbeg:jend, 1:1) + real(kind=kind_phys), intent(out) :: wk3_out_stc(1:im, jbeg:jend, 1:km) + real(kind=kind_phys), intent(out) :: wk3_out_slc(1:im, jbeg:jend, 1:km) integer :: i, j, k, l, npz integer :: i1, i2, j1 logical :: exists - integer :: ncid + integer :: ncid, status, varid integer :: ierr character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] - character(len=32) :: t2m_vars = 'tmp2m_inc' - character(len=32) :: q2m_vars = 'spfh2m_inc' !Errors messages handled through CCPP error handling variables errmsg = '' @@ -678,69 +612,56 @@ subroutine read_iau_forcing_all_timesteps(LND_IAU_Control, fname, errmsg, errflg inquire (file=trim(fname), exist=exists) if (exists) then -! if( file_exist(fname) ) then - call open_ncfile( fname, ncid ) ! open the file + status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file + call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) + if (errflg .ne. 0) return else - ! call mpp_error(FATAL,'==> Error in read_iau_forcing: Expected file '& - ! //trim(fname)//' for DA increment does not exist') - errmsg = 'FATAL Error in read_iau_forcing: Expected file '//trim(fname)//' for DA increment does not exist' + errmsg = 'FATAL Error in land read_iau_forcing_all_timesteps: Expected file '//trim(fname)//' for DA increment does not exist' errflg = 1 return endif do i = 1, size(stc_vars) print *, trim(stc_vars(i)) - call check_var_exists(ncid, trim(stc_vars(i)), ierr) - if (ierr == 0) then - ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) - call get_var3_r4( ncid, trim(stc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i) ) + ! call check_var_exists(ncid, trim(stc_vars(i)), ierr) + status = nf90_inq_varid(ncid, trim(stc_vars(i)), varid) + if (status == nf90_noerr) then !if (ierr == 0) then + call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i), status) + call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg_out) + if (errflg .ne. 0) return else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, & + 'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' wk3_out_stc(:, :, i) = 0. endif enddo do i = 1, size(slc_vars) print *, trim(slc_vars(i)) - call check_var_exists(ncid, trim(slc_vars(i)), ierr) - if (ierr == 0) then - ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) - call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) + status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) + if (status == nf90_noerr) then !if (ierr == 0) then + ! call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) + call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i), status) + call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg_out) + if (errflg .ne. 0) return else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,& + 'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' wk3_out_slc(:, :, i) = 0. endif enddo - print *, trim(t2m_vars) - call check_var_exists(ncid, trim(t2m_vars), ierr) - if (ierr == 0) then - ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) - call get_var3_r4( ncid, trim(t2m_vars), 1,im, jbeg,jend, 1,1, wk3_out_t2m(:, :, :) ) - else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(t2m_vars),' found, assuming zero' - wk3_out_t2m(:, :, :) = 0. - endif - print *, trim(q2m_vars) - call check_var_exists(ncid, trim(q2m_vars), ierr) - if (ierr == 0) then - ! call get_var3_r4( ncid, field_name, 1,im, jbeg,jend, 1,km, wk3 ) - call get_var3_r4( ncid, trim(q2m_vars), 1,im, jbeg,jend, 1,1, wk3_out_q2m(:, :, :) ) - else - if (LND_IAU_Control%me == LND_IAU_Control%mpi_root) print *,'warning: no increment for ',trim(q2m_vars),' found, assuming zero' - wk3_out_q2m(:, :, :) = 0. - endif call close_ncfile(ncid) end subroutine read_iau_forcing_all_timesteps -subroutine interp_inc_at_timestep(LND_IAU_Control, km_in, wk3_in, var, errmsg, errflg) !field_name, , jbeg, jend) +subroutine interp_inc_at_timestep(Land_IAU_Control, km_in, wk3_in, var, errmsg, errflg) !field_name, , jbeg, jend) ! interpolate increment from GSI gaussian grid to cubed sphere ! everying is on the A-grid, earth relative - type (LND_IAU_Control_type), intent(in) :: LND_IAU_Control + type (land_iau_control_type), intent(in) :: Land_IAU_Control ! character(len=*), intent(in) :: field_name integer, intent(in) :: km_in !jbeg,jend - real(kind=4), intent(in) :: wk3_in(1:im,jbeg:jend, 1:km_in) - real, dimension(is:ie, js:je, 1:km), intent(inout) :: var + real(kind=kind_phys), intent(in) :: wk3_in(1:im,jbeg:jend, 1:km_in) + real(kind=kind_phys), dimension(is:ie, js:je, 1:km), intent(inout) :: var character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -769,14 +690,14 @@ subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed integer, intent(in):: im, jm - real(kind=kind_dyn), intent(in):: lon(im), lat(jm) - real, intent(out):: s2c(is:ie,js:je,4) + real(kind=kind_phys), intent(in):: lon(im), lat(jm) + real(kind=kind_phys), intent(out):: s2c(is:ie,js:je,4) integer, intent(out), dimension(is:ie,js:je):: id1, id2, jdc - real(kind=kind_dyn), intent(in):: agrid(isd:ied,jsd:jed,2) + real(kind=kind_phys), intent(in):: agrid(isd:ied,jsd:jed,2) ! local: - real :: rdlon(im) - real :: rdlat(jm) - real:: a1, b1 + real(kind=kind_phys) :: rdlon(im) + real(kind=kind_phys) :: rdlat(jm) + real(kind=kind_phys):: a1, b1 integer i,j, i1, i2, jc, i0, j0 do i=1,im-1 rdlon(i) = 1. / (lon(i+1) - lon(i)) @@ -841,7 +762,100 @@ subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & 5000 continue ! j-loop end subroutine remap_coef + + SUBROUTINE NETCDF_ERR(ERR, STRING, errflg, errmsg_out) + + !-------------------------------------------------------------- + ! IF AT NETCDF CALL RETURNS AN ERROR, PRINT OUT A MESSAGE + ! AND STOP PROCESSING. + !-------------------------------------------------------------- + IMPLICIT NONE + + include 'mpif.h' + + INTEGER, INTENT(IN) :: ERR + CHARACTER(LEN=*), INTENT(IN) :: STRING + CHARACTER(LEN=80) :: ERRMSG + integer :: errflg + character(len=*) :: errmsg_out + + !Errors messages handled through CCPP error handling variables + errmsg_out = '' + errflg = 0 + + IF (ERR == NF90_NOERR) RETURN + ERRMSG = NF90_STRERROR(ERR) + PRINT*,'FATAL ERROR in Land IAU ', TRIM(STRING), ': ', TRIM(ERRMSG) + errmsg_out = 'FATAL ERROR in Land IAU ', TRIM(STRING), ': ', TRIM(ERRMSG) + ! CALL MPI_ABORT(MPI_COMM_WORLD, 999) + errflg = 1 + return + + END SUBROUTINE NETCDF_ERR + + subroutine get_nc_dimlen(ncid, dim_name, dim_len, errflg, errmsg_out ) + integer, intent(in):: ncid + character(len=*), intent(in):: dim_name + integer, intent(out):: dim_len + integer :: dimid + integer :: errflg + character(len=*) :: errmsg_out + + !Errors messages handled through CCPP error handling variables + errmsg_out = '' + errflg = 0 + + status = nf90_inq_dimid(ncid, dim_name, dimid) + CALL netcdf_err(status, 'reading dim id '//trim(dim_name), errflg, errmsg_out) + if (errflg .ne. 0) return + status = nf90_inquire_dimension(ncid, dimid, len = dim_len) + CALL netcdf_err(status, 'reading dim length '//trim(dim_name), errflg, errmsg_out) + + end subroutine get_nc_dimlen + ! status = nf90_inq_dimid(ncid, "longitude", dimid) + ! CALL netcdf_err(status, 'reading longitude dim id') + ! status = nf90_inquire_dimension(ncid, dimid, len = im) + ! CALL netcdf_err(status, 'reading dim longitude') + ! status = nf90_inq_dimid(ncid, "latitude", dimid) + ! CALL netcdf_err(status, 'reading latitude dim id') + ! status = nf90_inquire_dimension(ncid, dimid, len = jm) + ! CALL netcdf_err(status, 'reading dim latitude') + subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) + integer, intent(in):: ncid, dim_len + character(len=*), intent(in):: var_name + real(kind=kind_phys), intent(out):: var_arr(dim_len) + integer :: errflg + character(len=*) :: errmsg_out + integer :: var_id + + !Errors messages handled through CCPP error handling variables + errmsg_out = '' + errflg = 0 + + status = nf90_inq_varid(ncid, trim(var_name), varid) + CALL NETCDF_ERR(status, 'getting varid: '//trim(var_name), errflg, errmsg_out) + if (errflg .ne. 0) return + status = nf90_get_var(ncid, varid, var_arr) + CALL NETCDF_ERR(status, 'reading var: '//trim(var_name), errflg, errmsg_out) + + end subroutine get_var1d + + subroutine get_var3d_values(ncid, varid, is,ie, js,je, ks,ke, var3d, status) + integer, intent(in):: ncid, varid + integer, intent(in):: is, ie, js, je, ks,ke + real(kind=kind_phys), intent(out):: var3d(is:ie,js:je,ks:ke) + integer, intent(out):: status + ! integer, dimension(3):: start, nreco + ! start(1) = is; start(2) = js; start(3) = ks + ! nreco(1) = ie - is + 1 + ! nreco(2) = je - js + 1 + ! nreco(3) = ke - ks + 1 + + status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) + start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) + + end subroutine get_var3d_values -end module lnd_iau_mod +end module land_iau_mod diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index d583a7ffa..ab3faf9d2 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -13,10 +13,10 @@ module noahmpdrv use module_sf_noahmplsm - ! 3.5.24 for use in IAU - use lnd_iau_mod, only: lnd_iau_control_type, lnd_iau_external_data_type, & - lnd_iau_mod_set_control, lnd_iau_mod_init, lnd_iau_mod_getiauforcing, & - lnd_iau_mod_finalize + ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) + use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & + land_iau_mod_set_control, land_iau_mod_init, + land_iau_mod_getiauforcing, land_iau_mod_finalize implicit none @@ -27,9 +27,14 @@ module noahmpdrv public :: noahmpdrv_init, noahmpdrv_run, & noahmpdrv_timestep_init, noahmpdrv_timestep_finalize, noahmpdrv_finalize - ! IAU data and control - type (lnd_iau_control_type) :: LND_IAU_Control - type (lnd_iau_external_data_type) :: LND_IAU_Data !(number of blocks):each proc holds nblks + !> \Land IAU data and control + ! Land IAU Control holds settings' information, maily read from namelist (e.g., + ! block of global domain that belongs to a process , + ! whethrer to do IAU increment at this time step, + ! time step informatoin, etc) + type (land_iau_control_type) :: Land_IAU_Control + ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step + type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks contains @@ -127,23 +132,18 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & pores (:) = maxsmc (:) resid (:) = drysmc (:) - ! 3.7.24 init iau for land - call lnd_iau_mod_set_control(LND_IAU_Control, fn_nml, input_nml_file, me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & - lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) - ! print*, 'proc errmsg, errflg after set control', me, errmsg, errflg - ! print*, 'proc iau_control isc, nx, dtp fhour', me, LND_IAU_Control%isc, LND_IAU_Control%nx, & - ! LND_IAU_Control%dtp, LND_IAU_Control%fhour - ! print*, 'proc iau_control incfiles(1)', me, LND_IAU_Control%iau_inc_files(1) - - call lnd_iau_mod_init (LND_IAU_Control, LND_IAU_Data, xlon, xlat, errmsg, errflg) - !print*, 'proc errmsg, errflg interval after lnd_iau_init ', me,trim(errmsg), errflg, LND_IAU_Data%in_interval - ! print*, 'proc nblks blksize(1) after set init', me,LND_IAU_Control%nblks, LND_IAU_Control%blksz(1) + ! Read Land IAU settings + call land_iau_mod_set_control(Land_IAU_Control, fn_nml, input_nml_file, & + me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & + lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) + ! Initialize IAU for land + call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errmsg, errflg) end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called before noahmpdrv_run -!! to update states with iau increments +!! to update states with iau increments, if available !! \section arg_table_noahmpdrv_timestep_init Argument Table !! \htmlinclude noahmpdrv_timestep_init.html !! @@ -154,8 +154,6 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo implicit none - ! integer, intent(in) :: me !mpi_rank - ! integer, intent(in) :: mpi_root ! = GFS_Control%master integer , intent(in) :: itime !current forecast iteration real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) real(kind=kind_phys) , intent(in) :: delt ! time interval [s] @@ -168,8 +166,6 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! IAU update real,allocatable :: stc_inc_flat(:,:) ! real,allocatable :: slc_inc_flat(:,:) - ! real,allocatable :: tmp2m_inc_flat(:) - ! real,allocatable :: spfh2m_inc_flat(:) integer :: j, k, ib ! --- end declaration @@ -179,70 +175,59 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo !> update current forecast hour ! GFS_control%jdat(:) = jdat(:) - LND_IAU_Control%fhour=fhour + Land_IAU_Control%fhour=fhour - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",LND_IAU_Control%fhour, & - " delt ",delt," IauCont%dtp",LND_IAU_Control%dtp + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",Land_IAU_Control%fhour, & + " delt ",delt," IauCont%dtp",Land_IAU_Control%dtp endif - !> 3.7.24 read iau increments - call lnd_iau_mod_getiauforcing(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) + !> read iau increments + call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) if (errflg .ne. 0) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" print*, errmsg endif return endif - !> update with iau increments - if (LND_IAU_Data%in_interval) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then + !> update land states with iau increments + if (Land_IAU_Data%in_interval) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print*, "adding land iau increments " endif - if (LND_IAU_Control%lsoil .ne. km) then - write(errmsg,*) 'noahmpdrv_timestep_init: LND_IAU_Data%lsoil ',LND_IAU_Control%lsoil,' not equal to km ',km + if (Land_IAU_Control%lsoil .ne. km) then + write(errmsg,*) 'noahmpdrv_timestep_init: Land_IAU_Data%lsoil ',Land_IAU_Control%lsoil,' not equal to km ',km errflg = 1 return endif - ! local variable to copy blocked data LND_IAU_Data%stc_inc - allocate(stc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - ! allocate(slc_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny, km)) !GFS_Control%ncols - ! allocate(tmp2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols - ! allocate(spfh2m_inc_flat(LND_IAU_Control%nx * LND_IAU_Control%ny)) !GFS_Control%ncols + ! local variable to copy blocked data Land_IAU_Data%stc_inc + allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols + ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols ib = 1 - do j = 1, LND_IAU_Control%ny !ny + do j = 1, Land_IAU_Control%ny !ny do k = 1, km - stc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) =LND_IAU_Data%stc_inc(:,j, k) - ! slc_inc_flat(ib:ib+LND_IAU_Control%nx-1, k) = LND_IAU_Data%slc_inc(:,j, k) + stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) =Land_IAU_Data%stc_inc(:,j, k) + ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) enddo - ! ib = 1 - ! do j = 1, LND_IAU_Control%ny !ny - ! tmp2m_inc_flat(ib:ib+LND_IAU_Control%nx-1) =LND_IAU_Data%tmp2m_inc(:,j, 1) - ! spfh2m_inc_flat(ib:ib+LND_IAU_Control%nx-1)=LND_IAU_Data%spfh2m_inc(:,j, 1) - ib = ib + LND_IAU_Control%nx !nlon + ib = ib + Land_IAU_Control%nx !nlon enddo ! delt=GFS_Control%dtf - if ((LND_IAU_Control%dtp - delt) > 0.0001) then - if(LND_IAU_Control%me == LND_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_run delt ",delt,"different from LND_IAU_Control%dtp ",LND_IAU_Control%dtp + if ((Land_IAU_Control%dtp - delt) > 0.0001) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "Warning noahmpdrv_run delt ",delt,"different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp endif endif - !IAU increments are in units of 1/sec !LND_IAU_Control%dtp -!* only updating soil temp + !IAU increments are in units of 1/sec !Land_IAU_Control%dtp + !* only updating soil temp for now do k = 1, km - stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !LND_IAU_Control%dtp - ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !LND_IAU_Control%dtp + stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp + ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp enddo - ! t2mmp = t2mmp + & - ! tmp2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb) + im-1)*delt !LND_IAU_Control%dtp - ! q2mp = q2mp + & - ! spfh2m_inc_flat(LND_IAU_Control%blk_strt_indx(nb):LND_IAU_Control%blk_strt_indx(nb)+ im-1)*delt !LND_IAU_Control%dtp - deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) endif @@ -251,51 +236,41 @@ end subroutine noahmpdrv_timestep_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called after noahmpdrv_run -!! to free up allocated memory +!! to free up allocated memory, if there are any +!! code to do any needed consistency check will go here !! \section arg_table_noahmpdrv_timestep_finalize Argument Table !! \htmlinclude noahmpdrv_timestep_finalize.html !! subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, - use machine, only: kind_phys - + use machine, only: kind_phys implicit none - character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - - integer :: j, k, ib - ! --- Initialize CCPP error handling variables errmsg = '' - errflg = 0 - + errflg = 0 + !> note the IAU deallocate happens at the noahmpdrv_finalize end subroutine noahmpdrv_timestep_finalize !> \ingroup NoahMP_LSM !! \brief This subroutine mirrors noahmpdrv_init -!! to free up allocated memory in IAU_init (noahmdrv_init) +!! it calls land_iau_finalize which frees up allocated memory by IAU_init (in noahmdrv_init) !! \section arg_table_noahmpdrv_finalize Argument Table !! \htmlinclude noahmpdrv_finalize.html -!! subroutine noahmpdrv_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, - use machine, only: kind_phys - + use machine, only: kind_phys implicit none - character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - integer :: j, k, ib - ! --- Initialize CCPP error handling variables errmsg = '' - errflg = 0 - - call lnd_iau_mod_finalize(LND_IAU_Control, LND_IAU_Data, errmsg, errflg) !LND_IAU_Control%finalize() + errflg = 0 + call land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !Land_IAU_Control%finalize() end subroutine noahmpdrv_finalize @@ -323,7 +298,7 @@ end subroutine noahmpdrv_finalize subroutine noahmpdrv_run & !................................... ! --- inputs: - (nb, im, km, lsnowl, itime, fhour, ps, u1, v1, t1, q1, soiltyp,soilcol,& + (im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp,soilcol,& vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp,& shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & @@ -425,12 +400,10 @@ subroutine noahmpdrv_run & ! --- CCPP interface fields (in call order) ! - integer , intent(in) :: nb !=cdata%blk_no, integer , intent(in) :: im ! horiz dimension and num of used pts integer , intent(in) :: km ! vertical soil layer dimension integer , intent(in) :: lsnowl ! lower bound for snow level arrays integer , intent(in) :: itime ! NOT USED current forecast iteration - real(kind=kind_phys) , intent(in) :: fhour ! currentforecast time (hr) real(kind=kind_phys), dimension(:) , intent(in) :: ps ! surface pressure [Pa] real(kind=kind_phys), dimension(:) , intent(in) :: u1 ! u-component of wind [m/s] real(kind=kind_phys), dimension(:) , intent(in) :: v1 ! u-component of wind [m/s] From e535c80eab5a08bc717e80383b2c9c73ef552da6 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 31 May 2024 13:45:20 -0400 Subject: [PATCH 024/154] add soil temp adjustments --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 51 +++- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 279 +++++++++++++----- 2 files changed, 259 insertions(+), 71 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index d25aa3877..9a3fa8e7c 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -80,7 +80,8 @@ module land_iau_mod real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours character(len=240) :: iau_inc_files(7)! list of increment files real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files - logical :: iau_filter_increments + logical :: iau_filter_increments + integer :: lsoil_incr ! soil layers (from top) updated by DA !, iau_drymassfixer integer :: me !< MPI rank designator integer :: mpi_root !< MPI rank of master atmosphere processor @@ -131,8 +132,12 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files real(kind=kind_phys) :: land_iaufhrs(7) = -1 !< forecast hours associated with increment files logical :: land_iau_filter_increments = .false. !< filter IAU increments + + integer :: lsoil_incr = 4 - NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iaufhrs, land_iau_filter_increments !, lnd_iau_drymassfixer & + NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iaufhrs, & + land_iau_filter_increments, & !, lnd_iau_drymassfixer + lsoil_incr !Errors messages handled through CCPP error handling variables errmsg = '' @@ -185,6 +190,8 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%iaufhrs = land_iaufhrs Land_IAU_Control%iau_filter_increments = land_iau_filter_increments ! Land_IAU_Control%iau_drymassfixer = lnd_iau_drymassfixer + Land_IAU_Control%lsoil_incr = lsoil_incr + Land_IAU_Control%me = me Land_IAU_Control%mpi_root = mpi_root Land_IAU_Control%isc = isc @@ -763,6 +770,46 @@ subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & end subroutine remap_coef + !> Calculate soil mask for land on model grid. +!! Output is 1 - soil, 2 - snow-covered, 0 - land ice, -1 not land. +!! +!! @param[in] lensfc Number of land points for this tile +!! @param[in] veg_type_landice Value of vegetion class that indicates land-ice +!! @param[in] stype Soil type +!! @param[in] swe Model snow water equivalent +!! @param[in] vtype Model vegetation type +!! @param[out] mask Land mask for increments +!! @author Clara Draper @date March 2021 +!! @author Yuan Xue: introduce stype to make the mask calculation more generic +subroutine calculate_landinc_mask(swe,vtype,stype,lensfc,veg_type_landice,mask) + + implicit none + + integer, intent(in) :: lensfc, veg_type_landice + real, intent(in) :: swe(lensfc) + integer, intent(in) :: vtype(lensfc),stype(lensfc) + integer, intent(out) :: mask(lensfc) + + integer :: i + + mask = -1 ! not land + + ! land (but not land-ice) + do i=1,lensfc + if (stype(i) .GT. 0) then + if (swe(i) .GT. 0.001) then ! snow covered land + mask(i) = 2 + else ! non-snow covered land + mask(i) = 1 + endif + end if ! else should work here too + if ( vtype(i) == veg_type_landice ) then ! land-ice + mask(i) = 0 + endif + end do + +end subroutine calculate_landinc_mask + SUBROUTINE NETCDF_ERR(ERR, STRING, errflg, errmsg_out) !-------------------------------------------------------------- diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index ab3faf9d2..5bae760a6 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -16,7 +16,8 @@ module noahmpdrv ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & land_iau_mod_set_control, land_iau_mod_init, - land_iau_mod_getiauforcing, land_iau_mod_finalize + land_iau_mod_getiauforcing, land_iau_mod_finalize, & + calculate_landinc_mask implicit none @@ -147,92 +148,232 @@ end subroutine noahmpdrv_init !! \section arg_table_noahmpdrv_timestep_init Argument Table !! \htmlinclude noahmpdrv_timestep_init.html !! - subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, - stc, slc, errmsg, errflg) ! smc, t2mmp, q2mp, + !! For Noah-MP, the adjustment scheme shown below as of 11/09/2023: +!! Case 1: frozen ==> frozen, recalculate slc following opt_frz=1, smc remains +!! Case 2: unfrozen ==> frozen, recalculate slc following opt_frz=1, smc remains +!! Case 3: frozen ==> unfrozen, melt all soil ice (if any) +!! Case 4: unfrozen ==> unfrozen along with other cases, (e.g., soil temp=tfrz),do nothing +!! Note: For Case 3, Yuan Xue thoroughly evaluated a total of four options and +!! current option is found to be the best as of 11/09/2023 + +!! @param[in] isot Integer code for the soil type data set +!! @param[in] ivegsrc Integer code for the vegetation type data set +!! @param[in] lensfc Number of land points for this tile + +!! @param[in] lsoil_incr Number of soil layers (from top) to apply soil increments to + +!! @param[inout] smc_adj Analysis soil moisture states +!! @param[inout] slc_adj Analysis liquid soil moisture states +!! @param[in] stc_updated Integer to record whether STC in each grid cell was updated + +subroutine noahmpdrv_timestep_init (isot, ivegsrc, itime, fhour, delt, km, & !me, mpi_root, + soiltyp, vegtype, weasd, & + stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, - use machine, only: kind_phys - - implicit none + use machine, only: kind_phys + use namelist_soilveg + ! use set_soilveg_snippet_mod, only: set_soilveg_noahmp + use noahmp_tables - integer , intent(in) :: itime !current forecast iteration - real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) - real(kind=kind_phys) , intent(in) :: delt ! time interval [s] - integer , intent(in) :: km !vertical soil layer dimension - real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] - real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + implicit none - ! IAU update - real,allocatable :: stc_inc_flat(:,:) - ! real,allocatable :: slc_inc_flat(:,:) - integer :: j, k, ib - ! --- end declaration + ! for soil temp/moisture consistency adjustment after DA update + integer, intent(in) :: isot, ivegsrc - ! --- Initialize CCPP error handling variables - errmsg = '' - errflg = 0 + integer , intent(in) :: itime !current forecast iteration + real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) + real(kind=kind_phys) , intent(in) :: delt ! time interval [s] + integer , intent(in) :: km !vertical soil layer dimension - !> update current forecast hour - ! GFS_control%jdat(:) = jdat(:) - Land_IAU_Control%fhour=fhour + integer , dimension(:) , intent(in) :: soiltyp ! soil type (integer index) + integer , dimension(:) , intent(in) :: vegtype ! vegetation type (integer index) + real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] + + real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] + real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' + real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! IAU update + real,allocatable :: stc_inc_flat(:,:) + ! real,allocatable :: slc_inc_flat(:,:) + integer :: lsoil_incr + ! integer :: veg_type_landice + + integer, allocatable :: mask_tile(:) + integer,allocatable :: stc_updated(:) + logical :: soil_freeze, soil_ice + integer :: n_freeze, n_thaw + integer :: soiltype, n_stc + real :: slc_new + + integer :: i, l, jj, k, ib + integer :: lensfc + + real (kind=kind_phys), dimension(max_soiltyp) :: maxsmc, bb, satpsi + ! real, dimension(30) :: maxsmc, bb, satpsi + real, parameter :: tfreez=273.16 !< con_t0c in physcons + real, parameter :: hfus=0.3336e06 !< latent heat of fusion(j/kg) + real, parameter :: grav=9.80616 !< gravity accel.(m/s2) + real :: smp !< for computing supercooled water + + integer :: nother, nsnowupd + integer :: nstcupd, nfrozen, nfrozen_upd + ! --- Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + !> update current forecast hour + ! GFS_control%jdat(:) = jdat(:) + Land_IAU_Control%fhour=fhour + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",Land_IAU_Control%fhour, & + " delt ",delt," IauCont%dtp",Land_IAU_Control%dtp + endif + + !> read iau increments + call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) + if (errflg .ne. 0) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",Land_IAU_Control%fhour, & - " delt ",delt," IauCont%dtp",Land_IAU_Control%dtp - endif + print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" + print*, errmsg + endif + return + endif - !> read iau increments - call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) - if (errflg .ne. 0) then - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" - print*, errmsg - endif + !> update land states with iau increments + if (Land_IAU_Data%in_interval) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "adding land iau increments " + endif + + if (Land_IAU_Control%lsoil .ne. km) then + write(errmsg,*) 'noahmpdrv_timestep_init: Land_IAU_Data%lsoil ',Land_IAU_Control%lsoil,' not equal to km ',km + errflg = 1 return endif - !> update land states with iau increments - if (Land_IAU_Data%in_interval) then - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "adding land iau increments " - endif + ! local variable to copy blocked data Land_IAU_Data%stc_inc + allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols + ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) + stc_updated = 0 + ib = 1 + do j = 1, Land_IAU_Control%ny !ny + do k = 1, km + stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) =Land_IAU_Data%stc_inc(:,j, k) + ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) + enddo + ib = ib + Land_IAU_Control%nx !nlon + enddo - if (Land_IAU_Control%lsoil .ne. km) then - write(errmsg,*) 'noahmpdrv_timestep_init: Land_IAU_Data%lsoil ',Land_IAU_Control%lsoil,' not equal to km ',km - errflg = 1 - return + ! delt=GFS_Control%dtf + if ((Land_IAU_Control%dtp - delt) > 0.0001) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "Warning noahmpdrv_run delt ",delt,"different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp endif + endif - ! local variable to copy blocked data Land_IAU_Data%stc_inc - allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols - ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols - ib = 1 - do j = 1, Land_IAU_Control%ny !ny - do k = 1, km - stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) =Land_IAU_Data%stc_inc(:,j, k) - ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) + !IAU increments are in units of 1/sec !Land_IAU_Control%dtp + !* only updating soil temp for now + lsoil_incr = Land_IAU_Control%lsoil_incr + lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny + + print*,'adjusting first ', lsoil_incr, ' surface layers only' + ! initialize variables for counts statitics to be zeros + nother = 0 ! grid cells not land + nsnowupd = 0 ! grid cells with snow (temperature not yet updated) + nstcupd = 0 ! grid cells that are updated + nfrozen = 0 ! not update as frozen soil + nfrozen_upd = 0 ! not update as frozen soil + + allocate(mask_tile(lensfc)) + call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, & !veg_type_landice, + mask_tile) + + ij_loop : do ij = 1, lensfc + ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land + if (mask_tile(ij) == 1) then + soil_freeze=.false. + soil_ice=.false. + do k = 1, lsoil_incr ! k = 1, km + if ( stc(ij,k) < tfreez) soil_freeze=.true. + if ( smc(ij,k) - slc(ij,k) > 0.001 ) soil_ice=.true. + + stc(ij,k) = stc(ij,k) + stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp + + if (k==1) then + stc_updated(ij) = 1 + nstcupd = nstcupd + 1 + endif + if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) )& + nfrozen_upd = nfrozen_upd + 1 + ! moisture updates not done if this layer or any above is frozen + if ( soil_freeze .or. soil_ice ) then + if (k==1) nfrozen = nfrozen+1 + endif enddo - ib = ib + Land_IAU_Control%nx !nlon - enddo - - ! delt=GFS_Control%dtf - if ((Land_IAU_Control%dtp - delt) > 0.0001) then - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_run delt ",delt,"different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp - endif + endif ! if soil/snow point + enddo ij_loop + ! do k = 1, km + ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp + ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp + ! enddo + deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + + ! add (consistency) adjustments for updated soil temp and moisture + + ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) + call read_mp_table_parameters(errmsg, errflg) + maxsmc(1:slcats) = smcmax_table(1:slcats) + bb(1:slcats) = bexp_table(1:slcats) + satpsi(1:slcats) = psisat_table(1:slcats) + + if (errflg .ne. 0) then + print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + return + endif + n_stc = 0 + do i=1,lensfc + if (stc_updated(i) == 1 ) then ! soil-only location + n_stc = n_stc+1 + soiltype = soiltyp(i) + do l = 1, lsoil_incr + !case 1: frz ==> frz, recalculate slc, smc remains + !case 2: unfrz ==> frz, recalculate slc, smc remains + !both cases are considered in the following if case + if (stc(i,l) .LT. tfreez )then + !recompute supercool liquid water,smc_anl remain unchanged + smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) + slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) + slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) + endif + !case 3: frz ==> unfrz, melt all soil ice (if any) + if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck + slc(i,l)=smc(i,l) + endif + enddo endif - !IAU increments are in units of 1/sec !Land_IAU_Control%dtp - !* only updating soil temp for now - do k = 1, km - stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp - ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp - enddo - deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + enddo + + deallocate(stc_updated) + allocate(mask_tile) - endif + write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me + write(*,'(a,i8)') ' soil grid total', lensfc + write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd + write(*,'(a,i8)') ' soil grid cells not updated, frozen = ',nfrozen + write(*,'(a,i8)') ' soil grid cells update, became frozen = ',nfrozen_upd + write(*,'(a,i8)') ' (not updated yet) snow grid cells = ', nsnowupd + write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother + write(*,'(a,i8)') ' soil grid cells with stc update', n_stc + + endif - end subroutine noahmpdrv_timestep_init +end subroutine noahmpdrv_timestep_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called after noahmpdrv_run From 25358b9fa552ee21d6d9f7c4e328b5bc80c258c8 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 13 Jun 2024 11:26:56 -0400 Subject: [PATCH 025/154] read fv3 increments --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 275 ++++++++++++------ physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 12 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 6 + 3 files changed, 207 insertions(+), 86 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 9a3fa8e7c..fefcd53c2 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -69,6 +69,7 @@ module land_iau_mod integer :: jsc integer :: nx integer :: ny + integer :: tile_num integer :: nblks integer, allocatable :: blksz(:) ! this could vary for the last block integer, allocatable :: blk_strt_indx(:) @@ -91,6 +92,8 @@ module land_iau_mod character(len=:), pointer, dimension(:) :: input_nml_file => null() ! null() integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads - + !> these are not available through the CCPP interface so need to read them from namelist file !> vars to read from namelist @@ -132,12 +135,12 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files real(kind=kind_phys) :: land_iaufhrs(7) = -1 !< forecast hours associated with increment files logical :: land_iau_filter_increments = .false. !< filter IAU increments - + logical :: gaussian_inc_file = .false. integer :: lsoil_incr = 4 NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iaufhrs, & land_iau_filter_increments, & !, lnd_iau_drymassfixer - lsoil_incr + lsoil_incr, gaussian_inc_file !Errors messages handled through CCPP error handling variables errmsg = '' @@ -198,6 +201,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%jsc = jsc Land_IAU_Control%nx = nx Land_IAU_Control%ny = ny + Land_IAU_Control%tile_num = tile_num Land_IAU_Control%nblks = nblks Land_IAU_Control%lsoil = lsoil Land_IAU_Control%lsnow_lsm = lsnow_lsm @@ -206,6 +210,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%input_nml_file = input_nml_file Land_IAU_Control%input_nml_file_length = input_nml_file_length + Land_IAU_Control%gaussian_inc_file = gaussian_inc_file allocate(Land_IAU_Control%blksz(nblks)) allocate(Land_IAU_Control%blk_strt_indx(nblks)) @@ -316,60 +321,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms dt = (Land_IAU_Control%iau_delthrs*3600.) rdt = 1.0/dt -! set up interpolation weights to go from GSI's gaussian grid to cubed sphere - deg2rad = pi/180. - - ! npz = Land_IAU_Control%levs - fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1)) - inquire (file=trim(fname), exist=exists) - if (exists) then ! if( file_exist(fname) ) then - ! call open_ncfile( fname, ncid ) - status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file - call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) - if (errflg .ne. 0) return - call get_nc_dimlen(ncid, "longitude", im, errflg, errmsg) - if (errflg .ne. 0) return - call get_nc_dimlen(ncid, "latitude", jm, errflg, errmsg) - if (errflg .ne. 0) return - km = n_soill - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) write(*,*) fname, ' DA increment dimensions:', im,jm,km - allocate (lon(im) ) - allocate (lat(jm) ) - call get_var1d(ncid, im, "longitude", lon, errflg, errmsg) - if (errflg .ne. 0) return - call get_var1d(ncid, jm, "latitude", lat, errflg, errmsg) - if (errflg .ne. 0) return - status = nf90_close(ncid) - CALL netcdf_err(status, 'closing file: '//trim(fname) , errflg, errmsg) - if (errflg .ne. 0) return - ! Convert to radians - do i=1,im - lon(i) = lon(i) * deg2rad - enddo - do j=1,jm - lat(j) = lat(j) * deg2rad - enddo - else - errmsg = 'FATAL Error in Land_IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' - errflg = 1 - return - endif - -! Initialize lat-lon to Cubed bi-linear interpolation coeff: - do j = 1,size(Init_parm_xlon,2) - do i = 1,size(Init_parm_xlon,1) - ! print*,i,j,is-1+j,js-1+j - agrid(is-1+i,js-1+j,1)=Init_parm_xlon(i,j) - agrid(is-1+i,js-1+j,2)=Init_parm_xlat(i,j) - enddo - enddo - call remap_coef( is, ie, js, je, is, ie, js, je, & - im, jm, lon, lat, id1, id2, jdc, s2c, & - agrid) - deallocate ( lon, lat,agrid ) - if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) - if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) - allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) ! allocate arrays that will hold iau state @@ -410,27 +361,111 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms enddo enddo - ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid - allocate (wk3_stc(nfiles, 1:im,jbeg:jend, 1:km)) - allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) - do k=1, nfiles - call read_iau_forcing_all_timesteps(Land_IAU_Control, & - 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(k)), errmsg, errflg, & - wk3_stc(k, :, :, :), wk3_slc(k, :, :, :)) - enddo + if (Land_IAU_Control%gaussian_inc_file) then + !set up interpolation weights to go from GSI's gaussian grid to cubed sphere + deg2rad = pi/180. + ! npz = Land_IAU_Control%levs + fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1)) + inquire (file=trim(fname), exist=exists) + if (exists) then ! if( file_exist(fname) ) then + ! call open_ncfile( fname, ncid ) + status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file + call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) + if (errflg .ne. 0) return + call get_nc_dimlen(ncid, "longitude", im, errflg, errmsg) + if (errflg .ne. 0) return + call get_nc_dimlen(ncid, "latitude", jm, errflg, errmsg) + if (errflg .ne. 0) return + km = n_soill + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) write(*,*) fname, ' DA increment dimensions:', im,jm,km + allocate (lon(im) ) + allocate (lat(jm) ) + call get_var1d(ncid, im, "longitude", lon, errflg, errmsg) + if (errflg .ne. 0) return + call get_var1d(ncid, jm, "latitude", lat, errflg, errmsg) + if (errflg .ne. 0) return + status = nf90_close(ncid) + CALL netcdf_err(status, 'closing file: '//trim(fname) , errflg, errmsg) + if (errflg .ne. 0) return + ! Convert to radians + do i=1,im + lon(i) = lon(i) * deg2rad + enddo + do j=1,jm + lat(j) = lat(j) * deg2rad + enddo + else + errmsg = 'FATAL Error in Land_IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' + errflg = 1 + return + endif + + ! Initialize lat-lon to Cubed bi-linear interpolation coeff: + do j = 1,size(Init_parm_xlon,2) + do i = 1,size(Init_parm_xlon,1) + ! print*,i,j,is-1+j,js-1+j + agrid(is-1+i,js-1+j,1)=Init_parm_xlon(i,j) + agrid(is-1+i,js-1+j,2)=Init_parm_xlat(i,j) + enddo + enddo + call remap_coef( is, ie, js, je, is, ie, js, je, & + im, jm, lon, lat, id1, id2, jdc, s2c, & + agrid) + + if (allocated(lon)) deallocate (lon) + if (allocated(lat)) deallocate (lat) + if (allocated(agrid)) deallocate (agrid) + if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) + if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) + + ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid + allocate (wk3_stc(nfiles, 1:im,jbeg:jend, 1:km)) + allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) + do k=1, nfiles + call read_iau_forcing_all_timesteps(Land_IAU_Control, & + 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(k)), errmsg, errflg, & + wk3_stc(k, :, :, :), wk3_slc(k, :, :, :)) + enddo + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) + if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window + call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%wt) + endif + if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them + allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) + allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) + Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) + endif + else ! increment files in fv3 tiles + ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid + ! increments already in the fv3 modele grid--no need for interpolation + ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid + allocate (wk3_stc(nfiles, 1:im,jbeg:jend, 1:km)) + allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) + do k=1, nfiles + call read_iau_forcing_fv3(Land_IAU_Control, & + 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(k)), errmsg, errflg, & + + Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) + enddo + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) + if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window + call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%wt) + endif + if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them + allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) + allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) + Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) + endif - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) - if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window - call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%wt) - endif - if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them - allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) - allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) - Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) endif + + ! print*,'end of IAU init',dt,rdt end subroutine land_iau_mod_init @@ -599,8 +634,8 @@ subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errfl wk3_out_stc, wk3_out_slc) !, fname_sfc) is, ie, js, je, ks,ke, type (land_iau_control_type), intent(in) :: Land_IAU_Control character(len=*), intent(in) :: fname - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg real(kind=kind_phys), intent(out) :: wk3_out_stc(1:im, jbeg:jend, 1:km) real(kind=kind_phys), intent(out) :: wk3_out_slc(1:im, jbeg:jend, 1:km) @@ -623,7 +658,7 @@ subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errfl call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) if (errflg .ne. 0) return else - errmsg = 'FATAL Error in land read_iau_forcing_all_timesteps: Expected file '//trim(fname)//' for DA increment does not exist' + errmsg = 'FATAL Error in land iau read_iau_forcing_all_timesteps: Expected file '//trim(fname)//' for DA increment does not exist' errflg = 1 return endif @@ -661,6 +696,80 @@ subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errfl end subroutine read_iau_forcing_all_timesteps +subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errmsg, errflg) + + type (land_iau_control_type), intent(in) :: Land_IAU_Control + ! character(len=*), intent(in) :: fname + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + real(kind=kind_phys), intent(out) :: stc_inc_out(1:im, jbeg:jend, 1:km) + real(kind=kind_phys), intent(out) :: slc_inc_out(1:im, jbeg:jend, 1:km) + + integer :: i, j, k, l, npz + integer :: i1, i2, j1 + logical :: exists + integer :: ncid, status, varid + integer :: ierr + character(len=500) :: fname + character(len=2) :: tile_str + + character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] + character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] + + !Errors messages handled through CCPP error handling variables + errmsg = '' + errflg = 0 + + write(tile_str, '(I0)') Land_IAU_Control%tile_num + + fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1))//".tile"//tile_str//".nc" + + inquire (file=trim(fname), exist=exists) + if (exists) then + status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file + call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) + if (errflg .ne. 0) return + else + errmsg = 'FATAL Error in land iau read_iau_forcing_fv3: Expected file '//trim(fname)//' for DA increment does not exist' + errflg = 1 + return + endif + + do i = 1, size(stc_vars) + print *, trim(stc_vars(i)) + ! call check_var_exists(ncid, trim(stc_vars(i)), ierr) + status = nf90_inq_varid(ncid, trim(stc_vars(i)), varid) + if (status == nf90_noerr) then !if (ierr == 0) then + ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) + call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i), status) + call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg_out) + if (errflg .ne. 0) return + else + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, & + 'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' + wk3_out_stc(:, :, i) = 0. + endif + enddo + do i = 1, size(slc_vars) + print *, trim(slc_vars(i)) + status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) + if (status == nf90_noerr) then !if (ierr == 0) then + ! call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) + call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i), status) + call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg_out) + if (errflg .ne. 0) return + else + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,& + 'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' + wk3_out_slc(:, :, i) = 0. + endif + enddo + + call close_ncfile(ncid) + + +end subroutine read_iau_forcing_fv3 + subroutine interp_inc_at_timestep(Land_IAU_Control, km_in, wk3_in, var, errmsg, errflg) !field_name, , jbeg, jend) ! interpolate increment from GSI gaussian grid to cubed sphere ! everying is on the A-grid, earth relative @@ -670,8 +779,8 @@ subroutine interp_inc_at_timestep(Land_IAU_Control, km_in, wk3_in, var, errmsg, real(kind=kind_phys), intent(in) :: wk3_in(1:im,jbeg:jend, 1:km_in) real(kind=kind_phys), dimension(is:ie, js:je, 1:km), intent(inout) :: var - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg integer:: i1, i2, j1, k, j, i do k=1,km_in diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 5bae760a6..b95d62a13 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -51,8 +51,8 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & do_mynnsfclay,do_mynnedmf, & errmsg, errflg, & mpi_root, & - fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, nblks, & - blksz, xlon, xlat, & + fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, tile_num, & + nblks, blksz, xlon, xlat, & lsoil, lsnow_lsm, dtp, fhour) use machine, only: kind_phys @@ -78,9 +78,13 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & character(*), intent(in) :: fn_nml character(len=:), intent(in), dimension(:), pointer :: input_nml_file integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks + integer, intent(in) :: tile_num !GFS_control_type%tile_num integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + + + integer, intent(in) :: lsoil, lsnow_lsm real(kind=kind_phys), intent(in) :: dtp, fhour ! type(gfs_data_type), dimension(:), intent(inout) :: GFS_Data ! !(one:) @@ -135,7 +139,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & ! Read Land IAU settings call land_iau_mod_set_control(Land_IAU_Control, fn_nml, input_nml_file, & - me, mpi_root, isc,jsc, nx, ny, nblks, blksz, & + me, mpi_root, isc,jsc, nx, ny, tile_num, nblks, blksz, & lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) ! Initialize IAU for land call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errmsg, errflg) @@ -279,6 +283,8 @@ subroutine noahmpdrv_timestep_init (isot, ivegsrc, itime, fhour, delt, km, & !IAU increments are in units of 1/sec !Land_IAU_Control%dtp !* only updating soil temp for now lsoil_incr = Land_IAU_Control%lsoil_incr + +!---this should be ncol?? as last block may be shorter (check blksz)? lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny print*,'adjusting first ', lsoil_incr, ' surface layers only' diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 2f2ccba2f..2d500d060 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -155,6 +155,12 @@ dimensions = () type = integer intent = in + [tile_num] + standard_name = index_of_cubed_sphere_tile + long_name = tile number + units = none + dimensions = () + type = integer [nblks] standard_name = ccpp_block_count long_name = for explicit data blocking: number of blocks From df9f6409eeb55cae857642695401e9c21fdaef72 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 17 Jun 2024 10:10:41 -0400 Subject: [PATCH 026/154] update driver_timestepinit --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 109 +++++++++++------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 7 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 46 +++++++- 3 files changed, 117 insertions(+), 45 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index fefcd53c2..b200da916 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -440,32 +440,31 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms endif else ! increment files in fv3 tiles ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid - ! increments already in the fv3 modele grid--no need for interpolation - ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid - allocate (wk3_stc(nfiles, 1:im,jbeg:jend, 1:km)) - allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) - do k=1, nfiles - call read_iau_forcing_fv3(Land_IAU_Control, & - 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(k)), errmsg, errflg, & - - Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) - enddo - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) + ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) + ! allocate (wk3_slc(n_t, 1:im,jbeg:jend, 1:km)) + call read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errflg) + ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) + + ! increments already in the fv3 modele grid--no need for interpolation + Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + Land_IAU_state%inc1%slc_inc(:, :, :) = wk3_slc(1, :, :, :) + ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) + ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%wt) endif if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) - Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) + Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) + + Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(2, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(2, :, :, :) + ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) + ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) endif - endif - ! print*,'end of IAU init',dt,rdt end subroutine land_iau_mod_init @@ -574,11 +573,14 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e Land_IAU_state%inc1=Land_IAU_state%inc2 ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(Land_IAU_Control%iau_inc_files(itnext)) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'interpolating next lnd iau increment ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(itnext, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(itnext, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, 1, wk3_t2m(itnext, :, :, :), Land_IAU_state%inc2%tmp2m_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, 1, wk3_q2m(itnext, :, :, :), Land_IAU_state%inc2%spfh2m_inc, errmsg, errflg) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'copying/interpolating next lnd iau increment ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) + if (Land_IAU_Control%gaussian_inc_file) then + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(itnext, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) + call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(itnext, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) + else + Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + ` Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) + endif endif call updateiauforcing(Land_IAU_Control,Land_IAU_Data,Land_IAU_state%wt) endif @@ -602,8 +604,6 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, wt) Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%stc_inc(i,j,k))*rdt*wt Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%slc_inc(i,j,k))*rdt*wt end do - Land_IAU_Data%tmp2m_inc(i,j,1) =(delt*Land_IAU_state%inc1%tmp2m_inc(i,j,1) + (1.-delt)* Land_IAU_state%inc2%tmp2m_inc(i,j,1))*rdt*wt - Land_IAU_Data%spfh2m_inc(i,j,1) =(delt*Land_IAU_state%inc1%spfh2m_inc(i,j,1) + (1.-delt)* Land_IAU_state%inc2%spfh2m_inc(i,j,1))*rdt*wt enddo enddo end subroutine updateiauforcing @@ -623,8 +623,6 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, wt) Land_IAU_Data%stc_inc(i,j,k) = wt*Land_IAU_state%inc1%stc_inc(i,j,k)*rdt Land_IAU_Data%slc_inc(i,j,k) = wt*Land_IAU_state%inc1%slc_inc(i,j,k)*rdt end do - Land_IAU_Data%tmp2m_inc(i,j,1) = wt*Land_IAU_state%inc1%tmp2m_inc(i,j,1)*rdt - Land_IAU_Data%spfh2m_inc(i,j,1) = wt*Land_IAU_state%inc1%spfh2m_inc(i,j,1)*rdt enddo enddo @@ -702,16 +700,17 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm ! character(len=*), intent(in) :: fname character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg - real(kind=kind_phys), intent(out) :: stc_inc_out(1:im, jbeg:jend, 1:km) - real(kind=kind_phys), intent(out) :: slc_inc_out(1:im, jbeg:jend, 1:km) + real(kind=kind_phys), allocatable intent(out) :: stc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) + real(kind=kind_phys), allocatable intent(out) :: slc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) - integer :: i, j, k, l, npz - integer :: i1, i2, j1 + integer :: i, it !j, k, l, npz, logical :: exists integer :: ncid, status, varid integer :: ierr character(len=500) :: fname character(len=2) :: tile_str + integer :: n_t, n_y, n_x + ! integer :: isc, jsc character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] @@ -723,6 +722,8 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm write(tile_str, '(I0)') Land_IAU_Control%tile_num fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1))//".tile"//tile_str//".nc" + ! isc = Land_IAU_Control%isc + ! jsc = Land_IAU_Control%jsc inquire (file=trim(fname), exist=exists) if (exists) then @@ -734,34 +735,60 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm errflg = 1 return endif + ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) + call get_nc_dimlen(ncid, "Time", n_t, errflg, errmsg) + if (errflg .ne. 0) return + call get_nc_dimlen(ncid, "yaxis_1", n_y, errflg, errmsg) + if (errflg .ne. 0) return + call get_nc_dimlen(ncid, "xaxis_1", n_x, errflg, errmsg) + if (errflg .ne. 0) return + + if (n_x .lt. Land_IAU_Control%nx) then + errmsg = 'Error in land iau read_iau_forcing_fv3: Land_IAU_Control%nx bigger than dim xaxis_1 in file '//trim(fname) + errflg = 1 + return + endif + if (n_y .lt. Land_IAU_Control%ny) then + errmsg = 'Error in land iau read_iau_forcing_fv3: Land_IAU_Control%ny bigger than dim yaxis_1 in file '//trim(fname) + errflg = 1 + return + endif + + allocate(stc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) + allocate(slc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) do i = 1, size(stc_vars) print *, trim(stc_vars(i)) ! call check_var_exists(ncid, trim(stc_vars(i)), ierr) status = nf90_inq_varid(ncid, trim(stc_vars(i)), varid) if (status == nf90_noerr) then !if (ierr == 0) then - ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) - call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg_out) - if (errflg .ne. 0) return + do it = 1, n_t + ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) + call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, stc_inc_out(it,:, :, i), status) + ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, stc_inc_out(it,:, :, i), status) + call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg_out) + if (errflg .ne. 0) return + enddo else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, & 'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' - wk3_out_stc(:, :, i) = 0. + stc_inc_out(:, :, :, i) = 0. endif enddo do i = 1, size(slc_vars) print *, trim(slc_vars(i)) status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) if (status == nf90_noerr) then !if (ierr == 0) then - ! call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) - call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg_out) - if (errflg .ne. 0) return + do it = 1, n_t + call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, slc_inc_out(it, :, :, i), status) + ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, slc_inc_out(it, :, :, i), status) + call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg_out) + if (errflg .ne. 0) return + end do else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,& 'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' - wk3_out_slc(:, :, i) = 0. + slc_inc_out(:, :, :, i) = 0. endif enddo @@ -890,7 +917,7 @@ end subroutine remap_coef !! @param[out] mask Land mask for increments !! @author Clara Draper @date March 2021 !! @author Yuan Xue: introduce stype to make the mask calculation more generic -subroutine calculate_landinc_mask(swe,vtype,stype,lensfc,veg_type_landice,mask) +subroutine calculate_landinc_mask(swe,vtype,stype,lensfc,veg_type_landice, mask) implicit none diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index b95d62a13..ad6d9f2f9 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -170,9 +170,9 @@ end subroutine noahmpdrv_init !! @param[inout] slc_adj Analysis liquid soil moisture states !! @param[in] stc_updated Integer to record whether STC in each grid cell was updated -subroutine noahmpdrv_timestep_init (isot, ivegsrc, itime, fhour, delt, km, & !me, mpi_root, - soiltyp, vegtype, weasd, & - stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, +subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, + isot, ivegsrc, soiltyp, vegtype, weasd, & + stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, use machine, only: kind_phys use namelist_soilveg @@ -295,6 +295,7 @@ subroutine noahmpdrv_timestep_init (isot, ivegsrc, itime, fhour, delt, km, & nfrozen = 0 ! not update as frozen soil nfrozen_upd = 0 ! not update as frozen soil +!TODO---if only fv3 increment files are used, this can be read from file allocate(mask_tile(lensfc)) call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, & !veg_type_landice, mask_tile) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 2d500d060..d561a0fd0 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -155,7 +155,7 @@ dimensions = () type = integer intent = in - [tile_num] +[tile_num] standard_name = index_of_cubed_sphere_tile long_name = tile number units = none @@ -256,6 +256,42 @@ dimensions = () type = integer intent = in +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent= in +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent= in +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [stc] standard_name = soil_temperature long_name = soil temperature @@ -272,6 +308,14 @@ type = real kind = kind_phys intent = inout +[smc] + standard_name = volume_fraction_of_condensed_water_in_soil + long_name = total soil moisture + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From ea2f78bdd69f52af0a3d8c7e4f80967d55dea945 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 17 Jun 2024 10:21:09 -0400 Subject: [PATCH 027/154] remove duplicte names --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index d561a0fd0..aa27f29fc 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -376,13 +376,6 @@ [ccpp-arg-table] name = noahmpdrv_run type = scheme -[nb] - standard_name = ccpp_block_number - long_name = number of block for explicit data blocking in CCPP - units = index - dimensions = () - type = integer - intent = in [im] standard_name = horizontal_loop_extent long_name = horizontal dimension @@ -411,14 +404,6 @@ dimensions = () type = integer intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in [ps] standard_name = surface_air_pressure long_name = surface pressure From 4737da1fd24465d80fd31b5d923980ad09aa65a7 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 17 Jun 2024 10:25:51 -0400 Subject: [PATCH 028/154] remove duplicte names --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 28 ++++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index ad6d9f2f9..dcfe53146 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -9,35 +9,35 @@ !! as diagnotics calculation. !> This module contains the CCPP-compliant NoahMP land surface model driver. -module noahmpdrv + module noahmpdrv - use module_sf_noahmplsm + use module_sf_noahmplsm - ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) - use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & + ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) + use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & land_iau_mod_set_control, land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & calculate_landinc_mask - implicit none + implicit none - integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS + integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS - private + private - public :: noahmpdrv_init, noahmpdrv_run, & + public :: noahmpdrv_init, noahmpdrv_run, & noahmpdrv_timestep_init, noahmpdrv_timestep_finalize, noahmpdrv_finalize - !> \Land IAU data and control - ! Land IAU Control holds settings' information, maily read from namelist (e.g., + !> \Land IAU data and control + ! Land IAU Control holds settings' information, maily read from namelist (e.g., ! block of global domain that belongs to a process , ! whethrer to do IAU increment at this time step, ! time step informatoin, etc) - type (land_iau_control_type) :: Land_IAU_Control - ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step - type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks + type (land_iau_control_type) :: Land_IAU_Control + ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step + type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks - contains + contains !> \ingroup NoahMP_LSM !! \brief This subroutine is called during the CCPP initialization phase and calls set_soilveg() to From bb042f3bbbf7833377578ef7261fc9de9ddb5ea0 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 17 Jun 2024 10:30:34 -0400 Subject: [PATCH 029/154] remove duplicte names --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 32 ++++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index dcfe53146..280f616c3 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -11,33 +11,33 @@ !> This module contains the CCPP-compliant NoahMP land surface model driver. module noahmpdrv - use module_sf_noahmplsm + use module_sf_noahmplsm - ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) - use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & + ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) + use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & land_iau_mod_set_control, land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & calculate_landinc_mask - implicit none + implicit none - integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS + integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS - private + private - public :: noahmpdrv_init, noahmpdrv_run, & + public :: noahmpdrv_init, noahmpdrv_run, & noahmpdrv_timestep_init, noahmpdrv_timestep_finalize, noahmpdrv_finalize - !> \Land IAU data and control - ! Land IAU Control holds settings' information, maily read from namelist (e.g., - ! block of global domain that belongs to a process , - ! whethrer to do IAU increment at this time step, - ! time step informatoin, etc) - type (land_iau_control_type) :: Land_IAU_Control - ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step - type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks + !> \Land IAU data and control + ! Land IAU Control holds settings' information, maily read from namelist (e.g., + ! block of global domain that belongs to a process , + ! whethrer to do IAU increment at this time step, + ! time step informatoin, etc) + type (land_iau_control_type) :: Land_IAU_Control + ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step + type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks - contains + contains !> \ingroup NoahMP_LSM !! \brief This subroutine is called during the CCPP initialization phase and calls set_soilveg() to From 2975f64b8460caf15eacda6b7041c56113b2a6e6 Mon Sep 17 00:00:00 2001 From: tsga Date: Mon, 17 Jun 2024 18:38:09 +0000 Subject: [PATCH 030/154] fix arg_table_noahmpdrv_finalize --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 3 ++- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index b95d62a13..3574997ba 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -402,11 +402,12 @@ subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp end subroutine noahmpdrv_timestep_finalize - !> \ingroup NoahMP_LSM + !> \ingroup NoahMP_LSM !! \brief This subroutine mirrors noahmpdrv_init !! it calls land_iau_finalize which frees up allocated memory by IAU_init (in noahmdrv_init) !! \section arg_table_noahmpdrv_finalize Argument Table !! \htmlinclude noahmpdrv_finalize.html +!! subroutine noahmpdrv_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, use machine, only: kind_phys diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 2d500d060..3cf4def3c 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -155,12 +155,13 @@ dimensions = () type = integer intent = in - [tile_num] +[tile_num] standard_name = index_of_cubed_sphere_tile long_name = tile number units = none dimensions = () type = integer + intent = in [nblks] standard_name = ccpp_block_count long_name = for explicit data blocking: number of blocks From d009364a2fb4f52764dacbcb11871aeacd7d10ab Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 17 Jun 2024 16:09:30 -0400 Subject: [PATCH 031/154] debug --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index b200da916..9dae88e33 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -969,7 +969,7 @@ SUBROUTINE NETCDF_ERR(ERR, STRING, errflg, errmsg_out) IF (ERR == NF90_NOERR) RETURN ERRMSG = NF90_STRERROR(ERR) PRINT*,'FATAL ERROR in Land IAU ', TRIM(STRING), ': ', TRIM(ERRMSG) - errmsg_out = 'FATAL ERROR in Land IAU ', TRIM(STRING), ': ', TRIM(ERRMSG) + errmsg_out = 'FATAL ERROR in Land IAU '//TRIM(STRING), ': '//TRIM(ERRMSG) ! CALL MPI_ABORT(MPI_COMM_WORLD, 999) errflg = 1 return From ae680688888fbc424f1ebcdf031ef11e57489dd6 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 18 Jun 2024 09:58:03 -0400 Subject: [PATCH 032/154] fix error about horizontal dimention --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 44361d81f..0b9e17f97 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -275,21 +275,21 @@ standard_name = soil_type_classification long_name = soil type at each grid cell units = index - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = integer intent= in [vegtype] standard_name = vegetation_type_classification long_name = vegetation type at each grid cell units = index - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = integer intent= in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land units = mm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys intent = inout @@ -313,7 +313,7 @@ standard_name = volume_fraction_of_condensed_water_in_soil long_name = total soil moisture units = frac - dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + dimensions = (horizontal_dimension,vertical_dimension_of_soil) type = real kind = kind_phys intent = inout From 04e246dcdde0f4d713410afe0cf19e5007c5fdc7 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 18 Jun 2024 10:33:39 -0400 Subject: [PATCH 033/154] fix error about horizontal dimention --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 9dae88e33..618a92362 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -969,7 +969,7 @@ SUBROUTINE NETCDF_ERR(ERR, STRING, errflg, errmsg_out) IF (ERR == NF90_NOERR) RETURN ERRMSG = NF90_STRERROR(ERR) PRINT*,'FATAL ERROR in Land IAU ', TRIM(STRING), ': ', TRIM(ERRMSG) - errmsg_out = 'FATAL ERROR in Land IAU '//TRIM(STRING), ': '//TRIM(ERRMSG) + errmsg_out = 'FATAL ERROR in Land IAU '//TRIM(STRING)//': '//TRIM(ERRMSG) ! CALL MPI_ABORT(MPI_COMM_WORLD, 999) errflg = 1 return @@ -983,6 +983,7 @@ subroutine get_nc_dimlen(ncid, dim_name, dim_len, errflg, errmsg_out ) integer :: dimid integer :: errflg character(len=*) :: errmsg_out + integer :: status !Errors messages handled through CCPP error handling variables errmsg_out = '' @@ -1009,7 +1010,7 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) real(kind=kind_phys), intent(out):: var_arr(dim_len) integer :: errflg character(len=*) :: errmsg_out - integer :: var_id + integer :: varid !Errors messages handled through CCPP error handling variables errmsg_out = '' @@ -1019,6 +1020,7 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) CALL NETCDF_ERR(status, 'getting varid: '//trim(var_name), errflg, errmsg_out) if (errflg .ne. 0) return status = nf90_get_var(ncid, varid, var_arr) + ! start = (/1/), count = (/dim_len/)) CALL NETCDF_ERR(status, 'reading var: '//trim(var_name), errflg, errmsg_out) end subroutine get_var1d From 264eaf30f725beb5d0a70d8202dae952573b1b86 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 18 Jun 2024 10:58:31 -0400 Subject: [PATCH 034/154] fix netcdf error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 618a92362..7a70c8c37 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -579,7 +579,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(itnext, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) else Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - ` Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) + Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif endif call updateiauforcing(Land_IAU_Control,Land_IAU_Data,Land_IAU_state%wt) @@ -667,7 +667,7 @@ subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errfl status = nf90_inq_varid(ncid, trim(stc_vars(i)), varid) if (status == nf90_noerr) then !if (ierr == 0) then call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg_out) + call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, & @@ -681,7 +681,7 @@ subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errfl if (status == nf90_noerr) then !if (ierr == 0) then ! call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg_out) + call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,& @@ -700,8 +700,8 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm ! character(len=*), intent(in) :: fname character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg - real(kind=kind_phys), allocatable intent(out) :: stc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) - real(kind=kind_phys), allocatable intent(out) :: slc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) + real(kind=kind_phys), allocatable, intent(out) :: stc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) + real(kind=kind_phys), allocatable, intent(out) :: slc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) integer :: i, it !j, k, l, npz, logical :: exists @@ -1010,7 +1010,7 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) real(kind=kind_phys), intent(out):: var_arr(dim_len) integer :: errflg character(len=*) :: errmsg_out - integer :: varid + integer :: varid, status !Errors messages handled through CCPP error handling variables errmsg_out = '' From fb21cc0b8bfb2d8126f97e877804d4e92615feac Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 18 Jun 2024 11:11:33 -0400 Subject: [PATCH 035/154] fix netcdf error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 7a70c8c37..ce9e092c6 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -766,7 +766,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, stc_inc_out(it,:, :, i), status) ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, stc_inc_out(it,:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg_out) + call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return enddo else @@ -782,7 +782,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm do it = 1, n_t call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, slc_inc_out(it, :, :, i), status) ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, slc_inc_out(it, :, :, i), status) - call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg_out) + call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return end do else From 9675dc804a473ca9cec30c14151d07b1ea40b2bf Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 18 Jun 2024 11:52:38 -0400 Subject: [PATCH 036/154] fix smc adjustment error --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 20 +++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index ce9e092c6..f9c767c18 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -99,7 +99,7 @@ module land_iau_mod type(land_iau_state_type) :: Land_IAU_state public land_iau_control_type, land_iau_external_data_type, land_iau_mod_set_control, & - land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize + land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, calculate_landinc_mask contains diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 9eb3671a4..cb38dbfb4 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -15,8 +15,8 @@ module noahmpdrv ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & - land_iau_mod_set_control, land_iau_mod_init, - land_iau_mod_getiauforcing, land_iau_mod_finalize, & + land_iau_mod_set_control, land_iau_mod_init, & + land_iau_mod_getiauforcing, land_iau_mod_finalize, & calculate_landinc_mask implicit none @@ -212,10 +212,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo integer :: soiltype, n_stc real :: slc_new - integer :: i, l, jj, k, ib + integer :: i, j, ij, l, k, ib integer :: lensfc - real (kind=kind_phys), dimension(max_soiltyp) :: maxsmc, bb, satpsi + ! real (kind=kind_phys), dimension(max_soiltyp) :: maxsmc, bb, satpsi ! real, dimension(30) :: maxsmc, bb, satpsi real, parameter :: tfreez=273.16 !< con_t0c in physcons real, parameter :: hfus=0.3336e06 !< latent heat of fusion(j/kg) @@ -262,7 +262,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! local variable to copy blocked data Land_IAU_Data%stc_inc allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols - allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) + allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) stc_updated = 0 ib = 1 do j = 1, Land_IAU_Control%ny !ny @@ -330,13 +330,13 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! enddo deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) - ! add (consistency) adjustments for updated soil temp and moisture +! (consistency) adjustments for updated soil temp and moisture ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) call read_mp_table_parameters(errmsg, errflg) - maxsmc(1:slcats) = smcmax_table(1:slcats) - bb(1:slcats) = bexp_table(1:slcats) - satpsi(1:slcats) = psisat_table(1:slcats) + ! maxsmc(1:slcats) = smcmax_table(1:slcats) + ! bb(1:slcats) = bexp_table(1:slcats) + ! satpsi(1:slcats) = psisat_table(1:slcats) if (errflg .ne. 0) then print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' @@ -367,7 +367,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo enddo deallocate(stc_updated) - allocate(mask_tile) + deallocate(mask_tile) write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me write(*,'(a,i8)') ' soil grid total', lensfc From 619fbc5659fa874c74cda50d59b47828ffad2395 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 18 Jun 2024 12:18:24 -0400 Subject: [PATCH 037/154] fix smc adjustment error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index f9c767c18..452afc429 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -690,7 +690,8 @@ subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errfl endif enddo - call close_ncfile(ncid) + status =nf90_close(ncid) + call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) end subroutine read_iau_forcing_all_timesteps @@ -792,7 +793,8 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm endif enddo - call close_ncfile(ncid) + status =nf90_close(ncid) + call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) end subroutine read_iau_forcing_fv3 From bc0e3eafd5821aff984ae73d97266026045715bd Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 19 Jun 2024 13:21:56 -0400 Subject: [PATCH 038/154] fix namelist typo --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 452afc429..0acf4ee0b 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -133,14 +133,14 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me logical :: do_land_iau = .false. real(kind=kind_phys) :: land_iau_delthrs = 0 !< iau time interval (to scale increments) character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files - real(kind=kind_phys) :: land_iaufhrs(7) = -1 !< forecast hours associated with increment files + real(kind=kind_phys) :: land_iau_fhrs(7) = -1 !< forecast hours associated with increment files logical :: land_iau_filter_increments = .false. !< filter IAU increments - logical :: gaussian_inc_file = .false. + logical :: land_iau_gaussian_inc_file = .false. integer :: lsoil_incr = 4 - NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iaufhrs, & - land_iau_filter_increments, & !, lnd_iau_drymassfixer - lsoil_incr, gaussian_inc_file + NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, land_iau_gaussian_inc_file, & + land_iau_filter_increments, & + lsoil_incr, !Errors messages handled through CCPP error handling variables errmsg = '' @@ -190,9 +190,9 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%do_land_iau = do_land_iau Land_IAU_Control%iau_delthrs = land_iau_delthrs Land_IAU_Control%iau_inc_files = land_iau_inc_files - Land_IAU_Control%iaufhrs = land_iaufhrs + Land_IAU_Control%iaufhrs = land_iau_fhrs Land_IAU_Control%iau_filter_increments = land_iau_filter_increments - ! Land_IAU_Control%iau_drymassfixer = lnd_iau_drymassfixer + Land_IAU_Control%gaussian_inc_file = land_iau_gaussian_inc_file Land_IAU_Control%lsoil_incr = lsoil_incr Land_IAU_Control%me = me @@ -210,7 +210,6 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%input_nml_file = input_nml_file Land_IAU_Control%input_nml_file_length = input_nml_file_length - Land_IAU_Control%gaussian_inc_file = gaussian_inc_file allocate(Land_IAU_Control%blksz(nblks)) allocate(Land_IAU_Control%blk_strt_indx(nblks)) From 7208087b09aaf75da24e3e146c8a03a4453ecd4b Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 19 Jun 2024 14:50:54 -0400 Subject: [PATCH 039/154] fix netcdf dim error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 0acf4ee0b..ed94e835e 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -140,7 +140,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, land_iau_gaussian_inc_file, & land_iau_filter_increments, & - lsoil_incr, + lsoil_incr !Errors messages handled through CCPP error handling variables errmsg = '' @@ -359,6 +359,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms jend = max(jend, j1+1) enddo enddo + print*, "proc ", Land_IAU_Control%me, " im ", im, " jbeg jend ", jbeg, jend if (Land_IAU_Control%gaussian_inc_file) then !set up interpolation weights to go from GSI's gaussian grid to cubed sphere From c5e52ddc9fa1bede49dde455d1f1320c17b20360 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 19 Jun 2024 16:27:36 -0400 Subject: [PATCH 040/154] fix netcdf dim error --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 137 +++++++++++------- 1 file changed, 88 insertions(+), 49 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index ed94e835e..62e1d6311 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -33,7 +33,7 @@ module land_iau_mod integer,allocatable,dimension(:,:) :: id1,id2,jdc real(kind=kind_phys) :: deg2rad,dt,rdt - integer :: im,jm,km,nfiles,ncid + integer :: im, jm, km, nfiles, ntimes, ncid integer:: jbeg, jend integer :: n_soill, n_snowl !soil and snow layers @@ -242,7 +242,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms integer:: ib, i, j, k, nstep, kstep integer:: i1, i2, j1 logical:: found - integer nfilesall + integer nfilesall, ntimesall integer, allocatable :: idt(:) real (kind=kind_phys), allocatable :: Init_parm_xlon (:, :) real (kind=kind_phys), allocatable :: Init_parm_xlat (:, :) @@ -286,40 +286,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms allocate(jdc(is:ie,js:je)) allocate(agrid(is:ie,js:je,2)) -! determine number of increment files to read, and the valid forecast hours - nfilesall = size(Land_IAU_Control%iau_inc_files) - nfiles = 0 - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,'in land_iau_init incfile1 iaufhr1 ', & - trim(Land_IAU_Control%iau_inc_files(1)),Land_IAU_Control%iaufhrs(1) - do k=1,nfilesall - if (trim(Land_IAU_Control%iau_inc_files(k)) .eq. '' .or. Land_IAU_Control%iaufhrs(k) .lt. 0) exit - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,k, " ", trim(adjustl(Land_IAU_Control%iau_inc_files(k))) - endif - nfiles = nfiles + 1 - enddo - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'nfiles = ',nfiles - if (nfiles < 1) then - return - endif - if (nfiles > 1) then - allocate(idt(nfiles-1)) - idt = Land_IAU_Control%iaufhrs(2:nfiles)-Land_IAU_Control%iaufhrs(1:nfiles-1) - do k=1,nfiles-1 - if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then - print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' - ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') - errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' - errflg = 1 - return - endif - enddo - deallocate(idt) - endif - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' - dt = (Land_IAU_Control%iau_delthrs*3600.) - rdt = 1.0/dt - allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) ! allocate arrays that will hold iau state @@ -348,20 +314,41 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms enddo Land_IAU_state%wt_normfact = (2*nstep+1)/normfact endif - - ! Find bounding latitudes: - jbeg = jm-1 - jend = 2 - do j=js,je - do i=is,ie - j1 = jdc(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) - enddo - enddo - print*, "proc ", Land_IAU_Control%me, " im ", im, " jbeg jend ", jbeg, jend - if (Land_IAU_Control%gaussian_inc_file) then + if (Land_IAU_Control%gaussian_inc_file) then + ! determine number of increment files to read, and the valid forecast hours + nfilesall = size(Land_IAU_Control%iau_inc_files) + nfiles = 0 + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,'in land_iau_init incfile1 iaufhr1 ', & + trim(Land_IAU_Control%iau_inc_files(1)),Land_IAU_Control%iaufhrs(1) + do k=1,nfilesall + if (trim(Land_IAU_Control%iau_inc_files(k)) .eq. '' .or. Land_IAU_Control%iaufhrs(k) .lt. 0) exit + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,k, " ", trim(adjustl(Land_IAU_Control%iau_inc_files(k))) + endif + nfiles = nfiles + 1 + enddo + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'nfiles = ',nfiles + if (nfiles < 1) then + return + endif + if (nfiles > 1) then + allocate(idt(nfiles-1)) + idt = Land_IAU_Control%iaufhrs(2:nfiles)-Land_IAU_Control%iaufhrs(1:nfiles-1) + do k=1,nfiles-1 + if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then + print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' + ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') + errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' + errflg = 1 + return + endif + enddo + deallocate(idt) + endif + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' + dt = (Land_IAU_Control%iau_delthrs*3600.) + rdt = 1.0/dt !set up interpolation weights to go from GSI's gaussian grid to cubed sphere deg2rad = pi/180. ! npz = Land_IAU_Control%levs @@ -411,6 +398,18 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms call remap_coef( is, ie, js, je, is, ie, js, je, & im, jm, lon, lat, id1, id2, jdc, s2c, & agrid) + + ! Find bounding latitudes: + jbeg = jm-1 + jend = 2 + do j=js,je + do i=is,ie + j1 = jdc(i,j) + jbeg = min(jbeg, j1) + jend = max(jend, j1+1) + enddo + enddo + print*, "proc ", Land_IAU_Control%me, " im ", im, " jbeg jend ", jbeg, jend if (allocated(lon)) deallocate (lon) if (allocated(lat)) deallocate (lat) @@ -439,6 +438,46 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) endif else ! increment files in fv3 tiles + if (trim(Land_IAU_Control%iau_inc_files(1)) .eq. '' .or. Land_IAU_Control%iaufhrs(1) .lt. 0) then ! only 1 file expected + print*, "warning! in Land IAU but increment file name is empty or iaufhrs(1) is negative" + return + endif + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,"increment file ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) + endif + + ! determine number of increment files to read, and the valid forecast hours + ntimesall = size(Land_IAU_Control%iaufhrs) + ntimes = 0 + do k=1,ntimesall + if (Land_IAU_Control%iaufhrs(k) .lt. 0) exit + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,k, " fhour ", Land_IAU_Control%iaufhrs(k) + endif + ntimes = ntimes + 1 + enddo + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'ntimes = ',ntimes + if (ntimes < 1) then + return + endif + if (ntimes > 1) then + allocate(idt(ntimes-1)) + idt = Land_IAU_Control%iaufhrs(2:ntimes)-Land_IAU_Control%iaufhrs(1:ntimes-1) + do k=1,ntimes-1 + if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then + print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' + ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') + errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' + errflg = 1 + return + endif + enddo + deallocate(idt) + endif + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' + dt = (Land_IAU_Control%iau_delthrs*3600.) + rdt = 1.0/dt + ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) ! allocate (wk3_slc(n_t, 1:im,jbeg:jend, 1:km)) From 08c49a6d5bfb509af87e9a2fad5bfbc3c2f831ca Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 20 Jun 2024 12:52:50 -0400 Subject: [PATCH 041/154] remove Gaussian files --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 566 ++++-------------- 1 file changed, 123 insertions(+), 443 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 62e1d6311..1f1cb85a0 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -10,7 +10,7 @@ !! \section land_iau_mod !> - reads settings from namelist file (which indicates if IAU increments are available or not) !> - reads in DA increments from GSI/JEDI DA at the start of (the DA) cycle -!> - interpolates increments to FV3 grid points (if increments are in Gaussian grid) +!> - maps increments to FV3 grid points belonging to mpi process !> - interpolates temporally (with filter, weights if required by configuration) !> - updates states with the interpolated increments @@ -28,21 +28,7 @@ module land_iau_mod private - real(kind=kind_phys),allocatable::s2c(:,:,:) - - integer,allocatable,dimension(:,:) :: id1,id2,jdc - - real(kind=kind_phys) :: deg2rad,dt,rdt - integer :: im, jm, km, nfiles, ntimes, ncid - integer:: jbeg, jend - - integer :: n_soill, n_snowl !soil and snow layers - logical :: do_land_iau - - integer :: is, ie, js, je - integer :: npz - - real(kind=kind_phys), allocatable:: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) + real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) type land_iau_internal_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) @@ -52,16 +38,17 @@ module land_iau_mod type land_iau_external_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:) - logical :: in_interval = .false. + logical :: in_interval = .false. end type land_iau_external_data_type type land_iau_state_type - type(land_iau_internal_data_type):: inc1 - type(land_iau_internal_data_type):: inc2 - real(kind=kind_phys) :: hr1 - real(kind=kind_phys) :: hr2 - real(kind=kind_phys) :: wt - real(kind=kind_phys) :: wt_normfact + type(land_iau_internal_data_type) :: inc1 + type(land_iau_internal_data_type) :: inc2 + real(kind=kind_phys) :: hr1 + real(kind=kind_phys) :: hr2 + real(kind=kind_phys) :: wt + real(kind=kind_phys) :: wt_normfact + real(kind=kind_phys) :: rdt end type land_iau_state_type type land_iau_control_type @@ -74,7 +61,7 @@ module land_iau_mod integer, allocatable :: blksz(:) ! this could vary for the last block integer, allocatable :: blk_strt_indx(:) - integer :: lsoil !< number of soil layers + integer :: lsoil !< number of soil layers ! this is the max dim (TBC: check it is consitent for noahmpdrv) integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model logical :: do_land_iau @@ -108,7 +95,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) !nlunit type (land_iau_control_type), intent(inout) :: Land_IAU_Control - character(*), intent(in) :: fn_nml !< namelist filename for surface data cycling + character(*), intent(in) :: fn_nml !< namelist filename for surface data cycling character(len=:), intent(in), dimension(:), pointer :: input_nml_file_i integer, intent(in) :: me, mpi_root !< MPI rank of master atmosphere processor integer, intent(in) :: isc, jsc, nx, ny, tile_num, nblks, lsoil, lsnow_lsm @@ -125,7 +112,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me character(len=512) :: ioerrmsg !character(len=32) :: fn_nml = "input.nml" character(len=:), pointer, dimension(:) :: input_nml_file => null() - integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads + integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads !> these are not available through the CCPP interface so need to read them from namelist file @@ -135,10 +122,10 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files real(kind=kind_phys) :: land_iau_fhrs(7) = -1 !< forecast hours associated with increment files logical :: land_iau_filter_increments = .false. !< filter IAU increments - logical :: land_iau_gaussian_inc_file = .false. + !logical :: land_iau_gaussian_inc_file = .false. integer :: lsoil_incr = 4 - NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, land_iau_gaussian_inc_file, & + NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & land_iau_filter_increments, & lsoil_incr @@ -230,27 +217,29 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms ! integer, intent(in) :: me, mpi_root type (land_iau_control_type), intent(in) :: Land_IAU_Control type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data - real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! local - character(len=128) :: fname - real(kind=kind_phys), allocatable:: lat(:), lon(:),agrid(:,:,:) - real(kind=kind_phys) sx,wx,wt,normfact,dtp - integer:: ib, i, j, k, nstep, kstep - integer:: i1, i2, j1 - logical:: found - integer nfilesall, ntimesall - integer, allocatable :: idt(:) - real (kind=kind_phys), allocatable :: Init_parm_xlon (:, :) - real (kind=kind_phys), allocatable :: Init_parm_xlat (:, :) - integer :: nlon, nlat + character(len=128) :: fname + real(kind=kind_phys) :: sx, wx, wt, normfact, dtp + integer :: k, nstep, kstep + integer :: nfilesall, ntimesall + integer, allocatable :: idt(:) + integer :: nlon, nlat ! integer :: nb, ix, nblks, blksz - logical :: exists - ! necdf vars - integer :: ncid, dimid, varid, status, IDIM + logical :: exists + integer :: ncid, dimid, varid, status, IDIM + + real(kind=kind_phys) :: dt, rdt + integer :: im, jm, km, nfiles, ntimes + + integer :: n_soill, n_snowl !soil and snow layers + logical :: do_land_iau + integer :: is, ie, js, je + integer :: npz !Errors messages handled through CCPP error handling variables errmsg = '' @@ -270,22 +259,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) - allocate(Init_parm_xlon(nlon,nlat), Init_parm_xlat(nlon,nlat)) - ib = 1 - do j = 1, nlat !ny - ! do i = 1, nx - Init_parm_xlon (:,j) = xlon(ib:ib+nlon-1) - Init_parm_xlat (:,j) = xlat(ib:ib+nlon-1) - ib = ib+nlon - ! enddo - enddo - - allocate(s2c(is:ie,js:je,4)) - allocate(id1(is:ie,js:je)) - allocate(id2(is:ie,js:je)) - allocate(jdc(is:ie,js:je)) - allocate(agrid(is:ie,js:je,2)) - allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) ! allocate arrays that will hold iau state @@ -314,196 +287,70 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errms enddo Land_IAU_state%wt_normfact = (2*nstep+1)/normfact endif - - if (Land_IAU_Control%gaussian_inc_file) then - ! determine number of increment files to read, and the valid forecast hours - nfilesall = size(Land_IAU_Control%iau_inc_files) - nfiles = 0 - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,'in land_iau_init incfile1 iaufhr1 ', & - trim(Land_IAU_Control%iau_inc_files(1)),Land_IAU_Control%iaufhrs(1) - do k=1,nfilesall - if (trim(Land_IAU_Control%iau_inc_files(k)) .eq. '' .or. Land_IAU_Control%iaufhrs(k) .lt. 0) exit - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,k, " ", trim(adjustl(Land_IAU_Control%iau_inc_files(k))) - endif - nfiles = nfiles + 1 - enddo - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'nfiles = ',nfiles - if (nfiles < 1) then - return - endif - if (nfiles > 1) then - allocate(idt(nfiles-1)) - idt = Land_IAU_Control%iaufhrs(2:nfiles)-Land_IAU_Control%iaufhrs(1:nfiles-1) - do k=1,nfiles-1 - if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then - print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' - ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') - errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' - errflg = 1 - return - endif - enddo - deallocate(idt) - endif - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' - dt = (Land_IAU_Control%iau_delthrs*3600.) - rdt = 1.0/dt - !set up interpolation weights to go from GSI's gaussian grid to cubed sphere - deg2rad = pi/180. - ! npz = Land_IAU_Control%levs - fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1)) - inquire (file=trim(fname), exist=exists) - if (exists) then ! if( file_exist(fname) ) then - ! call open_ncfile( fname, ncid ) - status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file - call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) - if (errflg .ne. 0) return - call get_nc_dimlen(ncid, "longitude", im, errflg, errmsg) - if (errflg .ne. 0) return - call get_nc_dimlen(ncid, "latitude", jm, errflg, errmsg) - if (errflg .ne. 0) return - km = n_soill - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) write(*,*) fname, ' DA increment dimensions:', im,jm,km - allocate (lon(im) ) - allocate (lat(jm) ) - call get_var1d(ncid, im, "longitude", lon, errflg, errmsg) - if (errflg .ne. 0) return - call get_var1d(ncid, jm, "latitude", lat, errflg, errmsg) - if (errflg .ne. 0) return - status = nf90_close(ncid) - CALL netcdf_err(status, 'closing file: '//trim(fname) , errflg, errmsg) - if (errflg .ne. 0) return - ! Convert to radians - do i=1,im - lon(i) = lon(i) * deg2rad - enddo - do j=1,jm - lat(j) = lat(j) * deg2rad - enddo - else - errmsg = 'FATAL Error in Land_IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' - errflg = 1 - return - endif - ! Initialize lat-lon to Cubed bi-linear interpolation coeff: - do j = 1,size(Init_parm_xlon,2) - do i = 1,size(Init_parm_xlon,1) - ! print*,i,j,is-1+j,js-1+j - agrid(is-1+i,js-1+j,1)=Init_parm_xlon(i,j) - agrid(is-1+i,js-1+j,2)=Init_parm_xlat(i,j) - enddo - enddo - call remap_coef( is, ie, js, je, is, ie, js, je, & - im, jm, lon, lat, id1, id2, jdc, s2c, & - agrid) - - ! Find bounding latitudes: - jbeg = jm-1 - jend = 2 - do j=js,je - do i=is,ie - j1 = jdc(i,j) - jbeg = min(jbeg, j1) - jend = max(jend, j1+1) - enddo - enddo - print*, "proc ", Land_IAU_Control%me, " im ", im, " jbeg jend ", jbeg, jend + ! increment files in fv3 tiles + if (trim(Land_IAU_Control%iau_inc_files(1)) .eq. '' .or. Land_IAU_Control%iaufhrs(1) .lt. 0) then ! only 1 file expected + print*, "warning! in Land IAU but increment file name is empty or iaufhrs(1) is negative" + return + endif + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,"increment file ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) + endif - if (allocated(lon)) deallocate (lon) - if (allocated(lat)) deallocate (lat) - if (allocated(agrid)) deallocate (agrid) - if (allocated(Init_parm_xlon)) deallocate(Init_parm_xlon) - if (allocated(Init_parm_xlat)) deallocate(Init_parm_xlat) - - ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid - allocate (wk3_stc(nfiles, 1:im,jbeg:jend, 1:km)) - allocate (wk3_slc(nfiles, 1:im,jbeg:jend, 1:km)) - do k=1, nfiles - call read_iau_forcing_all_timesteps(Land_IAU_Control, & - 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(k)), errmsg, errflg, & - wk3_stc(k, :, :, :), wk3_slc(k, :, :, :)) - enddo - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) - if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window - call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%wt) - endif - if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them - allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) - allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) - Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) - endif - else ! increment files in fv3 tiles - if (trim(Land_IAU_Control%iau_inc_files(1)) .eq. '' .or. Land_IAU_Control%iaufhrs(1) .lt. 0) then ! only 1 file expected - print*, "warning! in Land IAU but increment file name is empty or iaufhrs(1) is negative" - return - endif + ! determine number of valid forecast hours + ntimesall = size(Land_IAU_Control%iaufhrs) + ntimes = 0 + do k=1,ntimesall + if (Land_IAU_Control%iaufhrs(k) .lt. 0) exit if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,"increment file ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) + print *,k, " fhour ", Land_IAU_Control%iaufhrs(k) endif - - ! determine number of increment files to read, and the valid forecast hours - ntimesall = size(Land_IAU_Control%iaufhrs) - ntimes = 0 - do k=1,ntimesall - if (Land_IAU_Control%iaufhrs(k) .lt. 0) exit - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,k, " fhour ", Land_IAU_Control%iaufhrs(k) + ntimes = ntimes + 1 + enddo + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'ntimes = ',ntimes + if (ntimes < 1) then + return + endif + if (ntimes > 1) then + allocate(idt(ntimes-1)) + idt = Land_IAU_Control%iaufhrs(2:ntimes)-Land_IAU_Control%iaufhrs(1:ntimes-1) + do k=1,ntimes-1 + if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then + print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' + ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') + errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' + errflg = 1 + return endif - ntimes = ntimes + 1 enddo - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'ntimes = ',ntimes - if (ntimes < 1) then - return - endif - if (ntimes > 1) then - allocate(idt(ntimes-1)) - idt = Land_IAU_Control%iaufhrs(2:ntimes)-Land_IAU_Control%iaufhrs(1:ntimes-1) - do k=1,ntimes-1 - if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then - print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' - ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') - errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' - errflg = 1 - return - endif - enddo - deallocate(idt) - endif - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' - dt = (Land_IAU_Control%iau_delthrs*3600.) - rdt = 1.0/dt - - ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid - ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) - ! allocate (wk3_slc(n_t, 1:im,jbeg:jend, 1:km)) - call read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errflg) - ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) - - ! increments already in the fv3 modele grid--no need for interpolation - Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - Land_IAU_state%inc1%slc_inc(:, :, :) = wk3_slc(1, :, :, :) - ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(1, :, :, :), Land_IAU_state%inc1%stc_inc, errmsg, errflg) - ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(1, :, :, :), Land_IAU_state%inc1%slc_inc, errmsg, errflg) - if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window - call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%wt) - endif - if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them - allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) - allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) - Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - - Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(2, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(2, :, :, :) - ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(2, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) - ! call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(2, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) - endif + deallocate(idt) endif + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' + dt = (Land_IAU_Control%iau_delthrs*3600.) + rdt = 1.0/dt + Land_IAU_state%rdt = rdt + + ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid + ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) + ! allocate (wk3_slc(n_t, 1:im,jbeg:jend, 1:km)) + call read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errflg) + ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) + + ! increments already in the fv3 modele grid--no need for interpolation + Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + Land_IAU_state%inc1%slc_inc(:, :, :) = wk3_slc(1, :, :, :) + if (nfiles.EQ.1) then ! only need to get incrments once since constant forcing over window + call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) + endif + if (nfiles.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them + allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) + allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) + Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) + + Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(2, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(2, :, :, :) + endif ! print*,'end of IAU init',dt,rdt end subroutine land_iau_mod_init @@ -514,8 +361,8 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg if (allocated (wk3_stc)) deallocate (wk3_stc) if (allocated (wk3_slc)) deallocate (wk3_slc) @@ -536,8 +383,8 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e implicit none type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg real(kind=kind_phys) t1,t2,sx,wx,wt,dtp integer n,i,j,k,kstep,nstep,itnext @@ -585,7 +432,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 Land_IAU_Data%in_interval=.false. else - if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control,Land_IAU_Data,Land_IAU_state%wt) + if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control,Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact Land_IAU_Data%in_interval=.true. endif @@ -612,28 +459,31 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e Land_IAU_state%inc1=Land_IAU_state%inc2 ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(Land_IAU_Control%iau_inc_files(itnext)) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'copying/interpolating next lnd iau increment ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) - if (Land_IAU_Control%gaussian_inc_file) then - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_stc(itnext, :, :, :), Land_IAU_state%inc2%stc_inc, errmsg, errflg) - call interp_inc_at_timestep(Land_IAU_Control, km, wk3_slc(itnext, :, :, :), Land_IAU_state%inc2%slc_inc, errmsg, errflg) - else - Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'copying next lnd iau increment ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) + Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif endif - call updateiauforcing(Land_IAU_Control,Land_IAU_Data,Land_IAU_state%wt) + call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) endif endif end subroutine land_iau_mod_getiauforcing -subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, wt) +subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) implicit none type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - real(kind=kind_phys) delt, wt - integer i,j,k,l + real(kind=kind_phys) delt, rdt, wt + integer i,j,k + integer :: is, ie, js, je + + is = Land_IAU_Control%isc + ie = is + Land_IAU_Control%nx-1 + js = Land_IAU_Control%jsc + je = js + Land_IAU_Control%ny-1 + npz = Land_IAU_Control%lsoil ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in updateiauforcing',nfiles,Land_IAU_Control%iaufhrs(1:nfiles) delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) @@ -647,18 +497,25 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, wt) enddo end subroutine updateiauforcing - subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, wt) + subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) implicit none type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - real(kind=kind_phys) delt, dt,wt - integer i,j,k,l + real(kind=kind_phys) delt, rdt,wt + integer i, j, k + integer :: is, ie, js, je + + is = Land_IAU_Control%isc + ie = is + Land_IAU_Control%nx-1 + js = Land_IAU_Control%jsc + je = js + Land_IAU_Control%ny-1 + npz = Land_IAU_Control%lsoil ! this is only called if using 1 increment file if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',rdt - do j = js,je - do i = is,ie - do k = 1,npz ! do k = 1,n_soill ! + do j = js, je + do i = is, ie + do k = 1, npz ! do k = 1,n_soill ! Land_IAU_Data%stc_inc(i,j,k) = wt*Land_IAU_state%inc1%stc_inc(i,j,k)*rdt Land_IAU_Data%slc_inc(i,j,k) = wt*Land_IAU_state%inc1%slc_inc(i,j,k)*rdt end do @@ -667,73 +524,6 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, wt) end subroutine setiauforcing -subroutine read_iau_forcing_all_timesteps(Land_IAU_Control, fname, errmsg, errflg, & - wk3_out_stc, wk3_out_slc) !, fname_sfc) is, ie, js, je, ks,ke, - type (land_iau_control_type), intent(in) :: Land_IAU_Control - character(len=*), intent(in) :: fname - character(len=*), intent(inout) :: errmsg - integer, intent(inout) :: errflg - real(kind=kind_phys), intent(out) :: wk3_out_stc(1:im, jbeg:jend, 1:km) - real(kind=kind_phys), intent(out) :: wk3_out_slc(1:im, jbeg:jend, 1:km) - - integer :: i, j, k, l, npz - integer :: i1, i2, j1 - logical :: exists - integer :: ncid, status, varid - integer :: ierr - - character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] - character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] - - !Errors messages handled through CCPP error handling variables - errmsg = '' - errflg = 0 - - inquire (file=trim(fname), exist=exists) - if (exists) then - status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file - call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) - if (errflg .ne. 0) return - else - errmsg = 'FATAL Error in land iau read_iau_forcing_all_timesteps: Expected file '//trim(fname)//' for DA increment does not exist' - errflg = 1 - return - endif - - do i = 1, size(stc_vars) - print *, trim(stc_vars(i)) - ! call check_var_exists(ncid, trim(stc_vars(i)), ierr) - status = nf90_inq_varid(ncid, trim(stc_vars(i)), varid) - if (status == nf90_noerr) then !if (ierr == 0) then - call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_stc(:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) - if (errflg .ne. 0) return - else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, & - 'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' - wk3_out_stc(:, :, i) = 0. - endif - enddo - do i = 1, size(slc_vars) - print *, trim(slc_vars(i)) - status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) - if (status == nf90_noerr) then !if (ierr == 0) then - ! call get_var3_r4( ncid, trim(slc_vars(i)), 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i) ) - call get_var3d_values(ncid, varid, 1,im, jbeg,jend, 1,1, wk3_out_slc(:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg) - if (errflg .ne. 0) return - else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,& - 'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' - wk3_out_slc(:, :, i) = 0. - endif - enddo - - status =nf90_close(ncid) - call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) - -end subroutine read_iau_forcing_all_timesteps - subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errmsg, errflg) type (land_iau_control_type), intent(in) :: Land_IAU_Control @@ -835,118 +625,8 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm status =nf90_close(ncid) call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) - end subroutine read_iau_forcing_fv3 -subroutine interp_inc_at_timestep(Land_IAU_Control, km_in, wk3_in, var, errmsg, errflg) !field_name, , jbeg, jend) - ! interpolate increment from GSI gaussian grid to cubed sphere - ! everying is on the A-grid, earth relative - type (land_iau_control_type), intent(in) :: Land_IAU_Control - ! character(len=*), intent(in) :: field_name - integer, intent(in) :: km_in !jbeg,jend - real(kind=kind_phys), intent(in) :: wk3_in(1:im,jbeg:jend, 1:km_in) - real(kind=kind_phys), dimension(is:ie, js:je, 1:km), intent(inout) :: var - - character(len=*), intent(inout) :: errmsg - integer, intent(inout) :: errflg - integer:: i1, i2, j1, k, j, i - - do k=1,km_in - do j=js,je - do i=is,ie - i1 = id1(i,j) - i2 = id2(i,j) - j1 = jdc(i,j) - var(i,j,k) = s2c(i,j,1)*wk3_in(i1,j1 ,k) + s2c(i,j,2)*wk3_in(i2,j1 ,k)+& - s2c(i,j,3)*wk3_in(i2,j1+1,k) + s2c(i,j,4)*wk3_in(i1,j1+1,k) - enddo - enddo - enddo -end subroutine interp_inc_at_timestep - -!> This subroutine is copied from 'fv_treat_da_inc.F90 by Xi.Chen -! copying it here, due to inability to 'include' from the original module when the land iau mod is called through CCPP frameowrk -!> @author Xi.Chen !> @date 02/12/2016 - !============================================================================= - !>@brief The subroutine 'remap_coef' calculates the coefficients for horizonal regridding. - subroutine remap_coef( is, ie, js, je, isd, ied, jsd, jed, & - im, jm, lon, lat, id1, id2, jdc, s2c, agrid ) - - integer, intent(in):: is, ie, js, je, isd, ied, jsd, jed - integer, intent(in):: im, jm - real(kind=kind_phys), intent(in):: lon(im), lat(jm) - real(kind=kind_phys), intent(out):: s2c(is:ie,js:je,4) - integer, intent(out), dimension(is:ie,js:je):: id1, id2, jdc - real(kind=kind_phys), intent(in):: agrid(isd:ied,jsd:jed,2) - ! local: - real(kind=kind_phys) :: rdlon(im) - real(kind=kind_phys) :: rdlat(jm) - real(kind=kind_phys):: a1, b1 - integer i,j, i1, i2, jc, i0, j0 - do i=1,im-1 - rdlon(i) = 1. / (lon(i+1) - lon(i)) - enddo - rdlon(im) = 1. / (lon(1) + 2.*pi - lon(im)) - - do j=1,jm-1 - rdlat(j) = 1. / (lat(j+1) - lat(j)) - enddo - - ! * Interpolate to cubed sphere cell center - do 5000 j=js,je - - do i=is,ie - - if ( agrid(i,j,1)>lon(im) ) then - i1 = im; i2 = 1 - a1 = (agrid(i,j,1)-lon(im)) * rdlon(im) - elseif ( agrid(i,j,1)=lon(i0) .and. agrid(i,j,1)<=lon(i0+1) ) then - i1 = i0; i2 = i0+1 - a1 = (agrid(i,j,1)-lon(i1)) * rdlon(i0) - go to 111 - endif - enddo - endif -111 continue - - if ( agrid(i,j,2)lat(jm) ) then - jc = jm-1 - b1 = 1. - else - do j0=1,jm-1 - if ( agrid(i,j,2)>=lat(j0) .and. agrid(i,j,2)<=lat(j0+1) ) then - jc = j0 - b1 = (agrid(i,j,2)-lat(jc)) * rdlat(jc) - go to 222 - endif - enddo - endif -222 continue - - if ( a1<0.0 .or. a1>1.0 .or. b1<0.0 .or. b1>1.0 ) then -!TODO uncomment and fix mpp_pe write(*,*) 'gid=', mpp_pe(), i,j,a1, b1 - endif - - s2c(i,j,1) = (1.-a1) * (1.-b1) - s2c(i,j,2) = a1 * (1.-b1) - s2c(i,j,3) = a1 * b1 - s2c(i,j,4) = (1.-a1) * b1 - id1(i,j) = i1 - id2(i,j) = i2 - jdc(i,j) = jc - enddo !i-loop -5000 continue ! j-loop - - end subroutine remap_coef - !> Calculate soil mask for land on model grid. !! Output is 1 - soil, 2 - snow-covered, 0 - land ice, -1 not land. !! From bb02763ced6c1c2cb38982490a0c39052b5e4de2 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 20 Jun 2024 12:55:21 -0400 Subject: [PATCH 042/154] remove Gaussian files --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 6 +++--- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 1f1cb85a0..51661b867 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -213,12 +213,12 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me end subroutine land_iau_mod_set_control -subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) +subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) ! integer, intent(in) :: me, mpi_root type (land_iau_control_type), intent(in) :: Land_IAU_Control type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data - real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude + ! real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + ! real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index cb38dbfb4..ae0772032 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -142,7 +142,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & me, mpi_root, isc,jsc, nx, ny, tile_num, nblks, blksz, & lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) ! Initialize IAU for land - call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, xlon, xlat, errmsg, errflg) + call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! xlon, xlat, errmsg, errflg) end subroutine noahmpdrv_init From 651fb26928b93e21e2b1b37108f96cb7249a7aee Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 20 Jun 2024 15:38:15 -0400 Subject: [PATCH 043/154] remove Gaussian files --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 32 +++++++++++-------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 51661b867..a1a9f6cbd 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -79,8 +79,8 @@ module land_iau_mod character(len=:), pointer, dimension(:) :: input_nml_file => null() ! Date: Thu, 20 Jun 2024 16:07:27 -0400 Subject: [PATCH 044/154] debug memory --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index a1a9f6cbd..77e6894c5 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -214,7 +214,7 @@ end subroutine land_iau_mod_set_control subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) ! integer, intent(in) :: me, mpi_root - type (land_iau_control_type), intent(in) :: Land_IAU_Control + type (land_iau_control_type), intent(inout) :: Land_IAU_Control type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data ! real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon ! real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude @@ -401,7 +401,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e t2 = Land_IAU_Control%iaufhrs(1)+0.5*Land_IAU_Control%iau_delthrs else t1 = Land_IAU_Control%iaufhrs(1) - t2 = Land_IAU_Control%iaufhrs(nfiles) + t2 = Land_IAU_Control%iaufhrs(ntimes) endif if (Land_IAU_Control%iau_filter_increments) then ! compute increment filter weight From c3066284e329901b1f5adc1a78b8d13b966a304b Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 21 Jun 2024 10:15:41 -0400 Subject: [PATCH 045/154] fix fv3 file error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 77e6894c5..475c1101d 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -555,7 +555,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm write(tile_str, '(I0)') Land_IAU_Control%tile_num - fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1))//".tile"//tile_str//".nc" + fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1))//".tile"//trim(tile_str)//".nc" ! isc = Land_IAU_Control%isc ! jsc = Land_IAU_Control%jsc From 9a94c579cfdcc5b80e3aab1c7cb60dbee522fcbc Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 21 Jun 2024 10:57:10 -0400 Subject: [PATCH 046/154] fix fv3 file error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 475c1101d..edbf200a5 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -750,10 +750,10 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) end subroutine get_var1d - subroutine get_var3d_values(ncid, varid, is,ie, js,je, ks,ke, var3d, status) + subroutine get_var3d_values(ncid, varid, is,ix, js,jx, ks,kz, var3d, status) integer, intent(in):: ncid, varid - integer, intent(in):: is, ie, js, je, ks,ke - real(kind=kind_phys), intent(out):: var3d(is:ie,js:je,ks:ke) + integer, intent(in):: is, ix, js, jy, ks,kz + real(kind=kind_phys), intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) integer, intent(out):: status ! integer, dimension(3):: start, nreco ! start(1) = is; start(2) = js; start(3) = ks @@ -762,7 +762,8 @@ subroutine get_var3d_values(ncid, varid, is,ie, js,je, ks,ke, var3d, status) ! nreco(3) = ke - ks + 1 status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) - start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) + start = (/is, js, ks/), count = (/ix, jy, kz/)) + ! start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) end subroutine get_var3d_values From f5de22f69d21f408640ed5c70e1b3bc169b293b6 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 21 Jun 2024 11:09:50 -0400 Subject: [PATCH 047/154] fix fv3 file error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index edbf200a5..c194ab7ae 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -750,7 +750,7 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) end subroutine get_var1d - subroutine get_var3d_values(ncid, varid, is,ix, js,jx, ks,kz, var3d, status) + subroutine get_var3d_values(ncid, varid, is,ix, js,jy, ks,kz, var3d, status) integer, intent(in):: ncid, varid integer, intent(in):: is, ix, js, jy, ks,kz real(kind=kind_phys), intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) From 98d872b6397e3e5214738ba038dfb295cf67f627 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 09:01:45 -0400 Subject: [PATCH 048/154] add land iau conditions --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index ae0772032..801f195f6 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -137,6 +137,8 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & pores (:) = maxsmc (:) resid (:) = drysmc (:) + if (.not. Land_IAU_Control%do_land_iau) return + ! Read Land IAU settings call land_iau_mod_set_control(Land_IAU_Control, fn_nml, input_nml_file, & me, mpi_root, isc,jsc, nx, ny, tile_num, nblks, blksz, & @@ -228,6 +230,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! --- Initialize CCPP error handling variables errmsg = '' errflg = 0 + + if (.not. Land_IAU_Control%do_land_iau) return !> update current forecast hour ! GFS_control%jdat(:) = jdat(:) @@ -419,6 +423,8 @@ subroutine noahmpdrv_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, ! --- Initialize CCPP error handling variables errmsg = '' errflg = 0 + + if (.not. Land_IAU_Control%do_land_iau) return call land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !Land_IAU_Control%finalize() end subroutine noahmpdrv_finalize From f59bf592e32f4e06e30ecc34c09914e3971823f6 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 10:14:38 -0400 Subject: [PATCH 049/154] add land iau conditions --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 23 +++++++++++-------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 4 ++-- 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index c194ab7ae..c395d46f2 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -257,6 +257,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) nlat = Land_IAU_Control%ny !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) + print*, "proc is ie js je ",Land_IAU_Control%me, is, ie, js, je allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) @@ -331,12 +332,11 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) Land_IAU_state%rdt = rdt ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid - ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) - ! allocate (wk3_slc(n_t, 1:im,jbeg:jend, 1:km)) + ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errflg) ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) - ! increments already in the fv3 modele grid--no need for interpolation + ! increments already in the fv3 grid--no need for interpolation Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) Land_IAU_state%inc1%slc_inc(:, :, :) = wk3_slc(1, :, :, :) @@ -480,14 +480,17 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) real(kind=kind_phys) delt, rdt, wt integer i,j,k integer :: is, ie, js, je, npz + integer :: ntimes - is = Land_IAU_Control%isc + is = 1 !Land_IAU_Control%isc ie = is + Land_IAU_Control%nx-1 - js = Land_IAU_Control%jsc + js = 1 !Land_IAU_Control%jsc je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil -! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in updateiauforcing',nfiles,Land_IAU_Control%iaufhrs(1:nfiles) + ntimes = Land_IAU_Control%ntimes + + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes) delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) do j = js,je do i = is,ie @@ -508,9 +511,9 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) integer i, j, k integer :: is, ie, js, je, npz - is = Land_IAU_Control%isc + is = 1 !Land_IAU_Control%isc ie = is + Land_IAU_Control%nx-1 - js = Land_IAU_Control%jsc + js = 1 !Land_IAU_Control%jsc je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil ! this is only called if using 1 increment file @@ -592,7 +595,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm allocate(slc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) do i = 1, size(stc_vars) - print *, trim(stc_vars(i)) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(stc_vars(i)) ! call check_var_exists(ncid, trim(stc_vars(i)), ierr) status = nf90_inq_varid(ncid, trim(stc_vars(i)), varid) if (status == nf90_noerr) then !if (ierr == 0) then @@ -610,7 +613,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm endif enddo do i = 1, size(slc_vars) - print *, trim(slc_vars(i)) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(slc_vars(i)) status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) if (status == nf90_noerr) then !if (ierr == 0) then do it = 1, n_t diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 801f195f6..dd2976e1b 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -280,7 +280,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! delt=GFS_Control%dtf if ((Land_IAU_Control%dtp - delt) > 0.0001) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_run delt ",delt,"different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp + print*, "Warning noahmpdrv_run delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp endif endif @@ -423,7 +423,7 @@ subroutine noahmpdrv_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, ! --- Initialize CCPP error handling variables errmsg = '' errflg = 0 - + if (.not. Land_IAU_Control%do_land_iau) return call land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !Land_IAU_Control%finalize() From f40cebc1d6574c1420d8a5c56578e0d1fe031c18 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 10:39:41 -0400 Subject: [PATCH 050/154] add land iau conditions --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index dd2976e1b..bfd90f03e 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -137,13 +137,12 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & pores (:) = maxsmc (:) resid (:) = drysmc (:) - if (.not. Land_IAU_Control%do_land_iau) return - ! Read Land IAU settings call land_iau_mod_set_control(Land_IAU_Control, fn_nml, input_nml_file, & me, mpi_root, isc,jsc, nx, ny, tile_num, nblks, blksz, & lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) ! Initialize IAU for land + if (.not. Land_IAU_Control%do_land_iau) return call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! xlon, xlat, errmsg, errflg) end subroutine noahmpdrv_init From efad815958f09e7142623d9b8bd5291259eec6c5 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 11:58:17 -0400 Subject: [PATCH 051/154] temp comment soilt consistency --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 66 +++++++++---------- 2 files changed, 34 insertions(+), 34 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index c395d46f2..a6a51f19b 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -490,7 +490,7 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) ntimes = Land_IAU_Control%ntimes - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes) delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) do j = js,je do i = is,ie diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index bfd90f03e..d850ee975 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -333,41 +333,41 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! enddo deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) -! (consistency) adjustments for updated soil temp and moisture +! ! (consistency) adjustments for updated soil temp and moisture - ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) - call read_mp_table_parameters(errmsg, errflg) - ! maxsmc(1:slcats) = smcmax_table(1:slcats) - ! bb(1:slcats) = bexp_table(1:slcats) - ! satpsi(1:slcats) = psisat_table(1:slcats) +! ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) +! call read_mp_table_parameters(errmsg, errflg) +! ! maxsmc(1:slcats) = smcmax_table(1:slcats) +! ! bb(1:slcats) = bexp_table(1:slcats) +! ! satpsi(1:slcats) = psisat_table(1:slcats) - if (errflg .ne. 0) then - print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' - errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' - return - endif - n_stc = 0 - do i=1,lensfc - if (stc_updated(i) == 1 ) then ! soil-only location - n_stc = n_stc+1 - soiltype = soiltyp(i) - do l = 1, lsoil_incr - !case 1: frz ==> frz, recalculate slc, smc remains - !case 2: unfrz ==> frz, recalculate slc, smc remains - !both cases are considered in the following if case - if (stc(i,l) .LT. tfreez )then - !recompute supercool liquid water,smc_anl remain unchanged - smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) - slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) - slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) - endif - !case 3: frz ==> unfrz, melt all soil ice (if any) - if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck - slc(i,l)=smc(i,l) - endif - enddo - endif - enddo +! if (errflg .ne. 0) then +! print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' +! errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' +! return +! endif +! n_stc = 0 +! do i=1,lensfc +! if (stc_updated(i) == 1 ) then ! soil-only location +! n_stc = n_stc+1 +! soiltype = soiltyp(i) +! do l = 1, lsoil_incr +! !case 1: frz ==> frz, recalculate slc, smc remains +! !case 2: unfrz ==> frz, recalculate slc, smc remains +! !both cases are considered in the following if case +! if (stc(i,l) .LT. tfreez )then +! !recompute supercool liquid water,smc_anl remain unchanged +! smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) +! slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) +! slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) +! endif +! !case 3: frz ==> unfrz, melt all soil ice (if any) +! if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck +! slc(i,l)=smc(i,l) +! endif +! enddo +! endif +! enddo deallocate(stc_updated) deallocate(mask_tile) From 1537ef11762d21bb5b7b2e374b36f2b8c55419c5 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 13:11:02 -0400 Subject: [PATCH 052/154] temp comment soilt consistency --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 77 +++++++++++-------- 2 files changed, 44 insertions(+), 35 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index a6a51f19b..7f7288986 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -257,7 +257,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) nlat = Land_IAU_Control%ny !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) - print*, "proc is ie js je ",Land_IAU_Control%me, is, ie, js, je + print*, "proc tile is ie js je ",,Land_IAU_Control%tile_num, Land_IAU_Control%me, is, ie, js, je allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index d850ee975..6dede7c6d 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -240,6 +240,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo " delt ",delt," IauCont%dtp",Land_IAU_Control%dtp endif + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "root proc stc before update" + print*, stc + endif !> read iau increments call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) if (errflg .ne. 0) then @@ -270,7 +274,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ib = 1 do j = 1, Land_IAU_Control%ny !ny do k = 1, km - stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) =Land_IAU_Data%stc_inc(:,j, k) + stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%stc_inc(:,j, k) ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) enddo ib = ib + Land_IAU_Control%nx !nlon @@ -333,41 +337,41 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! enddo deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) -! ! (consistency) adjustments for updated soil temp and moisture +! (consistency) adjustments for updated soil temp and moisture -! ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) -! call read_mp_table_parameters(errmsg, errflg) -! ! maxsmc(1:slcats) = smcmax_table(1:slcats) -! ! bb(1:slcats) = bexp_table(1:slcats) -! ! satpsi(1:slcats) = psisat_table(1:slcats) + ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) + call read_mp_table_parameters(errmsg, errflg) + ! maxsmc(1:slcats) = smcmax_table(1:slcats) + ! bb(1:slcats) = bexp_table(1:slcats) + ! satpsi(1:slcats) = psisat_table(1:slcats) -! if (errflg .ne. 0) then -! print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' -! errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' -! return -! endif -! n_stc = 0 -! do i=1,lensfc -! if (stc_updated(i) == 1 ) then ! soil-only location -! n_stc = n_stc+1 -! soiltype = soiltyp(i) -! do l = 1, lsoil_incr -! !case 1: frz ==> frz, recalculate slc, smc remains -! !case 2: unfrz ==> frz, recalculate slc, smc remains -! !both cases are considered in the following if case -! if (stc(i,l) .LT. tfreez )then -! !recompute supercool liquid water,smc_anl remain unchanged -! smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) -! slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) -! slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) -! endif -! !case 3: frz ==> unfrz, melt all soil ice (if any) -! if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck -! slc(i,l)=smc(i,l) -! endif -! enddo -! endif -! enddo + if (errflg .ne. 0) then + print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + return + endif + n_stc = 0 + do i=1,lensfc + if (stc_updated(i) == 1 ) then ! soil-only location + n_stc = n_stc+1 + soiltype = soiltyp(i) + do l = 1, lsoil_incr + !case 1: frz ==> frz, recalculate slc, smc remains + !case 2: unfrz ==> frz, recalculate slc, smc remains + !both cases are considered in the following if case + if (stc(i,l) .LT. tfreez )then + !recompute supercool liquid water,smc_anl remain unchanged + smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) + slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) + slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) + endif + !case 3: frz ==> unfrz, melt all soil ice (if any) + if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck + slc(i,l)=smc(i,l) + endif + enddo + endif + enddo deallocate(stc_updated) deallocate(mask_tile) @@ -383,6 +387,11 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo endif + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "root proc stc after update" + print*, stc + endif + end subroutine noahmpdrv_timestep_init !> \ingroup NoahMP_LSM From e1dae931ff7546e930bcaa4e8c43fa1c8ffc943a Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 13:24:24 -0400 Subject: [PATCH 053/154] temp comment soilt consistency --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 7f7288986..48a1efff3 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -257,7 +257,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) nlat = Land_IAU_Control%ny !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) - print*, "proc tile is ie js je ",,Land_IAU_Control%tile_num, Land_IAU_Control%me, is, ie, js, je + print*, "proc tile is ie js je ",Land_IAU_Control%tile_num, Land_IAU_Control%me, is, ie, js, je allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) From d01adf6e986bd5ec9b8f9fef0cda1c005da11ed7 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 14:53:40 -0400 Subject: [PATCH 054/154] temp comment soilt consistency --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 6 ++++-- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 17 +++++++---------- 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 48a1efff3..c736d9029 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -257,7 +257,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) nlat = Land_IAU_Control%ny !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) - print*, "proc tile is ie js je ",Land_IAU_Control%tile_num, Land_IAU_Control%me, is, ie, js, je + + ! print*, "proc tile is ie js je ",Land_IAU_Control%me, Land_IAU_Control%tile_num, is, ie, js, je allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) @@ -490,7 +491,8 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) ntimes = Land_IAU_Control%ntimes - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & + " rdt wt ", rdt, wt delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) do j = js,je do i = is,ie diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 6dede7c6d..eff57df87 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -240,10 +240,6 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo " delt ",delt," IauCont%dtp",Land_IAU_Control%dtp endif - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "root proc stc before update" - print*, stc - endif !> read iau increments call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) if (errflg .ne. 0) then @@ -294,7 +290,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo !---this should be ncol?? as last block may be shorter (check blksz)? lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny - print*,'adjusting first ', lsoil_incr, ' surface layers only' + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,' adjusting first ', lsoil_incr, ' surface layers only, delt ', delt ! initialize variables for counts statitics to be zeros nother = 0 ! grid cells not land nsnowupd = 0 ! grid cells with snow (temperature not yet updated) @@ -306,10 +302,11 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo allocate(mask_tile(lensfc)) call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, & !veg_type_landice, mask_tile) - + ij_loop : do ij = 1, lensfc ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land if (mask_tile(ij) == 1) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) soil_freeze=.false. soil_ice=.false. do k = 1, lsoil_incr ! k = 1, km @@ -387,10 +384,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo endif - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "root proc stc after update" - print*, stc - endif + ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + ! print*, "root proc stc after update" + ! print*, stc + ! endif end subroutine noahmpdrv_timestep_init From e7bb2c33a762fc232bd6860f0b59797806f559e8 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 22 Jun 2024 15:23:52 -0400 Subject: [PATCH 055/154] temp comment soilt consistency --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 23 +++++++++++-------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index c736d9029..c3a3bcaae 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -334,7 +334,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) - call read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errflg) + call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) ! increments already in the fv3 grid--no need for interpolation @@ -531,14 +531,14 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) end subroutine setiauforcing -subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errmsg, errflg) +subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_out, slc_inc_out type (land_iau_control_type), intent(in) :: Land_IAU_Control ! character(len=*), intent(in) :: fname character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg - real(kind=kind_phys), allocatable, intent(out) :: stc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) - real(kind=kind_phys), allocatable, intent(out) :: slc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) + ! real(kind=kind_phys), allocatable, intent(out) :: stc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) + ! real(kind=kind_phys), allocatable, intent(out) :: slc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) integer :: i, it, km !j, k, l, npz, logical :: exists @@ -593,8 +593,11 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm return endif - allocate(stc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) - allocate(slc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) + ! allocate(stc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) + ! allocate(slc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) + allocate(wk3_stc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) + allocate(wk3_slc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) + do i = 1, size(stc_vars) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(stc_vars(i)) @@ -603,7 +606,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm if (status == nf90_noerr) then !if (ierr == 0) then do it = 1, n_t ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) - call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, stc_inc_out(it,:, :, i), status) + call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, wk3_stc(it,:, :, i), status) ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, stc_inc_out(it,:, :, i), status) call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return @@ -611,7 +614,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, & 'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' - stc_inc_out(:, :, :, i) = 0. + wk3_stc(:, :, :, i) = 0. endif enddo do i = 1, size(slc_vars) @@ -619,7 +622,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) if (status == nf90_noerr) then !if (ierr == 0) then do it = 1, n_t - call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, slc_inc_out(it, :, :, i), status) + call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, wk3_slc(it, :, :, i), status) ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, slc_inc_out(it, :, :, i), status) call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return @@ -627,7 +630,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, stc_inc_out, slc_inc_out, errm else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,& 'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' - slc_inc_out(:, :, :, i) = 0. + wk3_slc(:, :, :, i) = 0. endif enddo From 3fe39b710d3a277ec47a2ab874bbcab94019f712 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 09:29:33 -0400 Subject: [PATCH 056/154] fix rdt error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index c3a3bcaae..cae97b2b0 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -29,6 +29,7 @@ module land_iau_mod private real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) +! real(kind=kind_phys) :: rdt type land_iau_internal_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) @@ -327,11 +328,10 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) enddo deallocate(idt) endif - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval = ',Land_IAU_Control%iau_delthrs,' hours' dt = (Land_IAU_Control%iau_delthrs*3600.) rdt = 1.0/dt Land_IAU_state%rdt = rdt - + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_state%rdt ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc @@ -437,7 +437,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e Land_IAU_Data%in_interval=.false. else if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control,Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact,Land_IAU_state%rdt Land_IAU_Data%in_interval=.true. endif return @@ -449,7 +449,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',Land_IAU_Control%iaufhrs(1),Land_IAU_Control%fhour,Land_IAU_Control%iaufhrs(nfiles) Land_IAU_Data%in_interval=.false. else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact,Land_IAU_state%rdt Land_IAU_Data%in_interval=.true. do k=ntimes, 1, -1 if (Land_IAU_Control%iaufhrs(k) > Land_IAU_Control%fhour) then From ed09ad60018ff40e008003f4b25aeb4a7594c0a6 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 10:18:58 -0400 Subject: [PATCH 057/154] - --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index cae97b2b0..af2221379 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -336,6 +336,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'wk3_stc min max', min(wk3_stc), max(wk3_stc) ! increments already in the fv3 grid--no need for interpolation Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) @@ -491,9 +492,9 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) ntimes = Land_IAU_Control%ntimes - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & - " rdt wt ", rdt, wt delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & + " rdt wt delt ", rdt, wt, delt do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! From 0c8ff8ece14e40e7c033d3e833cb69a48843a38e Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 10:37:36 -0400 Subject: [PATCH 058/154] - --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index af2221379..888dc5d6a 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -336,7 +336,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'wk3_stc min max', min(wk3_stc), max(wk3_stc) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) ! increments already in the fv3 grid--no need for interpolation Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) From 3656ec51c29317a0b30b5113bd1b721762504ab5 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 11:05:18 -0400 Subject: [PATCH 059/154] - --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 888dc5d6a..d1de42cb9 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -336,7 +336,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) ! increments already in the fv3 grid--no need for interpolation Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) @@ -353,6 +352,11 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(2, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(2, :, :, :) endif + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,' IAU init wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) + print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) + print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) + endif ! print*,'end of IAU init',dt,rdt end subroutine land_iau_mod_init @@ -393,6 +397,12 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e ntimes = Land_IAU_Control%ntimes + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'getiauforc wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) + print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) + print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) + endif + Land_IAU_Data%in_interval=.false. if (ntimes.LE.0) then return From b744d6c18a3bff2174ce953d55f430517cc412f8 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 11:36:36 -0400 Subject: [PATCH 060/154] - --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 29 +++++++++++++++---- 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index d1de42cb9..8199aab6b 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -216,7 +216,7 @@ end subroutine land_iau_mod_set_control subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) ! integer, intent(in) :: me, mpi_root type (land_iau_control_type), intent(inout) :: Land_IAU_Control - type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data + type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data ! real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon ! real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude character(len=*), intent(out) :: errmsg @@ -239,7 +239,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) integer :: n_soill, n_snowl !soil and snow layers logical :: do_land_iau integer :: is, ie, js, je - integer :: npz + integer :: npz + integer :: i, j !Errors messages handled through CCPP error handling variables errmsg = '' @@ -338,8 +339,16 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) ! increments already in the fv3 grid--no need for interpolation - Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - Land_IAU_state%inc1%slc_inc(:, :, :) = wk3_slc(1, :, :, :) + ! Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + ! Land_IAU_state%inc1%slc_inc(:, :, :) = wk3_slc(1, :, :, :) + do k = 1, npz ! do k = 1,n_soill ! + do j = 1, nlat + do i = 1, nlon + Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(1, i, j, k) + Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(1, i, j, k) + end do + enddo + enddo if (ntimes.EQ.1) then ! only need to get incrments once since constant forcing over window call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) @@ -349,8 +358,16 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(2, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(2, :, :, :) + ! Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(2, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + ! Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(2, :, :, :) + do k = 1, npz ! do k = 1,n_soill ! + do j = 1, nlat + do i = 1, nlon + Land_IAU_state%inc2%stc_inc(i,j,k) = wk3_stc(2, i, j, k) + Land_IAU_state%inc2%slc_inc(i,j,k) = wk3_slc(2, i, j, k) + end do + enddo + enddo endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print *,' IAU init wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) From dbe2d7da0e216d3fe3c925b82bcd996921f0a311 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 12:10:01 -0400 Subject: [PATCH 061/154] - --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 8199aab6b..e1ea20c76 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -250,6 +250,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) n_soill = Land_IAU_Control%lsoil !4 for sfc updates ! n_snowl = Land_IAU_Control%lsnowl npz = Land_IAU_Control%lsoil + km = Land_IAU_Control%lsoil is = Land_IAU_Control%isc ie = is + Land_IAU_Control%nx-1 From 05de695455b45008dd1bf607e4705af27771ccd9 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 13:26:14 -0400 Subject: [PATCH 062/154] debug --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 20 +++++++++---------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index e1ea20c76..902905138 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -370,11 +370,11 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) enddo enddo endif - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,' IAU init wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) - print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) - print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) - endif + ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + ! print *,' IAU init wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) + ! print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) + ! print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) + ! endif ! print*,'end of IAU init',dt,rdt end subroutine land_iau_mod_init @@ -415,11 +415,11 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e ntimes = Land_IAU_Control%ntimes - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'getiauforc wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) - print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) - print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) - endif + ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + ! print *,'getiauforc wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) + ! print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) + ! print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) + ! endif Land_IAU_Data%in_interval=.false. if (ntimes.LE.0) then diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index eff57df87..6498d0206 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -306,7 +306,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ij_loop : do ij = 1, lensfc ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land if (mask_tile(ij) == 1) then - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) + ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) soil_freeze=.false. soil_ice=.false. do k = 1, lsoil_incr ! k = 1, km From 820ef5eb4f6e9a404489d6d772a5a744147c4d0a Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 23 Jun 2024 17:11:24 -0400 Subject: [PATCH 063/154] clean up --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 27 +---------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 47 +++++-------------- 2 files changed, 13 insertions(+), 61 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 902905138..b4a76f838 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -29,7 +29,6 @@ module land_iau_mod private real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) -! real(kind=kind_phys) :: rdt type land_iau_internal_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) @@ -261,8 +260,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) - ! print*, "proc tile is ie js je ",Land_IAU_Control%me, Land_IAU_Control%tile_num, is, ie, js, je - allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) ! allocate arrays that will hold iau state @@ -334,14 +331,12 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) rdt = 1.0/dt Land_IAU_state%rdt = rdt if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_state%rdt - ! Read all increment files at iau init time (at beginning of cycle) and interpolate to target grid + ! Read all increment files at iau init time (at beginning of cycle) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) ! increments already in the fv3 grid--no need for interpolation - ! Land_IAU_state%inc1%stc_inc(:, :, :) = wk3_stc(1, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - ! Land_IAU_state%inc1%slc_inc(:, :, :) = wk3_slc(1, :, :, :) do k = 1, npz ! do k = 1,n_soill ! do j = 1, nlat do i = 1, nlon @@ -358,9 +353,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - - ! Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(2, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - ! Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(2, :, :, :) + do k = 1, npz ! do k = 1,n_soill ! do j = 1, nlat do i = 1, nlon @@ -370,11 +363,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) enddo enddo endif - ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - ! print *,' IAU init wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) - ! print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) - ! print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) - ! endif ! print*,'end of IAU init',dt,rdt end subroutine land_iau_mod_init @@ -415,12 +403,6 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e ntimes = Land_IAU_Control%ntimes - ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - ! print *,'getiauforc wk3_stc min max', minval(wk3_stc), maxval(wk3_stc) - ! print *,'inc1%stc_inc min max', minval(Land_IAU_state%inc1%stc_inc), maxval(Land_IAU_state%inc1%stc_inc) - ! print *,'inc2%stc_inc min max', minval(Land_IAU_state%inc2%stc_inc), maxval(Land_IAU_state%inc2%stc_inc) - ! endif - Land_IAU_Data%in_interval=.false. if (ntimes.LE.0) then return @@ -566,8 +548,6 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou ! character(len=*), intent(in) :: fname character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg - ! real(kind=kind_phys), allocatable, intent(out) :: stc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) - ! real(kind=kind_phys), allocatable, intent(out) :: slc_inc_out(:, :, :, :) !1:im, jbeg:jend, 1:km) integer :: i, it, km !j, k, l, npz, logical :: exists @@ -622,12 +602,9 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou return endif - ! allocate(stc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) - ! allocate(slc_inc_out(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) allocate(wk3_stc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) allocate(wk3_slc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) - do i = 1, size(stc_vars) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(stc_vars(i)) ! call check_var_exists(ncid, trim(stc_vars(i)), ierr) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 6498d0206..74aaffb9e 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -30,9 +30,9 @@ module noahmpdrv !> \Land IAU data and control ! Land IAU Control holds settings' information, maily read from namelist (e.g., - ! block of global domain that belongs to a process , - ! whethrer to do IAU increment at this time step, - ! time step informatoin, etc) + ! block of global domain that belongs to a process , + ! whethrer to do IAU increment at this time step, + ! time step informatoin, etc) type (land_iau_control_type) :: Land_IAU_Control ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks @@ -59,8 +59,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & use set_soilveg_mod, only: set_soilveg use namelist_soilveg use noahmp_tables - !use GFS_typedefs, only: GFS_control_type - ! use GFS_typedefs, only: GFS_data_type implicit none @@ -83,12 +81,8 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon real(kind_phys), dimension(:), intent(in) :: xlat ! latitude - - integer, intent(in) :: lsoil, lsnow_lsm real(kind=kind_phys), intent(in) :: dtp, fhour - ! type(gfs_data_type), dimension(:), intent(inout) :: GFS_Data ! !(one:) - !type(gfs_control_type), intent(in) :: GFS_Control ! Initialize CCPP error handling variables errmsg = '' @@ -153,7 +147,7 @@ end subroutine noahmpdrv_init !! \section arg_table_noahmpdrv_timestep_init Argument Table !! \htmlinclude noahmpdrv_timestep_init.html !! - !! For Noah-MP, the adjustment scheme shown below as of 11/09/2023: +!! For Noah-MP, the adjustment scheme shown below is applied to soil moisture and temp: !! Case 1: frozen ==> frozen, recalculate slc following opt_frz=1, smc remains !! Case 2: unfrozen ==> frozen, recalculate slc following opt_frz=1, smc remains !! Case 3: frozen ==> unfrozen, melt all soil ice (if any) @@ -161,16 +155,6 @@ end subroutine noahmpdrv_init !! Note: For Case 3, Yuan Xue thoroughly evaluated a total of four options and !! current option is found to be the best as of 11/09/2023 -!! @param[in] isot Integer code for the soil type data set -!! @param[in] ivegsrc Integer code for the vegetation type data set -!! @param[in] lensfc Number of land points for this tile - -!! @param[in] lsoil_incr Number of soil layers (from top) to apply soil increments to - -!! @param[inout] smc_adj Analysis soil moisture states -!! @param[inout] slc_adj Analysis liquid soil moisture states -!! @param[in] stc_updated Integer to record whether STC in each grid cell was updated - subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, isot, ivegsrc, soiltyp, vegtype, weasd, & stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, @@ -182,13 +166,12 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo implicit none - ! for soil temp/moisture consistency adjustment after DA update - integer, intent(in) :: isot, ivegsrc - integer , intent(in) :: itime !current forecast iteration real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) real(kind=kind_phys) , intent(in) :: delt ! time interval [s] integer , intent(in) :: km !vertical soil layer dimension + integer, intent(in) :: isot + integer, intent(in) :: ivegsrc integer , dimension(:) , intent(in) :: soiltyp ! soil type (integer index) integer , dimension(:) , intent(in) :: vegtype ! vegetation type (integer index) @@ -282,12 +265,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo print*, "Warning noahmpdrv_run delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp endif endif - - !IAU increments are in units of 1/sec !Land_IAU_Control%dtp - !* only updating soil temp for now + lsoil_incr = Land_IAU_Control%lsoil_incr - -!---this should be ncol?? as last block may be shorter (check blksz)? lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,' adjusting first ', lsoil_incr, ' surface layers only, delt ', delt @@ -300,9 +279,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo !TODO---if only fv3 increment files are used, this can be read from file allocate(mask_tile(lensfc)) - call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, & !veg_type_landice, - mask_tile) - + call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, + + !IAU increments are in units of 1/sec !Land_IAU_Control%dtp + !* only updating soil temp for now ij_loop : do ij = 1, lensfc ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land if (mask_tile(ij) == 1) then @@ -384,11 +364,6 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo endif - ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - ! print*, "root proc stc after update" - ! print*, stc - ! endif - end subroutine noahmpdrv_timestep_init !> \ingroup NoahMP_LSM From b46a17fdb53b018c4579ce9db5b0509d0b5342c2 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 24 Jun 2024 16:49:29 -0400 Subject: [PATCH 064/154] read mask from file --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index b4a76f838..7e94d595e 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -39,6 +39,7 @@ module land_iau_mod real(kind=kind_phys),allocatable :: stc_inc(:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. + integer,allocatable :: snow_land_mask(:, :, :) end type land_iau_external_data_type type land_iau_state_type @@ -331,6 +332,29 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) rdt = 1.0/dt Land_IAU_state%rdt = rdt if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_state%rdt + + allocate(Land_IAU_Data%snow_land_mask(nlon, nlat, ntimes)) + fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1)) + inquire (file=trim(fname), exist=exists) + if (exists) then ! if( file_exist(fname) ) then + ! call open_ncfile( fname, ncid ) + status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file + call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) + if (errflg .ne. 0) return + ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) + call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, 1, n_t, & + Land_IAU_Data%snow_land_mask(:, :, it), status) + call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) + if (errflg .ne. 0) return + status = nf90_close(ncid) + CALL netcdf_err(status, 'closing file: '//trim(fname) , errflg, errmsg) + if (errflg .ne. 0) return + else + errmsg = 'FATAL Error in Land_IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' + errflg = 1 + return + endif + ! Read all increment files at iau init time (at beginning of cycle) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc From 3bb397a9c80b3fcd59f19c0de99781253b39b7ac Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 24 Jun 2024 18:38:26 -0400 Subject: [PATCH 065/154] revert back to calculating mask --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 24 +------------------ 1 file changed, 1 insertion(+), 23 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 7e94d595e..de245fcca 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -39,7 +39,7 @@ module land_iau_mod real(kind=kind_phys),allocatable :: stc_inc(:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. - integer,allocatable :: snow_land_mask(:, :, :) + ! integer,allocatable :: snow_land_mask(:, :, :) end type land_iau_external_data_type type land_iau_state_type @@ -333,28 +333,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) Land_IAU_state%rdt = rdt if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_state%rdt - allocate(Land_IAU_Data%snow_land_mask(nlon, nlat, ntimes)) - fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1)) - inquire (file=trim(fname), exist=exists) - if (exists) then ! if( file_exist(fname) ) then - ! call open_ncfile( fname, ncid ) - status = nf90_open(trim(fname), NF90_NOWRITE, ncid) ! open the file - call netcdf_err(status, ' opening file '//trim(fname), errflg, errmsg) - if (errflg .ne. 0) return - ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) - call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, 1, n_t, & - Land_IAU_Data%snow_land_mask(:, :, it), status) - call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) - if (errflg .ne. 0) return - status = nf90_close(ncid) - CALL netcdf_err(status, 'closing file: '//trim(fname) , errflg, errmsg) - if (errflg .ne. 0) return - else - errmsg = 'FATAL Error in Land_IAU_initialize: Expected file '// trim(fname)//' for DA increment does not exist' - errflg = 1 - return - endif - ! Read all increment files at iau init time (at beginning of cycle) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc From 10c3427104197dd725a4c6ef9a3f078632aa580c Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 26 Jun 2024 15:58:09 -0400 Subject: [PATCH 066/154] delete sim_nc --- .../SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 | 469 ------------------ 1 file changed, 469 deletions(-) delete mode 100644 physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 diff --git a/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 b/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 deleted file mode 100644 index 6f2bd1ad2..000000000 --- a/physics/SFC_Models/Land/Noahmp/sim_nc_mod_lnd.F90 +++ /dev/null @@ -1,469 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the FV3 dynamical core. -!* -!* The FV3 dynamical core is free software: you can redistribute it -!* and/or modify it under the terms of the -!* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or -!* (at your option) any later version. -!* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -!* See the GNU General Public License for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. -!* If not, see . -!*********************************************************************** - -!> March 2024: This is a copy of S-J Lin's sim_nc_mod -!> renamed it sim_nc_mod_lnd to faciliate compilaton - -!>@brief The module 'sim_nc' is a netcdf file reader. -!>@details The code is necessary to circumvent issues with the FMS -!! 'read_data' utility, which opens too many files and uses excessive -!! memory. -!>@author Shian-Jiann Lin - -module sim_nc_mod_lnd - -! This is S-J Lin's private netcdf file reader -! This code is needed because FMS utility (read_data) led to too much -! memory usage and too many files openned. Perhaps lower-level FMS IO -! calls should be used instead. - -#if defined(OLD_PT_TO_T) || defined(OLD_COS_SG) -#error -#error Compile time options -DOLD_PT_TO_T and -DOLD_COS_SG are no longer supported. Please remove them from your XML. -#error -#endif - -! use mpp_mod, only: mpp_error, FATAL - - implicit none -#include - - private - public open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_double, & - get_var3_real, get_var3_double, get_var3_r4, get_var2_real, get_var2_r4, & - handle_err, check_var, get_var1_real, get_var_att_double, & - check_var_exists - - contains - - subroutine open_ncfile( iflnm, ncid ) - character(len=*), intent(in):: iflnm - integer, intent(out):: ncid - integer:: status - - status = nf_open (iflnm, NF_NOWRITE, ncid) - if (status .ne. NF_NOERR) call handle_err('nf_open',status) - - - end subroutine open_ncfile - - - subroutine close_ncfile( ncid ) - integer, intent(in):: ncid - integer:: status - - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err('nf_close',status) - - - end subroutine close_ncfile - - - subroutine get_ncdim1( ncid, var1_name, im ) - integer, intent(in):: ncid - character(len=*), intent(in):: var1_name - integer, intent(out):: im - integer:: status, var1id - - status = nf_inq_dimid (ncid, var1_name, var1id) - if (status .ne. NF_NOERR) call handle_err('dimid '//var1_name,status) - - status = nf_inq_dimlen (ncid, var1id, im) - if (status .ne. NF_NOERR) call handle_err('dimid '//var1_name,status) - - end subroutine get_ncdim1 - -!>@brief The 'get_var' subroutines read in variables from netcdf files - subroutine get_var1_double( ncid, var1_name, im, var1, var_exist ) - integer, intent(in):: ncid - character(len=*), intent(in):: var1_name - integer, intent(in):: im - logical, intent(out), optional:: var_exist - real(kind=8), intent(out):: var1(im) - integer:: status, var1id - - status = nf_inq_varid (ncid, var1_name, var1id) - if (status .ne. NF_NOERR) then -! call handle_err('varid '//var1_name,status) - if(present(var_exist) ) var_exist = .false. - else - status = nf_get_var_double (ncid, var1id, var1) - if (status .ne. NF_NOERR) call handle_err('varid '//var1_name,status) - if(present(var_exist) ) var_exist = .true. - endif - - - end subroutine get_var1_double - - -! 4-byte data: - subroutine get_var1_real( ncid, var1_name, im, var1, var_exist ) - integer, intent(in):: ncid - character(len=*), intent(in):: var1_name - integer, intent(in):: im - logical, intent(out), optional:: var_exist - real(kind=4), intent(out):: var1(im) - integer:: status, var1id - - status = nf_inq_varid (ncid, var1_name, var1id) - if (status .ne. NF_NOERR) then -! call handle_err(status) - if(present(var_exist) ) var_exist = .false. - else - status = nf_get_var_real (ncid, var1id, var1) - if (status .ne. NF_NOERR) call handle_err('get_var1_real1 '//var1_name,status) - if(present(var_exist) ) var_exist = .true. - endif - - - end subroutine get_var1_real - - subroutine get_var2_real( ncid, var_name, im, jm, var2 ) - integer, intent(in):: ncid - character(len=*), intent(in):: var_name - integer, intent(in):: im, jm - real(kind=4), intent(out):: var2(im) - - integer:: status, var1id - - status = nf_inq_varid (ncid, var_name, var1id) - if (status .ne. NF_NOERR) call handle_err('get_var2_real varid '//var_name,status) - - status = nf_get_var_real (ncid, var1id, var2) - if (status .ne. NF_NOERR) call handle_err('get_var2_real get_var'//var_name,status) - - end subroutine get_var2_real - - subroutine get_var2_r4( ncid, var2_name, is,ie, js,je, var2, time_slice ) - integer, intent(in):: ncid - character(len=*), intent(in):: var2_name - integer, intent(in):: is, ie, js, je - real(kind=4), intent(out):: var2(is:ie,js:je) - integer, intent(in), optional :: time_slice -! - real(kind=4), dimension(1) :: time - integer, dimension(3):: start, nreco - integer:: status, var2id - - status = nf_inq_varid (ncid, var2_name, var2id) - if (status .ne. NF_NOERR) call handle_err('get_var2_r4 varid'//var2_name,status) - - start(1) = is; start(2) = js; start(3) = 1 - if ( present(time_slice) ) then - start(3) = time_slice - end if - - nreco(1) = ie - is + 1 - nreco(2) = je - js + 1 - nreco(3) = 1 - - status = nf_get_vara_real(ncid, var2id, start, nreco, var2) - if (status .ne. NF_NOERR) call handle_err('get_var2_r4 get_vara_real'//var2_name,status) - - end subroutine get_var2_r4 - - subroutine get_var2_double( ncid, var2_name, im, jm, var2 ) - integer, intent(in):: ncid - character(len=*), intent(in):: var2_name - integer, intent(in):: im, jm - real(kind=8), intent(out):: var2(im,jm) - - integer:: status, var2id - - status = nf_inq_varid (ncid, var2_name, var2id) - if (status .ne. NF_NOERR) call handle_err('get_var2_double varid'//var2_name,status) - - status = nf_get_var_double (ncid, var2id, var2) - if (status .ne. NF_NOERR) call handle_err('get_var2_double get_var_double'//var2_name,status) - - - end subroutine get_var2_double - - - subroutine get_var3_double( ncid, var3_name, im, jm, km, var3 ) - integer, intent(in):: ncid - character(len=*), intent(in):: var3_name - integer, intent(in):: im, jm, km - real(kind=8), intent(out):: var3(im,jm,km) - - integer:: status, var3id - - status = nf_inq_varid (ncid, var3_name, var3id) - - if (status .ne. NF_NOERR) & - call handle_err('get_var3_double varid '//var3_name,status) - - status = nf_get_var_double (ncid, var3id, var3) - if (status .ne. NF_NOERR) & - call handle_err('get_var3_double get_vara_double '//var3_name,status) - - end subroutine get_var3_double - - subroutine get_var3_real( ncid, var3_name, im, jm, km, var3 ) - integer, intent(in):: ncid - character(len=*), intent(in):: var3_name - integer, intent(in):: im, jm, km - real(kind=4), intent(out):: var3(im,jm,km) - - integer:: status, var3id - - status = nf_inq_varid (ncid, var3_name, var3id) - - if (status .ne. NF_NOERR) & - call handle_err('get_var3_real varid '//var3_name,status) - status = nf_get_var_real (ncid, var3id, var3) - - if (status .ne. NF_NOERR) & - call handle_err('get_var3_real get_var_real '//var3_name,status) - - end subroutine get_var3_real - - - subroutine check_var_exists(ncid, var_name, status) - integer, intent(in):: ncid - integer, intent(inout) :: status - character(len=*), intent(in):: var_name - integer:: varid - status = nf_inq_varid (ncid, var_name, varid) - end subroutine check_var_exists - - subroutine get_var3_r4( ncid, var3_name, is,ie, js,je, ks,ke, var3, time_slice ) - integer, intent(in):: ncid - character(len=*), intent(in):: var3_name - integer, intent(in):: is, ie, js, je, ks,ke - real(kind=4), intent(out):: var3(is:ie,js:je,ks:ke) - integer, intent(in), optional :: time_slice -! - real(kind=4), dimension(1) :: time - integer, dimension(4):: start, nreco - integer:: status, var3id - - status = nf_inq_varid (ncid, var3_name, var3id) - if (status .ne. NF_NOERR) call handle_err('get_var3_r4 varid '//var3_name,status) - - start(1) = is; start(2) = js; start(3) = ks; start(4) = 1 - if ( present(time_slice) ) then - start(4) = time_slice - end if - - nreco(1) = ie - is + 1 - nreco(2) = je - js + 1 - nreco(3) = ke - ks + 1 - nreco(4) = 1 - - status = nf_get_vara_real(ncid, var3id, start, nreco, var3) - if (status .ne. NF_NOERR) call handle_err('get_var3_r4 get_vara_real '//var3_name,status) - - end subroutine get_var3_r4 - - - subroutine get_var4_real( ncid, var4_name, im, jm, km, nt, var4 ) - implicit none -#include - integer, intent(in):: ncid - character*(*), intent(in):: var4_name - integer, intent(in):: im, jm, km, nt - real*4:: wk4(im,jm,km,4) - real*4, intent(out):: var4(im,jm) - integer:: status, var4id - integer:: start(4), icount(4) - integer:: i,j - - start(1) = 1 - start(2) = 1 - start(3) = 1 - start(4) = nt - - icount(1) = im ! all range - icount(2) = jm ! all range - icount(3) = km ! all range - icount(4) = 1 ! one time level at a time - -! write(*,*) nt, 'Within get_var4_double: ', var4_name - - status = nf_inq_varid (ncid, var4_name, var4id) -! write(*,*) '#1', status, ncid, var4id - - status = nf_get_vara_real(ncid, var4id, start, icount, var4) -! status = nf_get_vara_real(ncid, var4id, start, icount, wk4) -! write(*,*) '#2', status, ncid, var4id - - do j=1,jm - do i=1,im -! var4(i,j) = wk4(i,j,1,nt) - enddo - enddo - - if (status .ne. NF_NOERR) call handle_err('get_var4_r4 get_vara_real '//var4_name,status) - - end subroutine get_var4_real - - - subroutine get_var4_double( ncid, var4_name, im, jm, km, nt, var4 ) - integer, intent(in):: ncid - character(len=*), intent(in):: var4_name - integer, intent(in):: im, jm, km, nt - real(kind=8), intent(out):: var4(im,jm,km,1) - integer:: status, var4id -! - integer:: start(4), icount(4) - - start(1) = 1 - start(2) = 1 - start(3) = 1 - start(4) = nt - - icount(1) = im ! all range - icount(2) = jm ! all range - icount(3) = km ! all range - icount(4) = 1 ! one time level at a time - - status = nf_inq_varid (ncid, var4_name, var4id) - status = nf_get_vara_double(ncid, var4id, start, icount, var4) - - if (status .ne. NF_NOERR) call handle_err('get_var4_double get_vara_double '//var4_name,status) - - end subroutine get_var4_double -!------------------------------------------------------------------------ - - subroutine get_real3( ncid, var4_name, im, jm, nt, var4 ) -! This is for multi-time-level 2D var - integer, intent(in):: ncid - character(len=*), intent(in):: var4_name - integer, intent(in):: im, jm, nt - real(kind=4), intent(out):: var4(im,jm) - integer:: status, var4id - integer:: start(3), icount(3) - integer:: i,j - - start(1) = 1 - start(2) = 1 - start(3) = nt - - icount(1) = im - icount(2) = jm - icount(3) = 1 - - status = nf_inq_varid (ncid, var4_name, var4id) - status = nf_get_vara_real(ncid, var4id, start, icount, var4) - - if (status .ne. NF_NOERR) & - call handle_err('get_real3 get_vara_real '//var4_name,status) - - end subroutine get_real3 -!------------------------------------------------------------------------ - - logical function check_var( ncid, var3_name) - integer, intent(in):: ncid - character(len=*), intent(in):: var3_name - - integer:: status, var3id - - status = nf_inq_varid (ncid, var3_name, var3id) - check_var = (status == NF_NOERR) - - end function check_var - - subroutine get_var_att_str(ncid, var_name, att_name, att) - implicit none -#include - integer, intent(in):: ncid - character*(*), intent(in):: var_name, att_name - character*(*), intent(out):: att - - integer:: status, varid - - status = nf_inq_varid (ncid, var_name, varid) - status = nf_get_att_text(ncid, varid, att_name, att) - - if (status .ne. NF_NOERR) call handle_err('get_var_att_str '//var_name,status) - - end subroutine get_var_att_str - - subroutine get_var_att_double(ncid, var_name, att_name, value) - implicit none -#include - integer, intent(in):: ncid - character*(*), intent(in):: var_name, att_name - real(kind=8), intent(out):: value - - integer:: status, varid - - status = nf_inq_varid (ncid, var_name, varid) - status = nf_get_att(ncid, varid, att_name, value) - - if (status .ne. NF_NOERR) call handle_err('get_var_att_double '//var_name,status) - - end subroutine get_var_att_double - - - subroutine handle_err(idstr, status, errflg) - integer status - character(len=500) :: errstr - character(len=*) :: idstr - integer, optional, intent(inout) :: errflg - - if (status .ne. nf_noerr) then - write(errstr,*) 'Error in handle_err: ',trim(idstr)//' ',NF_STRERROR(STATUS) - ! call mpp_error(FATAL,errstr) - ! if (available(errflg)) errflg = 1 - ! return - write(6, *) trim(errstr) - stop - endif - - end subroutine handle_err - -!>@brief The subroutine 'calendar' computes the current GMT. - subroutine calendar(year, month, day, hour) - integer, intent(inout) :: year ! year - integer, intent(inout) :: month ! month - integer, intent(inout) :: day ! day - integer, intent(inout) :: hour -! -! Local variables -! - integer irem4,irem100 - integer mdays(12) !< number day of month - data mdays /31,28,31,30,31,30,31,31,30,31,30,31/ -!**** consider leap year -! - irem4 = mod( year, 4 ) - irem100 = mod( year, 100 ) - if( irem4 == 0 .and. irem100 /= 0) mdays(2) = 29 -! - if( hour >= 24 ) then - day = day + 1 - hour = hour - 24 - end if - - if( day > mdays(month) ) then - day = day - mdays(month) - month = month + 1 - end if - if( month > 12 ) then - year = year + 1 - month = 1 - end if - - end subroutine calendar - -end module sim_nc_mod_lnd From e8149406d08eb8bcaff0e93c58998aa5b5cdedd9 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 11 Jul 2024 08:10:08 -0400 Subject: [PATCH 067/154] use explcit array length --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index de245fcca..ceb2a7b79 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -261,11 +261,14 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) - allocate(Land_IAU_Data%stc_inc(is:ie, js:je, km)) - allocate(Land_IAU_Data%slc_inc(is:ie, js:je, km)) + allocate(Land_IAU_Data%stc_inc(nlon, nlat, km)) + allocate(Land_IAU_Data%slc_inc(nlon, nlat, km)) ! allocate arrays that will hold iau state - allocate (Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - allocate (Land_IAU_state%inc1%slc_inc(is:ie, js:je, km)) + allocate (Land_IAU_state%inc1%stc_inc(nlon, nlat, km)) + allocate (Land_IAU_state%inc1%slc_inc(nlon, nlat, km)) + allocate (Land_IAU_state%inc2%stc_inc(nlon, nlat, km)) + allocate (Land_IAU_state%inc2%slc_inc(nlon, nlat, km)) + Land_IAU_state%hr1=Land_IAU_Control%iaufhrs(1) Land_IAU_state%wt = 1.0 ! IAU increment filter weights (default 1.0) Land_IAU_state%wt_normfact = 1.0 @@ -351,9 +354,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) if (ntimes.EQ.1) then ! only need to get incrments once since constant forcing over window call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) endif - if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them - allocate (Land_IAU_state%inc2%stc_inc(is:ie, js:je, km)) - allocate (Land_IAU_state%inc2%slc_inc(is:ie, js:je, km)) + if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) do k = 1, npz ! do k = 1,n_soill ! From 18c769ce66b0f841d9d194f6c03fb9cdf7a4d3e1 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 11 Jul 2024 08:16:02 -0400 Subject: [PATCH 068/154] use explcit array length --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 0b9e17f97..fadbc70d1 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -4,7 +4,7 @@ dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F dependencies = module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90 dependencies = ../Noah/set_soilveg.f - dependencies = sim_nc_mod_lnd.F90,lnd_iau_mod.F90 + dependencies = lnd_iau_mod.F90 ######################################################################## [ccpp-arg-table] From 7644d5550c9cacf6bf71278217b312e8c45ac801 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 11 Jul 2024 08:44:12 -0400 Subject: [PATCH 069/154] debug print --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index ceb2a7b79..b6e322b54 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -261,6 +261,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !nblks = Land_IAU_Control%nblks !blksz = Land_IAU_Control%blksz(1) + print*, "rank is ie js je nlon nlat", Land_IAU_Control%me, is, ie, js, je, nlon, nlat + allocate(Land_IAU_Data%stc_inc(nlon, nlat, km)) allocate(Land_IAU_Data%slc_inc(nlon, nlat, km)) ! allocate arrays that will hold iau state From 77ed427372b797f2605c8b03b2d372ffdce0bc50 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 14 Jul 2024 10:26:05 -0400 Subject: [PATCH 070/154] read land snow mask from inc files --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 29 +++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index b6e322b54..d357ba48f 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -29,6 +29,7 @@ module land_iau_mod private real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) + integer(kind=kind_phys), allocatable :: wk3_slmsk(:, :, :) type land_iau_internal_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) @@ -39,7 +40,7 @@ module land_iau_mod real(kind=kind_phys),allocatable :: stc_inc(:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. - ! integer,allocatable :: snow_land_mask(:, :, :) + integer,allocatable :: snow_land_mask(:, :) end type land_iau_external_data_type type land_iau_state_type @@ -265,6 +266,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) allocate(Land_IAU_Data%stc_inc(nlon, nlat, km)) allocate(Land_IAU_Data%slc_inc(nlon, nlat, km)) + allocate(Land_IAU_Data%snow_land_mask(nlon, nlat)) + ! allocate arrays that will hold iau state allocate (Land_IAU_state%inc1%stc_inc(nlon, nlat, km)) allocate (Land_IAU_state%inc1%slc_inc(nlon, nlat, km)) @@ -305,6 +308,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) endif ! determine number of valid forecast hours +!TODO: can read this from the increment file ("Time" dim) ntimesall = size(Land_IAU_Control%iaufhrs) ntimes = 0 do k=1,ntimesall @@ -339,7 +343,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_state%rdt ! Read all increment files at iau init time (at beginning of cycle) - ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) + ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) @@ -358,6 +362,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) endif if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) + + Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) do k = 1, npz ! do k = 1,n_soill ! do j = 1, nlat @@ -383,9 +389,11 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg if (allocated (wk3_stc)) deallocate (wk3_stc) if (allocated (wk3_slc)) deallocate (wk3_slc) + if (allocated (wk3_slmsk)) deallocate (wk3_slmsk) if (allocated(Land_IAU_Data%stc_inc)) deallocate (Land_IAU_Data%stc_inc) if (allocated(Land_IAU_Data%slc_inc)) deallocate (Land_IAU_Data%slc_inc) + if (allocated(Land_IAU_Data%snow_land_mask)) deallocate (Land_IAU_Data%snow_land_mask) if (allocated(Land_IAU_state%inc1%stc_inc)) deallocate(Land_IAU_state%inc1%stc_inc) if (allocated(Land_IAU_state%inc1%slc_inc)) deallocate(Land_IAU_state%inc1%slc_inc) @@ -483,6 +491,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif + Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) endif endif @@ -542,6 +551,7 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) Land_IAU_Data%stc_inc(i,j,k) = wt*Land_IAU_state%inc1%stc_inc(i,j,k)*rdt Land_IAU_Data%slc_inc(i,j,k) = wt*Land_IAU_state%inc1%slc_inc(i,j,k)*rdt end do + Land_IAU_Data%snow_land_mask(i, j) = wk3_slmsk(1, i, j) enddo enddo @@ -565,6 +575,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] + character(len=32) :: slsn_mask = "soilsnow_mask" !Errors messages handled through CCPP error handling variables errmsg = '' @@ -609,6 +620,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou allocate(wk3_stc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) allocate(wk3_slc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) + allocate(wk3_slmsk(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny)) do i = 1, size(stc_vars) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(stc_vars(i)) @@ -644,6 +656,19 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou wk3_slc(:, :, :, i) = 0. endif enddo + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(slsn_mask) + status = nf90_inq_varid(ncid, trim(slsn_mask), varid) + if (status == nf90_noerr) then !if (ierr == 0) then + do it = 1, n_t + call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, wk3_slmsk(it, :, :), status) + call netcdf_err(status, 'reading var: '//trim(slsn_mask), errflg, errmsg) + if (errflg .ne. 0) return + enddo + else + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, 'warning: no values for ',trim(slsn_mask), ' found', & + 'assuming value of 1 for all grid cells. Please make sure the increment files have soil snow mask var' + wk3_slmsk(:, :, :) = 1 + endif status =nf90_close(ncid) call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) From 4590b5d7bf9ffd45eab77df313a2ab25f7ea35b5 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 14 Jul 2024 10:47:39 -0400 Subject: [PATCH 071/154] read land snow mask from inc files --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 22 +++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index d357ba48f..850b86a4e 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -362,7 +362,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) endif if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - + Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) do k = 1, npz ! do k = 1,n_soill ! @@ -660,7 +660,8 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou status = nf90_inq_varid(ncid, trim(slsn_mask), varid) if (status == nf90_noerr) then !if (ierr == 0) then do it = 1, n_t - call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, wk3_slmsk(it, :, :), status) + call get_var3d_values_int(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & + it, 1, wk3_slmsk(it, :, :), status) call netcdf_err(status, 'reading var: '//trim(slsn_mask), errflg, errmsg) if (errflg .ne. 0) return enddo @@ -810,6 +811,23 @@ subroutine get_var3d_values(ncid, varid, is,ix, js,jy, ks,kz, var3d, status) ! start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) end subroutine get_var3d_values + + subroutine get_var3d_values_int(ncid, varid, is,ix, js,jy, ks,kz, var3d, status) + integer, intent(in):: ncid, varid + integer, intent(in):: is, ix, js, jy, ks,kz + integer, intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) + integer, intent(out):: status + ! integer, dimension(3):: start, nreco + ! start(1) = is; start(2) = js; start(3) = ks + ! nreco(1) = ie - is + 1 + ! nreco(2) = je - js + 1 + ! nreco(3) = ke - ks + 1 + + status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) + start = (/is, js, ks/), count = (/ix, jy, kz/)) + ! start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) + + end subroutine get_var3d_values_int end module land_iau_mod From 562e6d3cae58cde0b8de5671cb2bafa530f3834b Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 14 Jul 2024 11:11:03 -0400 Subject: [PATCH 072/154] read land snow mask from inc files --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 850b86a4e..cc69dcc28 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -29,7 +29,7 @@ module land_iau_mod private real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) - integer(kind=kind_phys), allocatable :: wk3_slmsk(:, :, :) + integer, allocatable :: wk3_slmsk(:, :, :) type land_iau_internal_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) From 1a936bb0b43cc5beef6f73fde13004656896e7f2 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 14 Jul 2024 14:18:37 -0400 Subject: [PATCH 073/154] test on adj --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 42 ++++++++++---------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 74aaffb9e..7b0115611 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -328,27 +328,27 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo return endif n_stc = 0 - do i=1,lensfc - if (stc_updated(i) == 1 ) then ! soil-only location - n_stc = n_stc+1 - soiltype = soiltyp(i) - do l = 1, lsoil_incr - !case 1: frz ==> frz, recalculate slc, smc remains - !case 2: unfrz ==> frz, recalculate slc, smc remains - !both cases are considered in the following if case - if (stc(i,l) .LT. tfreez )then - !recompute supercool liquid water,smc_anl remain unchanged - smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) - slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) - slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) - endif - !case 3: frz ==> unfrz, melt all soil ice (if any) - if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck - slc(i,l)=smc(i,l) - endif - enddo - endif - enddo + ! do i=1,lensfc + ! if (stc_updated(i) == 1 ) then ! soil-only location + ! n_stc = n_stc+1 + ! soiltype = soiltyp(i) + ! do l = 1, lsoil_incr + ! !case 1: frz ==> frz, recalculate slc, smc remains + ! !case 2: unfrz ==> frz, recalculate slc, smc remains + ! !both cases are considered in the following if case + ! if (stc(i,l) .LT. tfreez )then + ! !recompute supercool liquid water,smc_anl remain unchanged + ! smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) + ! slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) + ! slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) + ! endif + ! !case 3: frz ==> unfrz, melt all soil ice (if any) + ! if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck + ! slc(i,l)=smc(i,l) + ! endif + ! enddo + ! endif + ! enddo deallocate(stc_updated) deallocate(mask_tile) From f53c9ab937a84a37ab1e31070b2055a03bf773e6 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 15 Jul 2024 10:21:10 -0400 Subject: [PATCH 074/154] print debug info --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 39 ++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 7b0115611..68c27cab0 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -280,6 +280,31 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo !TODO---if only fv3 increment files are used, this can be read from file allocate(mask_tile(lensfc)) call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, + + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num + ! do ij = 1, lensfc + ! print*, stc(ij,1) + ! enddo + ib = 1 + do j = 1, Land_IAU_Control%ny !ny + do i = ib, ib+Land_IAU_Control%nx-1 + print*, stc(i, 1) + enddo + ib = ib + Land_IAU_Control%nx !nlon + enddo + print*, "root proc layer 1 inc" + ! do ij = 1, lensfc + ! print*, stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp + ! enddo + ib = 1 + do j = 1, Land_IAU_Control%ny !ny + do i = ib, ib+Land_IAU_Control%nx-1 + print*, stc_inc_flat(i, 1)*delt + enddo + ib = ib + Land_IAU_Control%nx !nlon + enddo + endif !IAU increments are in units of 1/sec !Land_IAU_Control%dtp !* only updating soil temp for now @@ -312,6 +337,20 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp ! enddo + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "root proc layer 1 stc after adding IAU inc" + ! do ij = 1, lensfc + ! print*, stc(ij,1) + ! enddo + ib = 1 + do j = 1, Land_IAU_Control%ny !ny + do i = ib, ib+Land_IAU_Control%nx-1 + print*, stc(i, 1) + enddo + ib = ib + Land_IAU_Control%nx !nlon + enddo + endif + deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) ! (consistency) adjustments for updated soil temp and moisture From e6b68c7c927cea46cb6f4ec7f4d7201e38c72051 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 15 Jul 2024 10:57:17 -0400 Subject: [PATCH 075/154] print debug info --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 68c27cab0..7bf1fd6fa 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -288,9 +288,11 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! enddo ib = 1 do j = 1, Land_IAU_Control%ny !ny - do i = ib, ib+Land_IAU_Control%nx-1 - print*, stc(i, 1) - enddo + ! do i = ib, ib+Land_IAU_Control%nx-1 + ! print*, stc(i, 1) + ! WRITE(*,"(10F5.2)") + ! enddo + WRITE(*,"(48F7.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) ib = ib + Land_IAU_Control%nx !nlon enddo print*, "root proc layer 1 inc" @@ -299,9 +301,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! enddo ib = 1 do j = 1, Land_IAU_Control%ny !ny - do i = ib, ib+Land_IAU_Control%nx-1 - print*, stc_inc_flat(i, 1)*delt - enddo + ! do i = ib, ib+Land_IAU_Control%nx-1 + ! print*, stc_inc_flat(i, 1)*delt + ! enddo + WRITE(*,"(48F7.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1) ib = ib + Land_IAU_Control%nx !nlon enddo endif @@ -350,7 +353,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ib = ib + Land_IAU_Control%nx !nlon enddo endif - + deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) ! (consistency) adjustments for updated soil temp and moisture From c575a42f4c5bec4f44b7903f89c44b463f6dc30a Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 15 Jul 2024 11:27:22 -0400 Subject: [PATCH 076/154] print debug info --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 7bf1fd6fa..a037e6bf9 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -292,7 +292,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! print*, stc(i, 1) ! WRITE(*,"(10F5.2)") ! enddo - WRITE(*,"(48F7.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) + WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) ib = ib + Land_IAU_Control%nx !nlon enddo print*, "root proc layer 1 inc" @@ -304,7 +304,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! do i = ib, ib+Land_IAU_Control%nx-1 ! print*, stc_inc_flat(i, 1)*delt ! enddo - WRITE(*,"(48F7.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1) + WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt ib = ib + Land_IAU_Control%nx !nlon enddo endif @@ -347,9 +347,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! enddo ib = 1 do j = 1, Land_IAU_Control%ny !ny - do i = ib, ib+Land_IAU_Control%nx-1 - print*, stc(i, 1) - enddo + ! do i = ib, ib+Land_IAU_Control%nx-1 + ! print*, stc(i, 1) + ! enddo + WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) ib = ib + Land_IAU_Control%nx !nlon enddo endif From ca26670f7060f7cd80ffa1fb8d876bb0ba3c4c7e Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 15 Jul 2024 16:53:18 -0400 Subject: [PATCH 077/154] restrore stc/slc adjustments --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 42 ++++++++++---------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index a037e6bf9..598295498 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -371,27 +371,27 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo return endif n_stc = 0 - ! do i=1,lensfc - ! if (stc_updated(i) == 1 ) then ! soil-only location - ! n_stc = n_stc+1 - ! soiltype = soiltyp(i) - ! do l = 1, lsoil_incr - ! !case 1: frz ==> frz, recalculate slc, smc remains - ! !case 2: unfrz ==> frz, recalculate slc, smc remains - ! !both cases are considered in the following if case - ! if (stc(i,l) .LT. tfreez )then - ! !recompute supercool liquid water,smc_anl remain unchanged - ! smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) - ! slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) - ! slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) - ! endif - ! !case 3: frz ==> unfrz, melt all soil ice (if any) - ! if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck - ! slc(i,l)=smc(i,l) - ! endif - ! enddo - ! endif - ! enddo + do i=1,lensfc + if (stc_updated(i) == 1 ) then ! soil-only location + n_stc = n_stc+1 + soiltype = soiltyp(i) + do l = 1, lsoil_incr + !case 1: frz ==> frz, recalculate slc, smc remains + !case 2: unfrz ==> frz, recalculate slc, smc remains + !both cases are considered in the following if case + if (stc(i,l) .LT. tfreez )then + !recompute supercool liquid water,smc_anl remain unchanged + smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) + slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) + slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) + endif + !case 3: frz ==> unfrz, melt all soil ice (if any) + if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck + slc(i,l)=smc(i,l) + endif + enddo + endif + enddo deallocate(stc_updated) deallocate(mask_tile) From 2c0c276ea0141448f291e3f3d5f9c503e1077245 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 16 Jul 2024 09:52:41 -0400 Subject: [PATCH 078/154] print diff indices --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 52 ++++++++++---------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 598295498..88f3d807d 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -184,7 +184,9 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo integer, intent(out) :: errflg ! IAU update - real,allocatable :: stc_inc_flat(:,:) + real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat + real(kind=kind_phys),allocatable, dimension(:) :: stc_bck, d_stc + integer, allocatable, dimension(:) :: diff_indices ! real,allocatable :: slc_inc_flat(:,:) integer :: lsoil_incr ! integer :: veg_type_landice @@ -194,17 +196,17 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo logical :: soil_freeze, soil_ice integer :: n_freeze, n_thaw integer :: soiltype, n_stc - real :: slc_new + real(kind=kind_phys) :: slc_new integer :: i, j, ij, l, k, ib integer :: lensfc ! real (kind=kind_phys), dimension(max_soiltyp) :: maxsmc, bb, satpsi ! real, dimension(30) :: maxsmc, bb, satpsi - real, parameter :: tfreez=273.16 !< con_t0c in physcons - real, parameter :: hfus=0.3336e06 !< latent heat of fusion(j/kg) - real, parameter :: grav=9.80616 !< gravity accel.(m/s2) - real :: smp !< for computing supercooled water + real(kind=kind_phys), parameter :: tfreez=273.16 !< con_t0c in physcons + real(kind=kind_phys), parameter :: hfus=0.3336e06 !< latent heat of fusion(j/kg) + real(kind=kind_phys), parameter :: grav=9.80616 !< gravity accel.(m/s2) + real(kind=kind_phys) :: smp !< for computing supercooled water integer :: nother, nsnowupd integer :: nstcupd, nfrozen, nfrozen_upd @@ -249,6 +251,11 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) + !copy background stc + allocate(stc_bck(Land_IAU_Control%nx * Land_IAU_Control%ny)) + allocate(d_stc(Land_IAU_Control%nx * Land_IAU_Control%ny)) + stc_bck = stc(:, 1) + stc_updated = 0 ib = 1 do j = 1, Land_IAU_Control%ny !ny @@ -259,6 +266,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ib = ib + Land_IAU_Control%nx !nlon enddo + + ! delt=GFS_Control%dtf if ((Land_IAU_Control%dtp - delt) > 0.0001) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then @@ -283,27 +292,14 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num - ! do ij = 1, lensfc - ! print*, stc(ij,1) - ! enddo ib = 1 do j = 1, Land_IAU_Control%ny !ny - ! do i = ib, ib+Land_IAU_Control%nx-1 - ! print*, stc(i, 1) - ! WRITE(*,"(10F5.2)") - ! enddo WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) ib = ib + Land_IAU_Control%nx !nlon enddo print*, "root proc layer 1 inc" - ! do ij = 1, lensfc - ! print*, stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp - ! enddo ib = 1 do j = 1, Land_IAU_Control%ny !ny - ! do i = ib, ib+Land_IAU_Control%nx-1 - ! print*, stc_inc_flat(i, 1)*delt - ! enddo WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt ib = ib + Land_IAU_Control%nx !nlon enddo @@ -342,14 +338,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! enddo if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print*, "root proc layer 1 stc after adding IAU inc" - ! do ij = 1, lensfc - ! print*, stc(ij,1) - ! enddo ib = 1 do j = 1, Land_IAU_Control%ny !ny - ! do i = ib, ib+Land_IAU_Control%nx-1 - ! print*, stc(i, 1) - ! enddo WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) ib = ib + Land_IAU_Control%nx !nlon enddo @@ -392,9 +382,19 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo enddo endif enddo - + + d_stc = stc(:, 1) - stc_bck + ! Where(d_stc .gt. 0.0001) + diff_indices = pack([(i, i=1, lensfc)], d_stc > 0.0001) + print*, "proc ", Land_IAU_Control%me, " indices with large increment" + print*, diff_indices + print*, d_stc(diff_indices) + + deallocate(stc_bck, d_stc) + if(allocated(diff_indices)) deallocate(diff_indices) deallocate(stc_updated) deallocate(mask_tile) + write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me write(*,'(a,i8)') ' soil grid total', lensfc From 119ebbd13d04cbf246b9f7224e91f43dc3971443 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 18 Jul 2024 17:38:38 -0400 Subject: [PATCH 079/154] bypass _timestep_init --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 88f3d807d..873550d9d 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -214,6 +214,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! --- Initialize CCPP error handling variables errmsg = '' errflg = 0 + + return if (.not. Land_IAU_Control%do_land_iau) return From 9bfc30561d38558b8f76127b2ba5e121510af7e4 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 18 Jul 2024 18:33:42 -0400 Subject: [PATCH 080/154] bypass _timestep_init --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 303 ++++++++++--------- 1 file changed, 154 insertions(+), 149 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 873550d9d..5a61cc435 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -214,8 +214,6 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo ! --- Initialize CCPP error handling variables errmsg = '' errflg = 0 - - return if (.not. Land_IAU_Control%do_land_iau) return @@ -249,163 +247,170 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo return endif - ! local variable to copy blocked data Land_IAU_Data%stc_inc - allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols - ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols - allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) - !copy background stc - allocate(stc_bck(Land_IAU_Control%nx * Land_IAU_Control%ny)) - allocate(d_stc(Land_IAU_Control%nx * Land_IAU_Control%ny)) - stc_bck = stc(:, 1) - - stc_updated = 0 - ib = 1 - do j = 1, Land_IAU_Control%ny !ny - do k = 1, km - stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%stc_inc(:,j, k) - ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) - enddo - ib = ib + Land_IAU_Control%nx !nlon + do j = 33, 35 + do i = 40, 42 + ib = (j - 1) * Land_IAU_Control%nx + i + stc(ib, 1) = Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + enddo enddo +! ! local variable to copy blocked data Land_IAU_Data%stc_inc +! allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols +! ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols +! allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) +! !copy background stc +! allocate(stc_bck(Land_IAU_Control%nx * Land_IAU_Control%ny)) +! allocate(d_stc(Land_IAU_Control%nx * Land_IAU_Control%ny)) +! stc_bck = stc(:, 1) + +! stc_updated = 0 +! ib = 1 +! do j = 1, Land_IAU_Control%ny !ny +! do k = 1, km +! stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%stc_inc(:,j, k) +! ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) +! enddo +! ib = ib + Land_IAU_Control%nx !nlon +! enddo + - ! delt=GFS_Control%dtf - if ((Land_IAU_Control%dtp - delt) > 0.0001) then - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_run delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp - endif - endif +! ! delt=GFS_Control%dtf +! if ((Land_IAU_Control%dtp - delt) > 0.0001) then +! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then +! print*, "Warning noahmpdrv_run delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp +! endif +! endif - lsoil_incr = Land_IAU_Control%lsoil_incr - lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny - - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,' adjusting first ', lsoil_incr, ' surface layers only, delt ', delt - ! initialize variables for counts statitics to be zeros - nother = 0 ! grid cells not land - nsnowupd = 0 ! grid cells with snow (temperature not yet updated) - nstcupd = 0 ! grid cells that are updated - nfrozen = 0 ! not update as frozen soil - nfrozen_upd = 0 ! not update as frozen soil - -!TODO---if only fv3 increment files are used, this can be read from file - allocate(mask_tile(lensfc)) - call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, - - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num - ib = 1 - do j = 1, Land_IAU_Control%ny !ny - WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) - ib = ib + Land_IAU_Control%nx !nlon - enddo - print*, "root proc layer 1 inc" - ib = 1 - do j = 1, Land_IAU_Control%ny !ny - WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt - ib = ib + Land_IAU_Control%nx !nlon - enddo - endif +! lsoil_incr = Land_IAU_Control%lsoil_incr +! lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny + +! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,' adjusting first ', lsoil_incr, ' surface layers only, delt ', delt +! ! initialize variables for counts statitics to be zeros +! nother = 0 ! grid cells not land +! nsnowupd = 0 ! grid cells with snow (temperature not yet updated) +! nstcupd = 0 ! grid cells that are updated +! nfrozen = 0 ! not update as frozen soil +! nfrozen_upd = 0 ! not update as frozen soil + +! !TODO---if only fv3 increment files are used, this can be read from file +! allocate(mask_tile(lensfc)) +! call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, + +! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then +! print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num +! ib = 1 +! do j = 1, Land_IAU_Control%ny !ny +! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) +! ib = ib + Land_IAU_Control%nx !nlon +! enddo +! print*, "root proc layer 1 inc" +! ib = 1 +! do j = 1, Land_IAU_Control%ny !ny +! WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt +! ib = ib + Land_IAU_Control%nx !nlon +! enddo +! endif - !IAU increments are in units of 1/sec !Land_IAU_Control%dtp - !* only updating soil temp for now - ij_loop : do ij = 1, lensfc - ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land - if (mask_tile(ij) == 1) then - ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) - soil_freeze=.false. - soil_ice=.false. - do k = 1, lsoil_incr ! k = 1, km - if ( stc(ij,k) < tfreez) soil_freeze=.true. - if ( smc(ij,k) - slc(ij,k) > 0.001 ) soil_ice=.true. - - stc(ij,k) = stc(ij,k) + stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp - - if (k==1) then - stc_updated(ij) = 1 - nstcupd = nstcupd + 1 - endif - if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) )& - nfrozen_upd = nfrozen_upd + 1 - ! moisture updates not done if this layer or any above is frozen - if ( soil_freeze .or. soil_ice ) then - if (k==1) nfrozen = nfrozen+1 - endif - enddo - endif ! if soil/snow point - enddo ij_loop - ! do k = 1, km - ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp - ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp - ! enddo - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "root proc layer 1 stc after adding IAU inc" - ib = 1 - do j = 1, Land_IAU_Control%ny !ny - WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) - ib = ib + Land_IAU_Control%nx !nlon - enddo - endif - - deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) - -! (consistency) adjustments for updated soil temp and moisture - - ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) - call read_mp_table_parameters(errmsg, errflg) - ! maxsmc(1:slcats) = smcmax_table(1:slcats) - ! bb(1:slcats) = bexp_table(1:slcats) - ! satpsi(1:slcats) = psisat_table(1:slcats) +! !IAU increments are in units of 1/sec !Land_IAU_Control%dtp +! !* only updating soil temp for now +! ij_loop : do ij = 1, lensfc +! ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land +! if (mask_tile(ij) == 1) then +! ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) +! soil_freeze=.false. +! soil_ice=.false. +! do k = 1, lsoil_incr ! k = 1, km +! if ( stc(ij,k) < tfreez) soil_freeze=.true. +! if ( smc(ij,k) - slc(ij,k) > 0.001 ) soil_ice=.true. + +! stc(ij,k) = stc(ij,k) + stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp + +! if (k==1) then +! stc_updated(ij) = 1 +! nstcupd = nstcupd + 1 +! endif +! if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) )& +! nfrozen_upd = nfrozen_upd + 1 +! ! moisture updates not done if this layer or any above is frozen +! if ( soil_freeze .or. soil_ice ) then +! if (k==1) nfrozen = nfrozen+1 +! endif +! enddo +! endif ! if soil/snow point +! enddo ij_loop +! ! do k = 1, km +! ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp +! ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp +! ! enddo +! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then +! print*, "root proc layer 1 stc after adding IAU inc" +! ib = 1 +! do j = 1, Land_IAU_Control%ny !ny +! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) +! ib = ib + Land_IAU_Control%nx !nlon +! enddo +! endif + +! deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + +! ! (consistency) adjustments for updated soil temp and moisture + +! ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) +! call read_mp_table_parameters(errmsg, errflg) +! ! maxsmc(1:slcats) = smcmax_table(1:slcats) +! ! bb(1:slcats) = bexp_table(1:slcats) +! ! satpsi(1:slcats) = psisat_table(1:slcats) - if (errflg .ne. 0) then - print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' - errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' - return - endif - n_stc = 0 - do i=1,lensfc - if (stc_updated(i) == 1 ) then ! soil-only location - n_stc = n_stc+1 - soiltype = soiltyp(i) - do l = 1, lsoil_incr - !case 1: frz ==> frz, recalculate slc, smc remains - !case 2: unfrz ==> frz, recalculate slc, smc remains - !both cases are considered in the following if case - if (stc(i,l) .LT. tfreez )then - !recompute supercool liquid water,smc_anl remain unchanged - smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) - slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) - slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) - endif - !case 3: frz ==> unfrz, melt all soil ice (if any) - if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck - slc(i,l)=smc(i,l) - endif - enddo - endif - enddo - - d_stc = stc(:, 1) - stc_bck - ! Where(d_stc .gt. 0.0001) - diff_indices = pack([(i, i=1, lensfc)], d_stc > 0.0001) - print*, "proc ", Land_IAU_Control%me, " indices with large increment" - print*, diff_indices - print*, d_stc(diff_indices) +! if (errflg .ne. 0) then +! print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' +! errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' +! return +! endif +! n_stc = 0 +! do i=1,lensfc +! if (stc_updated(i) == 1 ) then ! soil-only location +! n_stc = n_stc+1 +! soiltype = soiltyp(i) +! do l = 1, lsoil_incr +! !case 1: frz ==> frz, recalculate slc, smc remains +! !case 2: unfrz ==> frz, recalculate slc, smc remains +! !both cases are considered in the following if case +! if (stc(i,l) .LT. tfreez )then +! !recompute supercool liquid water,smc_anl remain unchanged +! smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) +! slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) +! slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) +! endif +! !case 3: frz ==> unfrz, melt all soil ice (if any) +! if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck +! slc(i,l)=smc(i,l) +! endif +! enddo +! endif +! enddo + +! d_stc = stc(:, 1) - stc_bck +! ! Where(d_stc .gt. 0.0001) +! diff_indices = pack([(i, i=1, lensfc)], d_stc > 0.0001) +! print*, "proc ", Land_IAU_Control%me, " indices with large increment" +! print*, diff_indices +! print*, d_stc(diff_indices) - deallocate(stc_bck, d_stc) - if(allocated(diff_indices)) deallocate(diff_indices) - deallocate(stc_updated) - deallocate(mask_tile) +! deallocate(stc_bck, d_stc) +! if(allocated(diff_indices)) deallocate(diff_indices) +! deallocate(stc_updated) +! deallocate(mask_tile) - write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me - write(*,'(a,i8)') ' soil grid total', lensfc - write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd - write(*,'(a,i8)') ' soil grid cells not updated, frozen = ',nfrozen - write(*,'(a,i8)') ' soil grid cells update, became frozen = ',nfrozen_upd - write(*,'(a,i8)') ' (not updated yet) snow grid cells = ', nsnowupd - write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother - write(*,'(a,i8)') ' soil grid cells with stc update', n_stc +! write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me +! write(*,'(a,i8)') ' soil grid total', lensfc +! write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd +! write(*,'(a,i8)') ' soil grid cells not updated, frozen = ',nfrozen +! write(*,'(a,i8)') ' soil grid cells update, became frozen = ',nfrozen_upd +! write(*,'(a,i8)') ' (not updated yet) snow grid cells = ', nsnowupd +! write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother +! write(*,'(a,i8)') ' soil grid cells with stc update', n_stc endif From 3234712bc63761a2f403f8c0033d3464eac300fc Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 19 Jul 2024 18:05:06 -0400 Subject: [PATCH 081/154] test with hardcoded inc --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 19 ++++++++++++------- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 7 +++++++ 2 files changed, 19 insertions(+), 7 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 5a61cc435..bc40854f6 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -155,7 +155,7 @@ end subroutine noahmpdrv_init !! Note: For Case 3, Yuan Xue thoroughly evaluated a total of four options and !! current option is found to be the best as of 11/09/2023 -subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_root, +subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !me, mpi_root, isot, ivegsrc, soiltyp, vegtype, weasd, & stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, @@ -170,6 +170,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo real(kind=kind_phys) , intent(in) :: fhour !current forecast time (hr) real(kind=kind_phys) , intent(in) :: delt ! time interval [s] integer , intent(in) :: km !vertical soil layer dimension + integer, intent(in) :: ncols integer, intent(in) :: isot integer, intent(in) :: ivegsrc @@ -247,12 +248,16 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, & !me, mpi_roo return endif - do j = 33, 35 - do i = 40, 42 - ib = (j - 1) * Land_IAU_Control%nx + i - stc(ib, 1) = Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp - enddo - enddo + if(Land_IAU_Control%tile_num == 1) then + print*, "proc, tile num, layer 1 stc_inc at 33:35,40:42", Land_IAU_Control%me, Land_IAU_Control%tile_num + do j = 33, 35 + WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) + do i = 40, 42 + ib = (j - 1) * Land_IAU_Control%nx + i + stc(ib, 1) = stc(ib, 1) + 0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + enddo + enddo + endif ! ! local variable to copy blocked data Land_IAU_Data%stc_inc ! allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index fadbc70d1..892894329 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -257,6 +257,13 @@ dimensions = () type = integer intent = in +[ncols] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in [isot] standard_name = control_for_soil_type_dataset long_name = soil type dataset choice From 432015dc6197c9ce933d516ddad26fe1e8ec1416 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 19 Jul 2024 19:06:53 -0400 Subject: [PATCH 082/154] test with hardcoded inc --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index bc40854f6..6cfedee8c 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -186,7 +186,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! IAU update real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat - real(kind=kind_phys),allocatable, dimension(:) :: stc_bck, d_stc + ! real(kind=kind_phys),allocatable, dimension(:) :: stc_bck, d_stc + real(kind=kind_phys), :: stc_bck(ncols, km), d_stc(ncols, km) integer, allocatable, dimension(:) :: diff_indices ! real,allocatable :: slc_inc_flat(:,:) integer :: lsoil_incr @@ -209,6 +210,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & real(kind=kind_phys), parameter :: grav=9.80616 !< gravity accel.(m/s2) real(kind=kind_phys) :: smp !< for computing supercooled water + real(kind=kind_phys) :: hc_incr + integer :: nother, nsnowupd integer :: nstcupd, nfrozen, nfrozen_upd @@ -248,13 +251,18 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & return endif + stc_bck = stc + hc_incr = 0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 + if(Land_IAU_Control%tile_num == 1) then + print*, "stc_bck shape, min, max ", shape(stc_bck), minval(stc_bck), maxval(stc_bck) + print*, " hc_incr ", hc_incr print*, "proc, tile num, layer 1 stc_inc at 33:35,40:42", Land_IAU_Control%me, Land_IAU_Control%tile_num do j = 33, 35 WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) do i = 40, 42 ib = (j - 1) * Land_IAU_Control%nx + i - stc(ib, 1) = stc(ib, 1) + 0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp enddo enddo endif From 62fd97c0b339113d93e6b7ca8f93f3a11ee4ec05 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 19 Jul 2024 19:28:58 -0400 Subject: [PATCH 083/154] test with hardcoded inc --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 6cfedee8c..4627cb74d 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -187,7 +187,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! IAU update real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat ! real(kind=kind_phys),allocatable, dimension(:) :: stc_bck, d_stc - real(kind=kind_phys), :: stc_bck(ncols, km), d_stc(ncols, km) + real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) integer, allocatable, dimension(:) :: diff_indices ! real,allocatable :: slc_inc_flat(:,:) integer :: lsoil_incr From 6c2ac7618940c499172292be9f9de6106c2be547 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 19 Jul 2024 20:17:12 -0400 Subject: [PATCH 084/154] test with hardcoded inc --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 4627cb74d..0fb4221d8 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -252,7 +252,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & endif stc_bck = stc - hc_incr = 0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 + hc_incr = 0.0 !0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 if(Land_IAU_Control%tile_num == 1) then print*, "stc_bck shape, min, max ", shape(stc_bck), minval(stc_bck), maxval(stc_bck) From bde3e05738c570c6ace189a794f65e6e064c95d4 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 19 Jul 2024 20:58:23 -0400 Subject: [PATCH 085/154] test with hardcoded inc --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 28 +++++++++++--------- 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 0fb4221d8..c47eda703 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -254,18 +254,22 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & stc_bck = stc hc_incr = 0.0 !0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 - if(Land_IAU_Control%tile_num == 1) then - print*, "stc_bck shape, min, max ", shape(stc_bck), minval(stc_bck), maxval(stc_bck) - print*, " hc_incr ", hc_incr - print*, "proc, tile num, layer 1 stc_inc at 33:35,40:42", Land_IAU_Control%me, Land_IAU_Control%tile_num - do j = 33, 35 - WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) - do i = 40, 42 - ib = (j - 1) * Land_IAU_Control%nx + i - stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp - enddo - enddo - endif + ! if(Land_IAU_Control%tile_num == 1) then + ! print*, "stc_bck shape, min, max ", shape(stc_bck), minval(stc_bck), maxval(stc_bck) + ! print*, " hc_incr ", hc_incr + ! print*, "proc, tile num, layer 1 stc_inc at 33:35,40:42", Land_IAU_Control%me, Land_IAU_Control%tile_num + ! do j = 33, 35 + ! WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) + ! do i = 40, 42 + ! ib = (j - 1) * Land_IAU_Control%nx + i + ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + ! enddo + ! enddo + ! endif + + do ib = 1, ncols + stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + enddo ! ! local variable to copy blocked data Land_IAU_Data%stc_inc ! allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols From ff3660f24096fd67a0d7d5af31c8b6de0587c23a Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 21 Jul 2024 13:54:28 -0400 Subject: [PATCH 086/154] test non-iau increment hardcoded --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index c47eda703..ffc8c6b31 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -267,9 +267,9 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! enddo ! endif - do ib = 1, ncols - stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp - enddo + ! do ib = 1, ncols + ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + ! enddo ! ! local variable to copy blocked data Land_IAU_Data%stc_inc ! allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols @@ -1059,6 +1059,8 @@ subroutine noahmpdrv_run & errmsg = '' errflg = 0 + stc(:, 4) = stc(:, 4) + 0.000001 + do i = 1, im if (flag_iter(i) .and. dry(i)) then From 6f18f657375b399dd08a61894981002f84a8b7a4 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 23 Jul 2024 07:13:48 -0400 Subject: [PATCH 087/154] test 0 inc double prec --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 266 ++++++++++--------- 1 file changed, 138 insertions(+), 128 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index ffc8c6b31..a6697effc 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -240,136 +240,148 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & endif !> update land states with iau increments - if (Land_IAU_Data%in_interval) then + if (.not. Land_IAU_Data%in_interval) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "adding land iau increments " + print*, "current time step not in IAU interval " endif + return + endif - if (Land_IAU_Control%lsoil .ne. km) then - write(errmsg,*) 'noahmpdrv_timestep_init: Land_IAU_Data%lsoil ',Land_IAU_Control%lsoil,' not equal to km ',km - errflg = 1 - return - endif + ! if (Land_IAU_Data%in_interval) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "adding land iau increments " + endif - stc_bck = stc - hc_incr = 0.0 !0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 - - ! if(Land_IAU_Control%tile_num == 1) then - ! print*, "stc_bck shape, min, max ", shape(stc_bck), minval(stc_bck), maxval(stc_bck) - ! print*, " hc_incr ", hc_incr - ! print*, "proc, tile num, layer 1 stc_inc at 33:35,40:42", Land_IAU_Control%me, Land_IAU_Control%tile_num - ! do j = 33, 35 - ! WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) - ! do i = 40, 42 - ! ib = (j - 1) * Land_IAU_Control%nx + i - ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp - ! enddo - ! enddo - ! endif - - ! do ib = 1, ncols - ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp - ! enddo + if (Land_IAU_Control%lsoil .ne. km) then + write(errmsg,*) 'noahmpdrv_timestep_init: Land_IAU_Data%lsoil ',Land_IAU_Control%lsoil,' not equal to km ',km + errflg = 1 + return + endif -! ! local variable to copy blocked data Land_IAU_Data%stc_inc -! allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols -! ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols -! allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) -! !copy background stc -! allocate(stc_bck(Land_IAU_Control%nx * Land_IAU_Control%ny)) -! allocate(d_stc(Land_IAU_Control%nx * Land_IAU_Control%ny)) -! stc_bck = stc(:, 1) - -! stc_updated = 0 -! ib = 1 -! do j = 1, Land_IAU_Control%ny !ny -! do k = 1, km -! stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%stc_inc(:,j, k) -! ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) -! enddo -! ib = ib + Land_IAU_Control%nx !nlon -! enddo + stc_bck = stc + + ! hc_incr = 0.0 !0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 + + ! if(Land_IAU_Control%tile_num == 1) then + ! print*, "stc_bck shape, min, max ", shape(stc_bck), minval(stc_bck), maxval(stc_bck) + ! print*, " hc_incr ", hc_incr + ! print*, "proc, tile num, layer 1 stc_inc at 33:35,40:42", Land_IAU_Control%me, Land_IAU_Control%tile_num + ! do j = 33, 35 + ! WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) + ! do i = 40, 42 + ! ib = (j - 1) * Land_IAU_Control%nx + i + ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + ! enddo + ! enddo + ! endif + + ! do ib = 1, ncols + ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp + ! enddo + + ! local variable to copy blocked data Land_IAU_Data%stc_inc + allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols + ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) + !copy background stc + + stc_updated = 0 + ib = 1 + do j = 1, Land_IAU_Control%ny !ny + do k = 1, km + stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%stc_inc(:,j, k) + ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) + enddo + ib = ib + Land_IAU_Control%nx !nlon + enddo + + ! delt=GFS_Control%dtf + if ((Land_IAU_Control%dtp - delt) > 0.0001) then + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "Warning noahmpdrv_run delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp + endif + endif + + lsoil_incr = Land_IAU_Control%lsoil_incr + lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny - + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,' adjusting first ', lsoil_incr, ' surface layers only, delt ', delt + ! initialize variables for counts statitics to be zeros + nother = 0 ! grid cells not land + nsnowupd = 0 ! grid cells with snow (temperature not yet updated) + nstcupd = 0 ! grid cells that are updated + nfrozen = 0 ! not update as frozen soil + nfrozen_upd = 0 ! not update as frozen soil -! ! delt=GFS_Control%dtf -! if ((Land_IAU_Control%dtp - delt) > 0.0001) then -! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then -! print*, "Warning noahmpdrv_run delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp -! endif -! endif - -! lsoil_incr = Land_IAU_Control%lsoil_incr -! lensfc = Land_IAU_Control%nx * Land_IAU_Control%ny - -! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*,' adjusting first ', lsoil_incr, ' surface layers only, delt ', delt -! ! initialize variables for counts statitics to be zeros -! nother = 0 ! grid cells not land -! nsnowupd = 0 ! grid cells with snow (temperature not yet updated) -! nstcupd = 0 ! grid cells that are updated -! nfrozen = 0 ! not update as frozen soil -! nfrozen_upd = 0 ! not update as frozen soil - -! !TODO---if only fv3 increment files are used, this can be read from file -! allocate(mask_tile(lensfc)) -! call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, - -! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then -! print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num -! ib = 1 -! do j = 1, Land_IAU_Control%ny !ny -! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) -! ib = ib + Land_IAU_Control%nx !nlon -! enddo -! print*, "root proc layer 1 inc" -! ib = 1 -! do j = 1, Land_IAU_Control%ny !ny -! WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt -! ib = ib + Land_IAU_Control%nx !nlon -! enddo -! endif - -! !IAU increments are in units of 1/sec !Land_IAU_Control%dtp -! !* only updating soil temp for now -! ij_loop : do ij = 1, lensfc -! ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land -! if (mask_tile(ij) == 1) then -! ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) -! soil_freeze=.false. -! soil_ice=.false. -! do k = 1, lsoil_incr ! k = 1, km -! if ( stc(ij,k) < tfreez) soil_freeze=.true. -! if ( smc(ij,k) - slc(ij,k) > 0.001 ) soil_ice=.true. - -! stc(ij,k) = stc(ij,k) + stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp - -! if (k==1) then -! stc_updated(ij) = 1 -! nstcupd = nstcupd + 1 -! endif -! if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) )& -! nfrozen_upd = nfrozen_upd + 1 -! ! moisture updates not done if this layer or any above is frozen -! if ( soil_freeze .or. soil_ice ) then -! if (k==1) nfrozen = nfrozen+1 -! endif -! enddo -! endif ! if soil/snow point -! enddo ij_loop -! ! do k = 1, km -! ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp -! ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp -! ! enddo -! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then -! print*, "root proc layer 1 stc after adding IAU inc" -! ib = 1 -! do j = 1, Land_IAU_Control%ny !ny -! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) -! ib = ib + Land_IAU_Control%nx !nlon -! enddo -! endif +!TODO---if only fv3 increment files are used, this can be read from file + allocate(mask_tile(lensfc)) + call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, -! deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num + ! ib = 1 + ! do j = 1, Land_IAU_Control%ny !ny + ! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) + ! ib = ib + Land_IAU_Control%nx !nlon + ! enddo + print*, "root proc layer 1 inc" + ! ib = 1 + ! do j = 1, Land_IAU_Control%ny !ny + ! WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt + ! ib = ib + Land_IAU_Control%nx !nlon + ! enddo + do j = 33, 35 + WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) + enddo + print*, "stc_inc_flat" + + do j = 33, 35 + ib = (j - 1) * Land_IAU_Control%nx + 40 + WRITE(*,"(3F15.12)") stc_inc_flat(ib:ib+2, 1) + enddo + endif + + !IAU increments are in units of 1/sec !Land_IAU_Control%dtp + !* only updating soil temp for now + ij_loop : do ij = 1, lensfc + ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land + if (mask_tile(ij) == 1) then + ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) + soil_freeze=.false. + soil_ice=.false. + do k = 1, lsoil_incr ! k = 1, km + if ( stc(ij,k) < tfreez) soil_freeze=.true. + if ( smc(ij,k) - slc(ij,k) > 0.001 ) soil_ice=.true. + + stc(ij,k) = stc(ij,k) + stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp + + if (k==1) then + stc_updated(ij) = 1 + nstcupd = nstcupd + 1 + endif + if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) )& + nfrozen_upd = nfrozen_upd + 1 + ! moisture updates not done if this layer or any above is frozen + if ( soil_freeze .or. soil_ice ) then + if (k==1) nfrozen = nfrozen+1 + endif + enddo + endif ! if soil/snow point + enddo ij_loop + ! do k = 1, km + ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp + ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp + ! enddo + ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + ! print*, "root proc layer 1 stc after adding IAU inc" + ! ib = 1 + ! do j = 1, Land_IAU_Control%ny !ny + ! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) + ! ib = ib + Land_IAU_Control%nx !nlon + ! enddo + ! endif + + deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) ! ! (consistency) adjustments for updated soil temp and moisture @@ -378,7 +390,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! ! maxsmc(1:slcats) = smcmax_table(1:slcats) ! ! bb(1:slcats) = bexp_table(1:slcats) ! ! satpsi(1:slcats) = psisat_table(1:slcats) - + ! if (errflg .ne. 0) then ! print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' ! errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' @@ -413,12 +425,12 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! print*, "proc ", Land_IAU_Control%me, " indices with large increment" ! print*, diff_indices ! print*, d_stc(diff_indices) - + ! deallocate(stc_bck, d_stc) ! if(allocated(diff_indices)) deallocate(diff_indices) ! deallocate(stc_updated) ! deallocate(mask_tile) - + ! write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me ! write(*,'(a,i8)') ' soil grid total', lensfc @@ -429,7 +441,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother ! write(*,'(a,i8)') ' soil grid cells with stc update', n_stc - endif + ! endif end subroutine noahmpdrv_timestep_init @@ -1059,8 +1071,6 @@ subroutine noahmpdrv_run & errmsg = '' errflg = 0 - stc(:, 4) = stc(:, 4) + 0.000001 - do i = 1, im if (flag_iter(i) .and. dry(i)) then From 7c4806b1fc4ec5bc65e8e48025239d285ddfb2fc Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 24 Jul 2024 10:52:12 -0400 Subject: [PATCH 088/154] remove hard-coded test --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index cc69dcc28..28158fc1f 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -127,7 +127,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me !logical :: land_iau_gaussian_inc_file = .false. integer :: lsoil_incr = 4 - NAMELIST /lnd_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & + NAMELIST /land_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & land_iau_filter_increments, & lsoil_incr @@ -141,7 +141,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=100886 allocate(input_nml_file, mold=input_nml_file_i) input_nml_file => input_nml_file_i - read(input_nml_file, nml=lnd_iau_nml) + read(input_nml_file, nml=land_iau_nml) ! Set length (number of lines) in namelist for internal reads input_nml_file_length = size(input_nml_file) #else @@ -157,7 +157,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%fn_nml = trim(fn_nml) ! maynot need this open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios, iomsg=ioerrmsg) rewind(nlunit) - read (nlunit, nml=lnd_iau_nml) + read (nlunit, nml=land_iau_nml) close (nlunit) if (ios /= 0) then ! call mpp_error(FATAL, 'lnd_iau_mod_set_control: error reading namelist file ',trim(fn_nml)) @@ -172,8 +172,8 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me #endif if (me == mpi_root) then - write(6,*) "lnd_iau_nml" - write(6, lnd_iau_nml) + write(6,*) "land_iau_nml" + write(6, land_iau_nml) endif Land_IAU_Control%do_land_iau = do_land_iau From 29cff05c6739468c37bfe96005909828c741dac5 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 24 Jul 2024 11:01:22 -0400 Subject: [PATCH 089/154] remove debug prints --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 153 +++++++++---------- 1 file changed, 76 insertions(+), 77 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index a6697effc..cd135fdba 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -188,8 +188,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat ! real(kind=kind_phys),allocatable, dimension(:) :: stc_bck, d_stc real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) - integer, allocatable, dimension(:) :: diff_indices - ! real,allocatable :: slc_inc_flat(:,:) + ! integer, allocatable, dimension(:) :: diff_indices + integer :: lsoil_incr ! integer :: veg_type_landice @@ -317,29 +317,29 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & allocate(mask_tile(lensfc)) call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num - ! ib = 1 - ! do j = 1, Land_IAU_Control%ny !ny - ! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) - ! ib = ib + Land_IAU_Control%nx !nlon - ! enddo - print*, "root proc layer 1 inc" - ! ib = 1 - ! do j = 1, Land_IAU_Control%ny !ny - ! WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt - ! ib = ib + Land_IAU_Control%nx !nlon - ! enddo - do j = 33, 35 - WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) - enddo - print*, "stc_inc_flat" + ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + ! print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num + ! ! ib = 1 + ! ! do j = 1, Land_IAU_Control%ny !ny + ! ! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) + ! ! ib = ib + Land_IAU_Control%nx !nlon + ! ! enddo + ! print*, "root proc layer 1 inc" + ! ! ib = 1 + ! ! do j = 1, Land_IAU_Control%ny !ny + ! ! WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt + ! ! ib = ib + Land_IAU_Control%nx !nlon + ! ! enddo + ! do j = 33, 35 + ! WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) + ! enddo + ! print*, "stc_inc_flat" - do j = 33, 35 - ib = (j - 1) * Land_IAU_Control%nx + 40 - WRITE(*,"(3F15.12)") stc_inc_flat(ib:ib+2, 1) - enddo - endif + ! do j = 33, 35 + ! ib = (j - 1) * Land_IAU_Control%nx + 40 + ! WRITE(*,"(3F15.12)") stc_inc_flat(ib:ib+2, 1) + ! enddo + ! endif !IAU increments are in units of 1/sec !Land_IAU_Control%dtp !* only updating soil temp for now @@ -383,65 +383,64 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) -! ! (consistency) adjustments for updated soil temp and moisture +! (consistency) adjustments for updated soil temp and moisture -! ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) -! call read_mp_table_parameters(errmsg, errflg) -! ! maxsmc(1:slcats) = smcmax_table(1:slcats) -! ! bb(1:slcats) = bexp_table(1:slcats) -! ! satpsi(1:slcats) = psisat_table(1:slcats) + ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) + call read_mp_table_parameters(errmsg, errflg) + ! maxsmc(1:slcats) = smcmax_table(1:slcats) + ! bb(1:slcats) = bexp_table(1:slcats) + ! satpsi(1:slcats) = psisat_table(1:slcats) -! if (errflg .ne. 0) then -! print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' -! errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' -! return -! endif -! n_stc = 0 -! do i=1,lensfc -! if (stc_updated(i) == 1 ) then ! soil-only location -! n_stc = n_stc+1 -! soiltype = soiltyp(i) -! do l = 1, lsoil_incr -! !case 1: frz ==> frz, recalculate slc, smc remains -! !case 2: unfrz ==> frz, recalculate slc, smc remains -! !both cases are considered in the following if case -! if (stc(i,l) .LT. tfreez )then -! !recompute supercool liquid water,smc_anl remain unchanged -! smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) -! slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) -! slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) -! endif -! !case 3: frz ==> unfrz, melt all soil ice (if any) -! if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck -! slc(i,l)=smc(i,l) -! endif -! enddo -! endif -! enddo - -! d_stc = stc(:, 1) - stc_bck -! ! Where(d_stc .gt. 0.0001) -! diff_indices = pack([(i, i=1, lensfc)], d_stc > 0.0001) -! print*, "proc ", Land_IAU_Control%me, " indices with large increment" -! print*, diff_indices -! print*, d_stc(diff_indices) + if (errflg .ne. 0) then + print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + return + endif + n_stc = 0 + do i=1,lensfc + if (stc_updated(i) == 1 ) then ! soil-only location + n_stc = n_stc+1 + soiltype = soiltyp(i) + do l = 1, lsoil_incr + !case 1: frz ==> frz, recalculate slc, smc remains + !case 2: unfrz ==> frz, recalculate slc, smc remains + !both cases are considered in the following if case + if (stc(i,l) .LT. tfreez )then + !recompute supercool liquid water,smc_anl remain unchanged + smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) + slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) + slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) + endif + !case 3: frz ==> unfrz, melt all soil ice (if any) + if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck + slc(i,l)=smc(i,l) + endif + enddo + endif + enddo + + ! d_stc = stc(:, 1) - stc_bck + ! ! Where(d_stc .gt. 0.0001) + ! diff_indices = pack([(i, i=1, lensfc)], d_stc > 0.0001) + ! print*, "proc ", Land_IAU_Control%me, " indices with large increment" + ! print*, diff_indices + ! print*, d_stc(diff_indices) -! deallocate(stc_bck, d_stc) -! if(allocated(diff_indices)) deallocate(diff_indices) -! deallocate(stc_updated) -! deallocate(mask_tile) + ! if(allocated(diff_indices)) deallocate(diff_indices) + + deallocate(stc_updated) + deallocate(mask_tile) -! write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me -! write(*,'(a,i8)') ' soil grid total', lensfc -! write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd -! write(*,'(a,i8)') ' soil grid cells not updated, frozen = ',nfrozen -! write(*,'(a,i8)') ' soil grid cells update, became frozen = ',nfrozen_upd -! write(*,'(a,i8)') ' (not updated yet) snow grid cells = ', nsnowupd -! write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother -! write(*,'(a,i8)') ' soil grid cells with stc update', n_stc + write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me + write(*,'(a,i8)') ' soil grid total', lensfc + write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd + write(*,'(a,i8)') ' soil grid cells not updated, frozen = ',nfrozen + write(*,'(a,i8)') ' soil grid cells update, became frozen = ',nfrozen_upd + write(*,'(a,i8)') ' (not updated yet) snow grid cells = ', nsnowupd + write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother + write(*,'(a,i8)') ' soil grid cells with stc update', n_stc - ! endif end subroutine noahmpdrv_timestep_init From 6530674d07c6b51cc9f5a0531d100759d3f9f6bb Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 31 Jul 2024 15:34:03 -0400 Subject: [PATCH 090/154] add stc update and adjustment --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 9 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 97 ++++++++++++++----- 2 files changed, 82 insertions(+), 24 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 28158fc1f..8ccb26592 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -72,6 +72,8 @@ module land_iau_mod real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files logical :: iau_filter_increments integer :: lsoil_incr ! soil layers (from top) updated by DA + logical :: upd_stc + logical :: upd_slc !, iau_drymassfixer integer :: me !< MPI rank designator integer :: mpi_root !< MPI rank of master atmosphere processor @@ -126,10 +128,12 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me logical :: land_iau_filter_increments = .false. !< filter IAU increments !logical :: land_iau_gaussian_inc_file = .false. integer :: lsoil_incr = 4 + logical :: upd_stc = .false. + logical :: upd_slc = .false. NAMELIST /land_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & land_iau_filter_increments, & - lsoil_incr + lsoil_incr, upd_stc, upd_slc !Errors messages handled through CCPP error handling variables errmsg = '' @@ -199,6 +203,9 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%input_nml_file = input_nml_file Land_IAU_Control%input_nml_file_length = input_nml_file_length + Land_IAU_Control%upd_stc = upd_stc + Land_IAU_Control%upd_slc = upd_slc + allocate(Land_IAU_Control%blksz(nblks)) allocate(Land_IAU_Control%blk_strt_indx(nblks)) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index cd135fdba..9c01baf5c 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -185,19 +185,23 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & integer, intent(out) :: errflg ! IAU update - real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat + real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat, slc_inc_flat ! real(kind=kind_phys),allocatable, dimension(:) :: stc_bck, d_stc real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) ! integer, allocatable, dimension(:) :: diff_indices + real(kind=kind_phys), dimension(km) :: dz ! layer thickness + +!TODO: 7.31.24: This is hard-coded in noahmpdrv + real(kind=kind_phys) :: zsoil(4) = (/ -0.1, -0.4, -1.0, -2.0 /) !zsoil(km) integer :: lsoil_incr ! integer :: veg_type_landice integer, allocatable :: mask_tile(:) - integer,allocatable :: stc_updated(:) + integer,allocatable :: stc_updated(:), slc_updated(:) logical :: soil_freeze, soil_ice integer :: n_freeze, n_thaw - integer :: soiltype, n_stc + integer :: soiltype, n_stc, n_slc real(kind=kind_phys) :: slc_new integer :: i, j, ij, l, k, ib @@ -213,7 +217,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & real(kind=kind_phys) :: hc_incr integer :: nother, nsnowupd - integer :: nstcupd, nfrozen, nfrozen_upd + integer :: nstcupd, nslcupd, nfrozen, nfrozen_upd ! --- Initialize CCPP error handling variables errmsg = '' @@ -281,16 +285,18 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! local variable to copy blocked data Land_IAU_Data%stc_inc allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols - ! allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols + allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) + allocate(slc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) !copy background stc stc_updated = 0 + slc_updated = 0 ib = 1 do j = 1, Land_IAU_Control%ny !ny do k = 1, km stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%stc_inc(:,j, k) - ! slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) + slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) enddo ib = ib + Land_IAU_Control%nx !nlon enddo @@ -309,7 +315,8 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! initialize variables for counts statitics to be zeros nother = 0 ! grid cells not land nsnowupd = 0 ! grid cells with snow (temperature not yet updated) - nstcupd = 0 ! grid cells that are updated + nstcupd = 0 ! grid cells that are updated stc + nslcupd = 0 ! grid cells that are updated slc nfrozen = 0 ! not update as frozen soil nfrozen_upd = 0 ! not update as frozen soil @@ -353,21 +360,40 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & if ( stc(ij,k) < tfreez) soil_freeze=.true. if ( smc(ij,k) - slc(ij,k) > 0.001 ) soil_ice=.true. - stc(ij,k) = stc(ij,k) + stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp - - if (k==1) then - stc_updated(ij) = 1 - nstcupd = nstcupd + 1 + if (Land_IAU_Control%upd_stc) then + stc(ij,k) = stc(ij,k) + stc_inc_flat(ij,k)*delt !Land_IAU_Control%dtp + if (k==1) then + stc_updated(ij) = 1 + nstcupd = nstcupd + 1 + endif endif - if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) )& - nfrozen_upd = nfrozen_upd + 1 - ! moisture updates not done if this layer or any above is frozen - if ( soil_freeze .or. soil_ice ) then + + if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) ) nfrozen_upd = nfrozen_upd + 1 + + ! do not do updates if this layer or any above is frozen + if ( (.not. soil_freeze ) .and. (.not. soil_ice ) ) then + if (Land_IAU_Control%upd_slc) then + if (k==1) then + nslcupd = nslcupd + 1 + slc_updated(ij) = 1 + endif + ! apply zero limit here (higher, model-specific limits are later) + slc(ij,k) = max(slc(ij,k) + slc_inc_flat(ij,k)*delt, 0.0) + smc(ij,k) = max(smc(ij,k) + slc_inc_flat(ij,k)*delt, 0.0) + ! slc_state(ij,k) = max(slc_state(ij,k) + slcinc(ij,k), 0.0) + ! smc_state(ij,k) = max(smc_state(ij,k) + slcinc(ij,k), 0.0) + endif + else if (k==1) nfrozen = nfrozen+1 - endif + ! ! moisture updates not done if this layer or any above is frozen + ! if ( soil_freeze .or. soil_ice ) then + ! if (k==1) nfrozen = nfrozen+1 + ! endif + endif enddo endif ! if soil/snow point enddo ij_loop + ! do k = 1, km ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp @@ -381,7 +407,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! enddo ! endif - deallocate(stc_inc_flat) !, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) ! (consistency) adjustments for updated soil temp and moisture @@ -389,14 +415,16 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & call read_mp_table_parameters(errmsg, errflg) ! maxsmc(1:slcats) = smcmax_table(1:slcats) ! bb(1:slcats) = bexp_table(1:slcats) - ! satpsi(1:slcats) = psisat_table(1:slcats) - + ! satpsi(1:slcats) = psisat_table(1:slcats) if (errflg .ne. 0) then print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' return endif - n_stc = 0 + + n_stc = 0 + n_slc = 0 + if (Land_IAU_Control%upd_stc) then do i=1,lensfc if (stc_updated(i) == 1 ) then ! soil-only location n_stc = n_stc+1 @@ -418,6 +446,27 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & enddo endif enddo + endif + + if (Land_IAU_Control%upd_slc) then + dz(1) = -zsoil(1) + do l = 2, km + dz(l) = -zsoil(l) + zsoil(l-1) + enddo + ! print *, 'Applying soil moisture mins ' + do i=1,lensfc + if (slc_updated(i) == 1 ) then + n_slc = n_slc+1 + ! apply SM bounds (later: add upper SMC limit) + do l = 1, lsoil_incr + ! noah-mp minimum is 1 mm per layer (in SMC) + ! no need to maintain frozen amount, would be v. small. + slc(i,l) = max( 0.001/dz(l), slc(i,l) ) + smc(i,l) = max( 0.001/dz(l), smc(i,l) ) + enddo + endif + enddo + endif ! d_stc = stc(:, 1) - stc_bck ! ! Where(d_stc .gt. 0.0001) @@ -428,18 +477,20 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! if(allocated(diff_indices)) deallocate(diff_indices) - deallocate(stc_updated) + deallocate(stc_updated, slc_updated) deallocate(mask_tile) write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me write(*,'(a,i8)') ' soil grid total', lensfc write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd + write(*,'(a,i8)') ' soil grid cells slc updated = ',nslcupd write(*,'(a,i8)') ' soil grid cells not updated, frozen = ',nfrozen write(*,'(a,i8)') ' soil grid cells update, became frozen = ',nfrozen_upd write(*,'(a,i8)') ' (not updated yet) snow grid cells = ', nsnowupd write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother - write(*,'(a,i8)') ' soil grid cells with stc update', n_stc + write(*,'(a,i8)') ' soil grid cells with stc adjustment', n_stc + write(*,'(a,i8)') ' soil grid cells with slc adjustment', n_slc end subroutine noahmpdrv_timestep_init From 0b41c39f3f0516cfdbad8b7eb5b14938d7fd232b Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 31 Jul 2024 16:16:47 -0400 Subject: [PATCH 091/154] add stc update and adjustment --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 8ccb26592..89df0cdd1 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -128,12 +128,12 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me logical :: land_iau_filter_increments = .false. !< filter IAU increments !logical :: land_iau_gaussian_inc_file = .false. integer :: lsoil_incr = 4 - logical :: upd_stc = .false. - logical :: upd_slc = .false. + logical :: land_iau_upd_stc = .false. + logical :: land_iau_upd_slc = .false. NAMELIST /land_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & land_iau_filter_increments, & - lsoil_incr, upd_stc, upd_slc + lsoil_incr, land_iau_upd_stc, land_iau_upd_slc !Errors messages handled through CCPP error handling variables errmsg = '' @@ -203,8 +203,8 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%input_nml_file = input_nml_file Land_IAU_Control%input_nml_file_length = input_nml_file_length - Land_IAU_Control%upd_stc = upd_stc - Land_IAU_Control%upd_slc = upd_slc + Land_IAU_Control%upd_stc = land_iau_upd_stc + Land_IAU_Control%upd_slc = land_iau_upd_slc allocate(Land_IAU_Control%blksz(nblks)) allocate(Land_IAU_Control%blk_strt_indx(nblks)) From 0de64dde5e1b61585abb0aa88c47c506cb27547a Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 5 Aug 2024 12:55:41 -0400 Subject: [PATCH 092/154] zero out too small increments --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 89df0cdd1..f475e08b4 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -74,6 +74,7 @@ module land_iau_mod integer :: lsoil_incr ! soil layers (from top) updated by DA logical :: upd_stc logical :: upd_slc + real(kind=kind_phys) :: min_T_increment !, iau_drymassfixer integer :: me !< MPI rank designator integer :: mpi_root !< MPI rank of master atmosphere processor @@ -130,10 +131,11 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me integer :: lsoil_incr = 4 logical :: land_iau_upd_stc = .false. logical :: land_iau_upd_slc = .false. + real(kind=kind_phys) :: land_iau_min_T_increment = 0.0001 NAMELIST /land_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & land_iau_filter_increments, & - lsoil_incr, land_iau_upd_stc, land_iau_upd_slc + lsoil_incr, land_iau_upd_stc, land_iau_upd_slc, land_iau_min_T_increment !Errors messages handled through CCPP error handling variables errmsg = '' @@ -205,6 +207,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%upd_stc = land_iau_upd_stc Land_IAU_Control%upd_slc = land_iau_upd_slc + Land_IAU_Control%min_T_increment = land_iau_min_T_increment allocate(Land_IAU_Control%blksz(nblks)) allocate(Land_IAU_Control%blk_strt_indx(nblks)) @@ -681,6 +684,9 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou status =nf90_close(ncid) call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) + !8.3.24 ensure to zero out too small increments + where(wk3_stc < Land_IAU_Control%min_T_increment) wk3_stc = 0.0 + end subroutine read_iau_forcing_fv3 !> Calculate soil mask for land on model grid. From a6381f32153c02f1d61a9315c00d5fab9fec7174 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 6 Aug 2024 15:10:19 -0400 Subject: [PATCH 093/154] zero out too small increments --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index f475e08b4..3044b7dc3 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -685,7 +685,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) !8.3.24 ensure to zero out too small increments - where(wk3_stc < Land_IAU_Control%min_T_increment) wk3_stc = 0.0 + where(abs(wk3_stc) < Land_IAU_Control%min_T_increment) wk3_stc = 0.0 end subroutine read_iau_forcing_fv3 From 4a953f330a08429abead665b3297dddcb403259b Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 8 Aug 2024 17:11:09 -0400 Subject: [PATCH 094/154] add comment for single increment --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 3044b7dc3..bdb320d91 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -314,7 +314,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) return endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,"increment file ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) + print *,"land_iau_init: Increment file ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) endif ! determine number of valid forecast hours @@ -328,7 +328,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) endif ntimes = ntimes + 1 enddo - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'ntimes = ',ntimes + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau_init: ntimes = ',ntimes Land_IAU_Control%ntimes = ntimes if (ntimes < 1) then return @@ -684,7 +684,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_ou status =nf90_close(ncid) call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) - !8.3.24 ensure to zero out too small increments + !8.3.24 set too small increments to zero where(abs(wk3_stc) < Land_IAU_Control%min_T_increment) wk3_stc = 0.0 end subroutine read_iau_forcing_fv3 From 7319badd81c9f86efe6877807daf558b1faf4d47 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 8 Aug 2024 19:17:10 -0400 Subject: [PATCH 095/154] include t2 in update iau call --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index bdb320d91..3e81eee97 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -464,9 +464,10 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e endif if (ntimes.EQ.1) then - ! check to see if we are in the IAU window, - ! no need to update the states since they are fixed over the window - if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then + ! check to see if we are in the IAU window, no need to update the states since they are fixed over the window +!8.8.24 TBCL: noahmpdrv_timestep_init doesn't get visited at t1, so include t2 + ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then + if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 Land_IAU_Data%in_interval=.false. else @@ -479,7 +480,9 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e if (ntimes > 1) then itnext=2 - if (Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2) then +!8.8.24 TBCL: noahmpdrv_timestep_init doesn't get visited at t1, so include t2 + ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then + if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',Land_IAU_Control%iaufhrs(1),Land_IAU_Control%fhour,Land_IAU_Control%iaufhrs(nfiles) Land_IAU_Data%in_interval=.false. else From f5607ade7b357492e94237a8e934e6eb228b80a7 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sat, 10 Aug 2024 09:52:32 -0400 Subject: [PATCH 096/154] set hr6 the only incr file (for testing) --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 3e81eee97..12db20f16 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -361,8 +361,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) do k = 1, npz ! do k = 1,n_soill ! do j = 1, nlat do i = 1, nlon - Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(1, i, j, k) - Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(1, i, j, k) + Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(2, i, j, k) + Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(2, i, j, k) end do enddo enddo @@ -464,7 +464,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e endif if (ntimes.EQ.1) then - ! check to see if we are in the IAU window, no need to update the states since they are fixed over the window + ! check to see if we are in the IAU window, no need to update the states since they are fixed over the window !8.8.24 TBCL: noahmpdrv_timestep_init doesn't get visited at t1, so include t2 ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then From d0c2cac8d3bf99a638a5d3a7628ebf98ed93981b Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 14 Aug 2024 07:06:30 -0400 Subject: [PATCH 097/154] add increments at timestep_finalize (for testing) --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 4 ++-- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 8 ++++---- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 12db20f16..ebdc72aba 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -361,8 +361,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) do k = 1, npz ! do k = 1,n_soill ! do j = 1, nlat do i = 1, nlon - Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(2, i, j, k) - Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(2, i, j, k) + Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(1, i, j, k) + Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(1, i, j, k) end do enddo enddo diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 9c01baf5c..635af3907 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -155,7 +155,7 @@ end subroutine noahmpdrv_init !! Note: For Case 3, Yuan Xue thoroughly evaluated a total of four options and !! current option is found to be the best as of 11/09/2023 -subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !me, mpi_root, +subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, & !me, mpi_root, isot, ivegsrc, soiltyp, vegtype, weasd, & stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, @@ -493,7 +493,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & write(*,'(a,i8)') ' soil grid cells with slc adjustment', n_slc -end subroutine noahmpdrv_timestep_init +end subroutine noahmpdrv_timestep_finalize !> \ingroup NoahMP_LSM !! \brief This subroutine is called after noahmpdrv_run @@ -502,7 +502,7 @@ end subroutine noahmpdrv_timestep_init !! \section arg_table_noahmpdrv_timestep_finalize Argument Table !! \htmlinclude noahmpdrv_timestep_finalize.html !! - subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, + subroutine noahmpdrv_timestep_init (errmsg, errflg) ! smc, t2mmp, q2mp, use machine, only: kind_phys implicit none @@ -514,7 +514,7 @@ subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp !> note the IAU deallocate happens at the noahmpdrv_finalize - end subroutine noahmpdrv_timestep_finalize + end subroutine noahmpdrv_timestep_init !> \ingroup NoahMP_LSM !! \brief This subroutine mirrors noahmpdrv_init diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 892894329..414f03f02 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -225,7 +225,7 @@ ######################################################################## [ccpp-arg-table] - name = noahmpdrv_timestep_init + name = noahmpdrv_timestep_finalize type = scheme [itime] standard_name = index_of_timestep @@ -342,7 +342,7 @@ ####################################################################### [ccpp-arg-table] - name = noahmpdrv_timestep_finalize + name = noahmpdrv_timestep_init type = scheme [errmsg] standard_name = ccpp_error_message From b79c7e603e8873d7b39a2e070fdfa7aeb9121de5 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 14 Aug 2024 19:32:54 -0400 Subject: [PATCH 098/154] add sec argtable --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 635af3907..3510fa853 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -144,9 +144,10 @@ end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called before noahmpdrv_run !! to update states with iau increments, if available -!! \section arg_table_noahmpdrv_timestep_init Argument Table -!! \htmlinclude noahmpdrv_timestep_init.html -!! + +!! \section arg_table_noahmpdrv_timestep_finalize Argument Table +!! \htmlinclude noahmpdrv_timestep_finalize.html + !! For Noah-MP, the adjustment scheme shown below is applied to soil moisture and temp: !! Case 1: frozen ==> frozen, recalculate slc following opt_frz=1, smc remains !! Case 2: unfrozen ==> frozen, recalculate slc following opt_frz=1, smc remains @@ -499,8 +500,9 @@ end subroutine noahmpdrv_timestep_finalize !! \brief This subroutine is called after noahmpdrv_run !! to free up allocated memory, if there are any !! code to do any needed consistency check will go here -!! \section arg_table_noahmpdrv_timestep_finalize Argument Table -!! \htmlinclude noahmpdrv_timestep_finalize.html + +!! \section arg_table_noahmpdrv_timestep_init Argument Table +!! \htmlinclude noahmpdrv_timestep_init.html !! subroutine noahmpdrv_timestep_init (errmsg, errflg) ! smc, t2mmp, q2mp, From 4398a956d69506e71d03b5d7aa54101bc90c01a9 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 14 Aug 2024 22:37:37 -0400 Subject: [PATCH 099/154] fix argtable --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 3510fa853..dbaa7e8d3 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -143,11 +143,10 @@ end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called before noahmpdrv_run -!! to update states with iau increments, if available - +!! to update states with iau increments, if available--- !! \section arg_table_noahmpdrv_timestep_finalize Argument Table !! \htmlinclude noahmpdrv_timestep_finalize.html - +!! !! For Noah-MP, the adjustment scheme shown below is applied to soil moisture and temp: !! Case 1: frozen ==> frozen, recalculate slc following opt_frz=1, smc remains !! Case 2: unfrozen ==> frozen, recalculate slc following opt_frz=1, smc remains @@ -499,8 +498,7 @@ end subroutine noahmpdrv_timestep_finalize !> \ingroup NoahMP_LSM !! \brief This subroutine is called after noahmpdrv_run !! to free up allocated memory, if there are any -!! code to do any needed consistency check will go here - +!! code to do any needed consistency check will go here-- !! \section arg_table_noahmpdrv_timestep_init Argument Table !! \htmlinclude noahmpdrv_timestep_init.html !! From 4d244ea2fa768674bb137018964e811e01ff82a7 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 16 Aug 2024 18:07:44 -0400 Subject: [PATCH 100/154] input line in namelist for stcsmc adjustment --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 5 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 103 +++++++++--------- 2 files changed, 57 insertions(+), 51 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index ebdc72aba..afa88d45b 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -74,6 +74,7 @@ module land_iau_mod integer :: lsoil_incr ! soil layers (from top) updated by DA logical :: upd_stc logical :: upd_slc + logical :: do_stcsmc_adjustment !do moisture/temperature adjustment for consistency after increment add real(kind=kind_phys) :: min_T_increment !, iau_drymassfixer integer :: me !< MPI rank designator @@ -131,11 +132,12 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me integer :: lsoil_incr = 4 logical :: land_iau_upd_stc = .false. logical :: land_iau_upd_slc = .false. + logical :: land_iau_do_stcsmc_adjustment = .false. real(kind=kind_phys) :: land_iau_min_T_increment = 0.0001 NAMELIST /land_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & land_iau_filter_increments, & - lsoil_incr, land_iau_upd_stc, land_iau_upd_slc, land_iau_min_T_increment + lsoil_incr, land_iau_upd_stc, land_iau_upd_slc, land_iau_do_stcsmc_adjustment, land_iau_min_T_increment !Errors messages handled through CCPP error handling variables errmsg = '' @@ -207,6 +209,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%upd_stc = land_iau_upd_stc Land_IAU_Control%upd_slc = land_iau_upd_slc + Land_IAU_Control%do_stcsmc_adjustment = land_iau_do_stcsmc_adjustment Land_IAU_Control%min_T_increment = land_iau_min_T_increment allocate(Land_IAU_Control%blksz(nblks)) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index dbaa7e8d3..ccd08ef81 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -411,61 +411,64 @@ subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, ! (consistency) adjustments for updated soil temp and moisture - ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) - call read_mp_table_parameters(errmsg, errflg) - ! maxsmc(1:slcats) = smcmax_table(1:slcats) - ! bb(1:slcats) = bexp_table(1:slcats) - ! satpsi(1:slcats) = psisat_table(1:slcats) - if (errflg .ne. 0) then - print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' - errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' - return - endif + ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) + call read_mp_table_parameters(errmsg, errflg) + ! maxsmc(1:slcats) = smcmax_table(1:slcats) + ! bb(1:slcats) = bexp_table(1:slcats) + ! satpsi(1:slcats) = psisat_table(1:slcats) + if (errflg .ne. 0) then + print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' + return + endif n_stc = 0 n_slc = 0 - if (Land_IAU_Control%upd_stc) then - do i=1,lensfc - if (stc_updated(i) == 1 ) then ! soil-only location - n_stc = n_stc+1 - soiltype = soiltyp(i) + !!do moisture/temperature adjustment for consistency after increment add + if (Land_IAU_Control%do_stcsmc_adjustment) then + if (Land_IAU_Control%upd_stc) then + do i=1,lensfc + if (stc_updated(i) == 1 ) then ! soil-only location + n_stc = n_stc+1 + soiltype = soiltyp(i) + do l = 1, lsoil_incr + !case 1: frz ==> frz, recalculate slc, smc remains + !case 2: unfrz ==> frz, recalculate slc, smc remains + !both cases are considered in the following if case + if (stc(i,l) .LT. tfreez )then + !recompute supercool liquid water,smc_anl remain unchanged + smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) + slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) + slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) + endif + !case 3: frz ==> unfrz, melt all soil ice (if any) + if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck + slc(i,l)=smc(i,l) + endif + enddo + endif + enddo + endif + + if (Land_IAU_Control%upd_slc) then + dz(1) = -zsoil(1) + do l = 2, km + dz(l) = -zsoil(l) + zsoil(l-1) + enddo + ! print *, 'Applying soil moisture mins ' + do i=1,lensfc + if (slc_updated(i) == 1 ) then + n_slc = n_slc+1 + ! apply SM bounds (later: add upper SMC limit) do l = 1, lsoil_incr - !case 1: frz ==> frz, recalculate slc, smc remains - !case 2: unfrz ==> frz, recalculate slc, smc remains - !both cases are considered in the following if case - if (stc(i,l) .LT. tfreez )then - !recompute supercool liquid water,smc_anl remain unchanged - smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) - slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) - slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) - endif - !case 3: frz ==> unfrz, melt all soil ice (if any) - if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck - slc(i,l)=smc(i,l) - endif + ! noah-mp minimum is 1 mm per layer (in SMC) + ! no need to maintain frozen amount, would be v. small. + slc(i,l) = max( 0.001/dz(l), slc(i,l) ) + smc(i,l) = max( 0.001/dz(l), smc(i,l) ) enddo - endif - enddo - endif - - if (Land_IAU_Control%upd_slc) then - dz(1) = -zsoil(1) - do l = 2, km - dz(l) = -zsoil(l) + zsoil(l-1) - enddo - ! print *, 'Applying soil moisture mins ' - do i=1,lensfc - if (slc_updated(i) == 1 ) then - n_slc = n_slc+1 - ! apply SM bounds (later: add upper SMC limit) - do l = 1, lsoil_incr - ! noah-mp minimum is 1 mm per layer (in SMC) - ! no need to maintain frozen amount, would be v. small. - slc(i,l) = max( 0.001/dz(l), slc(i,l) ) - smc(i,l) = max( 0.001/dz(l), smc(i,l) ) - enddo - endif - enddo + endif + enddo + endif endif ! d_stc = stc(:, 1) - stc_bck From 1cbaea47f97c2b92b71376b3bfc1b17e94f618ac Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 20 Aug 2024 12:56:55 -0400 Subject: [PATCH 101/154] clean up --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 90 +++---------------- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 4 +- 3 files changed, 14 insertions(+), 82 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index afa88d45b..4be782033 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -11,7 +11,7 @@ !> - reads settings from namelist file (which indicates if IAU increments are available or not) !> - reads in DA increments from GSI/JEDI DA at the start of (the DA) cycle !> - maps increments to FV3 grid points belonging to mpi process -!> - interpolates temporally (with filter, weights if required by configuration) +!> - interpolates temporally (with filter-weights if required by configuration) !> - updates states with the interpolated increments !> March, 2024: Tseganeh Z. Gichamo, (EMC) based on the FV3 IAU mod diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index ccd08ef81..3dcdf01e5 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -144,8 +144,8 @@ end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called before noahmpdrv_run !! to update states with iau increments, if available--- -!! \section arg_table_noahmpdrv_timestep_finalize Argument Table -!! \htmlinclude noahmpdrv_timestep_finalize.html +!! \section arg_table_noahmpdrv_timestep_init Argument Table +!! \htmlinclude noahmpdrv_timestep_init.html !! !! For Noah-MP, the adjustment scheme shown below is applied to soil moisture and temp: !! Case 1: frozen ==> frozen, recalculate slc following opt_frz=1, smc remains @@ -155,7 +155,7 @@ end subroutine noahmpdrv_init !! Note: For Case 3, Yuan Xue thoroughly evaluated a total of four options and !! current option is found to be the best as of 11/09/2023 -subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, & !me, mpi_root, +subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !me, mpi_root, isot, ivegsrc, soiltyp, vegtype, weasd, & stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, @@ -186,11 +186,10 @@ subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, ! IAU update real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat, slc_inc_flat - ! real(kind=kind_phys),allocatable, dimension(:) :: stc_bck, d_stc - real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) - ! integer, allocatable, dimension(:) :: diff_indices real(kind=kind_phys), dimension(km) :: dz ! layer thickness - + ! real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) + ! integer, allocatable, dimension(:) :: diff_indices + !TODO: 7.31.24: This is hard-coded in noahmpdrv real(kind=kind_phys) :: zsoil(4) = (/ -0.1, -0.4, -1.0, -2.0 /) !zsoil(km) @@ -262,27 +261,6 @@ subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, return endif - stc_bck = stc - - ! hc_incr = 0.0 !0.9 * 4.6296296296296296296296296296296e-5 * delt !0.05 - - ! if(Land_IAU_Control%tile_num == 1) then - ! print*, "stc_bck shape, min, max ", shape(stc_bck), minval(stc_bck), maxval(stc_bck) - ! print*, " hc_incr ", hc_incr - ! print*, "proc, tile num, layer 1 stc_inc at 33:35,40:42", Land_IAU_Control%me, Land_IAU_Control%tile_num - ! do j = 33, 35 - ! WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) - ! do i = 40, 42 - ! ib = (j - 1) * Land_IAU_Control%nx + i - ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp - ! enddo - ! enddo - ! endif - - ! do ib = 1, ncols - ! stc(ib, 1) = stc_bck(ib, 1) + hc_incr !Land_IAU_Data%stc_inc(i,j,1)*delt !Land_IAU_Control%dtp - ! enddo - ! local variable to copy blocked data Land_IAU_Data%stc_inc allocate(stc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols @@ -323,30 +301,6 @@ subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, !TODO---if only fv3 increment files are used, this can be read from file allocate(mask_tile(lensfc)) call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, - - ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - ! print*, "root proc, tile num, layer 1 stc", Land_IAU_Control%me, Land_IAU_Control%tile_num - ! ! ib = 1 - ! ! do j = 1, Land_IAU_Control%ny !ny - ! ! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) - ! ! ib = ib + Land_IAU_Control%nx !nlon - ! ! enddo - ! print*, "root proc layer 1 inc" - ! ! ib = 1 - ! ! do j = 1, Land_IAU_Control%ny !ny - ! ! WRITE(*,"(48F6.3)") stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, 1)*delt - ! ! ib = ib + Land_IAU_Control%nx !nlon - ! ! enddo - ! do j = 33, 35 - ! WRITE(*,"(3F15.12)") Land_IAU_Data%stc_inc(40:42,j,1) - ! enddo - ! print*, "stc_inc_flat" - - ! do j = 33, 35 - ! ib = (j - 1) * Land_IAU_Control%nx + 40 - ! WRITE(*,"(3F15.12)") stc_inc_flat(ib:ib+2, 1) - ! enddo - ! endif !IAU increments are in units of 1/sec !Land_IAU_Control%dtp !* only updating soil temp for now @@ -394,19 +348,6 @@ subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, endif ! if soil/snow point enddo ij_loop - ! do k = 1, km - ! stc(:,k) = stc(:,k) + stc_inc_flat(:,k)*delt !Land_IAU_Control%dtp - ! ! slc(:,k) = slc(:,k) + slc_inc_flat(:,k)*delt !Land_IAU_Control%dtp - ! enddo - ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - ! print*, "root proc layer 1 stc after adding IAU inc" - ! ib = 1 - ! do j = 1, Land_IAU_Control%ny !ny - ! WRITE(*,"(48F8.3)") stc(ib:ib+Land_IAU_Control%nx-1, 1) - ! ib = ib + Land_IAU_Control%nx !nlon - ! enddo - ! endif - deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) ! (consistency) adjustments for updated soil temp and moisture @@ -471,15 +412,6 @@ subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, endif endif - ! d_stc = stc(:, 1) - stc_bck - ! ! Where(d_stc .gt. 0.0001) - ! diff_indices = pack([(i, i=1, lensfc)], d_stc > 0.0001) - ! print*, "proc ", Land_IAU_Control%me, " indices with large increment" - ! print*, diff_indices - ! print*, d_stc(diff_indices) - - ! if(allocated(diff_indices)) deallocate(diff_indices) - deallocate(stc_updated, slc_updated) deallocate(mask_tile) @@ -496,16 +428,16 @@ subroutine noahmpdrv_timestep_finalize (itime, fhour, delt, km, ncols, write(*,'(a,i8)') ' soil grid cells with slc adjustment', n_slc -end subroutine noahmpdrv_timestep_finalize +end subroutine noahmpdrv_timestep_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called after noahmpdrv_run !! to free up allocated memory, if there are any !! code to do any needed consistency check will go here-- -!! \section arg_table_noahmpdrv_timestep_init Argument Table -!! \htmlinclude noahmpdrv_timestep_init.html +!! \section arg_table_noahmpdrv_timestep_finalize Argument Table +!! \htmlinclude noahmpdrv_timestep_finalize.html !! - subroutine noahmpdrv_timestep_init (errmsg, errflg) ! smc, t2mmp, q2mp, + subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, use machine, only: kind_phys implicit none @@ -517,7 +449,7 @@ subroutine noahmpdrv_timestep_init (errmsg, errflg) ! smc, t2mmp, q2mp, !> note the IAU deallocate happens at the noahmpdrv_finalize - end subroutine noahmpdrv_timestep_init + end subroutine noahmpdrv_timestep_finalize !> \ingroup NoahMP_LSM !! \brief This subroutine mirrors noahmpdrv_init diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 414f03f02..892894329 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -225,7 +225,7 @@ ######################################################################## [ccpp-arg-table] - name = noahmpdrv_timestep_finalize + name = noahmpdrv_timestep_init type = scheme [itime] standard_name = index_of_timestep @@ -342,7 +342,7 @@ ####################################################################### [ccpp-arg-table] - name = noahmpdrv_timestep_init + name = noahmpdrv_timestep_finalize type = scheme [errmsg] standard_name = ccpp_error_message From 812aefbbf20922de42b32ba665cf7367e666c52f Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 28 Aug 2024 19:46:22 -0400 Subject: [PATCH 102/154] fix missing error code initialization --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 4be782033..4f3e013e5 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -400,6 +400,10 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + if (allocated (wk3_stc)) deallocate (wk3_stc) if (allocated (wk3_slc)) deallocate (wk3_slc) if (allocated (wk3_slmsk)) deallocate (wk3_slmsk) @@ -427,6 +431,10 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e integer n,i,j,k,kstep,nstep,itnext integer :: ntimes + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ntimes = Land_IAU_Control%ntimes Land_IAU_Data%in_interval=.false. From 9b3dccdd0d73af70da9e40205deec5f8b5eadd0a Mon Sep 17 00:00:00 2001 From: tsga Date: Wed, 4 Sep 2024 02:56:27 +0000 Subject: [PATCH 103/154] remove namelist filename from iau struct --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 4f3e013e5..565dc395d 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -82,9 +82,9 @@ module land_iau_mod character(len=64) :: fn_nml !< namelist filename for surface data cycling real(kind=kind_phys) :: dtp !< physics timestep in seconds real(kind=kind_phys) :: fhour !< current forecast hour - character(len=:), pointer, dimension(:) :: input_nml_file => null() ! null() ! Date: Fri, 13 Sep 2024 07:56:53 +0000 Subject: [PATCH 104/154] use defaults when lnd_iau_nml doesn't exist --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 24 ++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 565dc395d..6047fcaf0 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -119,7 +119,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me !character(len=32) :: fn_nml = "input.nml" character(len=:), pointer, dimension(:) :: input_nml_file => null() integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads - + character(len=4) :: iosstr !> these are not available through the CCPP interface so need to read them from namelist file !> vars to read from namelist @@ -149,7 +149,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=100886 allocate(input_nml_file, mold=input_nml_file_i) input_nml_file => input_nml_file_i - read(input_nml_file, nml=land_iau_nml) + read(input_nml_file, nml=land_iau_nml, ERR=888, END=999, iostat=ios) ! Set length (number of lines) in namelist for internal reads input_nml_file_length = size(input_nml_file) #else @@ -165,7 +165,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%fn_nml = trim(fn_nml) ! maynot need this open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios, iomsg=ioerrmsg) rewind(nlunit) - read (nlunit, nml=land_iau_nml) + read (nlunit, nml=land_iau_nml, ERR=888, END=999, iostat=ios) close (nlunit) if (ios /= 0) then ! call mpp_error(FATAL, 'lnd_iau_mod_set_control: error reading namelist file ',trim(fn_nml)) @@ -178,6 +178,24 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me end if endif #endif + +888 if (ios /= 0) then ! .and. ios /= iostat_end) then + write(iosstr, '(I0)') ios + if (me == mpi_root) then + write(6,*) 'lnd_iau_mod_set_control: I/O error code '//trim(iosstr)//' at land_iau namelist read' + endif + errmsg = 'lnd_iau_mod_set_control: I/O error code '//trim(iosstr)//' at land_iau namelist read' + errflg = 1 + return + end if + +999 if (ios /= 0) then ! ios .eq. iostat_end) then + write(iosstr, '(I0)') ios + if (me == mpi_root) then + WRITE(6, * ) 'lnd_iau_mod_set_control: Warning! EoF ('//trim(iosstr)//') while reading land_iau namelist,' & + // ' likely because land_iau_nml was not found in input.nml. It will be set to default.' + endif + endif if (me == mpi_root) then write(6,*) "land_iau_nml" From 105eca11a6cf2a92a47f57b77ac7446de5bcf786 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Mon, 23 Sep 2024 00:35:22 -0600 Subject: [PATCH 105/154] Update noahmpdrv.F90 remove empty subroutine noahmpdrv_timestep_finalize --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 23 +------------------- 1 file changed, 1 insertion(+), 22 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index bfe3ebfcc..4d891f345 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -26,7 +26,7 @@ module noahmpdrv private public :: noahmpdrv_init, noahmpdrv_run, & - noahmpdrv_timestep_init, noahmpdrv_timestep_finalize, noahmpdrv_finalize + noahmpdrv_timestep_init, noahmpdrv_finalize !> \Land IAU data and control ! Land IAU Control holds settings' information, maily read from namelist (e.g., @@ -430,27 +430,6 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & end subroutine noahmpdrv_timestep_init - !> \ingroup NoahMP_LSM -!! \brief This subroutine is called after noahmpdrv_run -!! to free up allocated memory, if there are any -!! code to do any needed consistency check will go here-- -!! \section arg_table_noahmpdrv_timestep_finalize Argument Table -!! \htmlinclude noahmpdrv_timestep_finalize.html -!! - subroutine noahmpdrv_timestep_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, - - use machine, only: kind_phys - implicit none - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! --- Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - !> note the IAU deallocate happens at the noahmpdrv_finalize - - end subroutine noahmpdrv_timestep_finalize - !> \ingroup NoahMP_LSM !! \brief This subroutine mirrors noahmpdrv_init !! it calls land_iau_finalize which frees up allocated memory by IAU_init (in noahmdrv_init) From b4f0ba98f60f8365b97bc63e821c4bf43c001329 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Mon, 23 Sep 2024 00:41:24 -0600 Subject: [PATCH 106/154] Update noahmpdrv.meta remove empty subroutine: noahmpdrv_timestep_finalize --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 20 ------------------- 1 file changed, 20 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 892894329..3994741d1 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -340,26 +340,6 @@ type = integer intent = out -####################################################################### -[ccpp-arg-table] - name = noahmpdrv_timestep_finalize - type = scheme -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ####################################################################### [ccpp-arg-table] name = noahmpdrv_finalize From d2f9be1392c49853e6839688623cbbaf4cb261ce Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Mon, 23 Sep 2024 00:43:48 -0600 Subject: [PATCH 107/154] Update noahmpdrv.F90 removed pointer attribute from "input_nml_file" declaration --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 4d891f345..c96fb5531 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -74,7 +74,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & ! land iau mod integer, intent(in) :: mpi_root ! = GFS_Control%master character(*), intent(in) :: fn_nml - character(len=:), intent(in), dimension(:), pointer :: input_nml_file + character(len=:), intent(in), dimension(:) :: input_nml_file integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks integer, intent(in) :: tile_num !GFS_control_type%tile_num integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz From 6609eac2c59806f0b366016861478897d4eb4407 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Mon, 23 Sep 2024 00:50:40 -0600 Subject: [PATCH 108/154] Update lnd_iau_mod.F90 --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 6047fcaf0..61dcebaf8 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -121,8 +121,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads character(len=4) :: iosstr - !> these are not available through the CCPP interface so need to read them from namelist file - !> vars to read from namelist + !> land iau setting read from namelist logical :: do_land_iau = .false. real(kind=kind_phys) :: land_iau_delthrs = 0 !< iau time interval (to scale increments) character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files From dbd3eb4a636c76629d9453d2a012c2f45b175fc7 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Mon, 23 Sep 2024 01:00:52 -0600 Subject: [PATCH 109/154] Update lnd_iau_mod.F90 remove commented out old lines --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 41 ++++--------------- 1 file changed, 7 insertions(+), 34 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 61dcebaf8..e537e5b56 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -76,15 +76,12 @@ module land_iau_mod logical :: upd_slc logical :: do_stcsmc_adjustment !do moisture/temperature adjustment for consistency after increment add real(kind=kind_phys) :: min_T_increment - !, iau_drymassfixer + integer :: me !< MPI rank designator integer :: mpi_root !< MPI rank of master atmosphere processor character(len=64) :: fn_nml !< namelist filename for surface data cycling real(kind=kind_phys) :: dtp !< physics timestep in seconds real(kind=kind_phys) :: fhour !< current forecast hour -! character(len=:), pointer, dimension(:) :: input_nml_file => null() ! null() + + character(len=:), dimension(:) :: input_nml_file => null() integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads character(len=4) :: iosstr @@ -127,7 +124,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files real(kind=kind_phys) :: land_iau_fhrs(7) = -1 !< forecast hours associated with increment files logical :: land_iau_filter_increments = .false. !< filter IAU increments - !logical :: land_iau_gaussian_inc_file = .false. + integer :: lsoil_incr = 4 logical :: land_iau_upd_stc = .false. logical :: land_iau_upd_slc = .false. @@ -155,7 +152,6 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me ! if (file_exist(fn_nml)) then inquire (file=trim(fn_nml), exist=exists) ! TBCL: this maybe be replaced by nlunit passed from ccpp if (.not. exists) then - ! call mpp_error(FATAL, 'lnd_iau_mod_set_control: namelist file ',trim(fn_nml),' does not exist') write(6,*) 'lnd_iau_mod_set_control: namelist file ',trim(fn_nml),' does not exist' errmsg = 'lnd_iau_mod_set_control: namelist file '//trim(fn_nml)//' does not exist' errflg = 1 @@ -167,8 +163,6 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me read (nlunit, nml=land_iau_nml, ERR=888, END=999, iostat=ios) close (nlunit) if (ios /= 0) then - ! call mpp_error(FATAL, 'lnd_iau_mod_set_control: error reading namelist file ',trim(fn_nml)) - ! write(6,*) 'lnd_iau_mod_set_control: error reading namelist file ',trim(fn_nml) write(6,*) trim(ioerrmsg) errmsg = 'lnd_iau_mod_set_control: error reading namelist file '//trim(fn_nml) & // 'the error message from file handler:' //trim(ioerrmsg) @@ -221,9 +215,6 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me Land_IAU_Control%dtp = dtp Land_IAU_Control%fhour = fhour -! Land_IAU_Control%input_nml_file = input_nml_file -! Land_IAU_Control%input_nml_file_length = input_nml_file_length - Land_IAU_Control%upd_stc = land_iau_upd_stc Land_IAU_Control%upd_slc = land_iau_upd_slc Land_IAU_Control%do_stcsmc_adjustment = land_iau_do_stcsmc_adjustment @@ -244,12 +235,9 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me end subroutine land_iau_mod_set_control -subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !nlunit, ncols, IPD_Data,,Init_parm) - ! integer, intent(in) :: me, mpi_root +subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) type (land_iau_control_type), intent(inout) :: Land_IAU_Control type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data - ! real(kind=kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - ! real(kind=kind_phys), dimension(:), intent(in) :: xlat ! latitude character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -260,7 +248,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) integer :: nfilesall, ntimesall integer, allocatable :: idt(:) integer :: nlon, nlat - ! integer :: nb, ix, nblks, blksz logical :: exists integer :: ncid, dimid, varid, status, IDIM @@ -598,10 +585,9 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) end subroutine setiauforcing -subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, stc_inc_out, slc_inc_out +subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) type (land_iau_control_type), intent(in) :: Land_IAU_Control - ! character(len=*), intent(in) :: fname character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg @@ -784,7 +770,6 @@ SUBROUTINE NETCDF_ERR(ERR, STRING, errflg, errmsg_out) ERRMSG = NF90_STRERROR(ERR) PRINT*,'FATAL ERROR in Land IAU ', TRIM(STRING), ': ', TRIM(ERRMSG) errmsg_out = 'FATAL ERROR in Land IAU '//TRIM(STRING)//': '//TRIM(ERRMSG) - ! CALL MPI_ABORT(MPI_COMM_WORLD, 999) errflg = 1 return @@ -810,14 +795,7 @@ subroutine get_nc_dimlen(ncid, dim_name, dim_len, errflg, errmsg_out ) CALL netcdf_err(status, 'reading dim length '//trim(dim_name), errflg, errmsg_out) end subroutine get_nc_dimlen - ! status = nf90_inq_dimid(ncid, "longitude", dimid) - ! CALL netcdf_err(status, 'reading longitude dim id') - ! status = nf90_inquire_dimension(ncid, dimid, len = im) - ! CALL netcdf_err(status, 'reading dim longitude') - ! status = nf90_inq_dimid(ncid, "latitude", dimid) - ! CALL netcdf_err(status, 'reading latitude dim id') - ! status = nf90_inquire_dimension(ncid, dimid, len = jm) - ! CALL netcdf_err(status, 'reading dim latitude') + subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) integer, intent(in):: ncid, dim_len character(len=*), intent(in):: var_name @@ -861,11 +839,6 @@ subroutine get_var3d_values_int(ncid, varid, is,ix, js,jy, ks,kz, var3d, status) integer, intent(in):: is, ix, js, jy, ks,kz integer, intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) integer, intent(out):: status - ! integer, dimension(3):: start, nreco - ! start(1) = is; start(2) = js; start(3) = ks - ! nreco(1) = ie - is + 1 - ! nreco(2) = je - js + 1 - ! nreco(3) = ke - ks + 1 status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) start = (/is, js, ks/), count = (/ix, jy, kz/)) From 3c4fc1a887a5b6476d25b753c07f44b3d6226057 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Mon, 23 Sep 2024 05:14:32 -0600 Subject: [PATCH 110/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index c96fb5531..e9043a3fa 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -29,10 +29,8 @@ module noahmpdrv noahmpdrv_timestep_init, noahmpdrv_finalize !> \Land IAU data and control - ! Land IAU Control holds settings' information, maily read from namelist (e.g., - ! block of global domain that belongs to a process , - ! whethrer to do IAU increment at this time step, - ! time step informatoin, etc) + ! Land IAU Control holds settings' information, maily read from namelist (e.g., block of global domain that belongs to a process , + ! whether to do IAU increment at this time step, time step informatoin, etc) type (land_iau_control_type) :: Land_IAU_Control ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks From 335141f1fb32598773c3a7941cd1a759570d49c8 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Thu, 26 Sep 2024 00:30:44 -0600 Subject: [PATCH 111/154] Update lnd_iau_mod.F90 get rid unused var input_nml_length --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index e537e5b56..cd7968dba 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -114,8 +114,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me logical :: exists character(len=512) :: ioerrmsg - character(len=:), dimension(:) :: input_nml_file => null() - integer :: input_nml_file_length !< length(number of lines) in namelist for internal reads + character(len=:), dimension(:) :: input_nml_file => null() character(len=4) :: iosstr !> land iau setting read from namelist @@ -146,8 +145,6 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me allocate(input_nml_file, mold=input_nml_file_i) input_nml_file => input_nml_file_i read(input_nml_file, nml=land_iau_nml, ERR=888, END=999, iostat=ios) - ! Set length (number of lines) in namelist for internal reads - input_nml_file_length = size(input_nml_file) #else ! if (file_exist(fn_nml)) then inquire (file=trim(fn_nml), exist=exists) ! TBCL: this maybe be replaced by nlunit passed from ccpp From 77714c4f000f70e95c8048a326ff54e7fc748f82 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 2 Oct 2024 09:13:14 -0600 Subject: [PATCH 112/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index e9043a3fa..08e6d192d 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -280,7 +280,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! delt=GFS_Control%dtf if ((Land_IAU_Control%dtp - delt) > 0.0001) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_run delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp + print*, "Warning noahmpdrv_timestep_init delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp endif endif From 28cf85f5983a1b8ffc714b02fd0cd45dc26b76fa Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 2 Oct 2024 09:19:38 -0600 Subject: [PATCH 113/154] Update noahmpdrv.F90 comment out unused number of freeze/thaw counters --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 08e6d192d..fbc9f15d1 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -197,7 +197,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & integer, allocatable :: mask_tile(:) integer,allocatable :: stc_updated(:), slc_updated(:) logical :: soil_freeze, soil_ice - integer :: n_freeze, n_thaw + ! integer :: n_freeze, n_thaw integer :: soiltype, n_stc, n_slc real(kind=kind_phys) :: slc_new From 156fb4e5f09e41b8064fe61502afc8f6a20e6432 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 2 Oct 2024 09:20:59 -0600 Subject: [PATCH 114/154] Update noahmpdrv.meta fix typo --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 3994741d1..5bcc0840e 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -114,7 +114,7 @@ intent = in [input_nml_file] standard_name = filename_of_internal_namelist - long_name = amelist filename for internal file reads + long_name = namelist filename for internal file reads units = none type = character dimensions = (ccpp_constant_one:number_of_lines_in_internal_namelist) From bfbb35de96dcd2fed39df0c4eae14548969bd97d Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 2 Oct 2024 09:26:27 -0600 Subject: [PATCH 115/154] Update noahmpdrv.meta make long names consistent with naming conventions --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 5bcc0840e..c8a0dd9dc 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -143,14 +143,14 @@ intent = in [nx] standard_name = number_of_points_in_x_direction_for_this_mpi_rank - long_name = number of points in x direction for this MPI rank + long_name = number of points in the x direction units = count dimensions = () type = integer intent = in [ny] standard_name = number_of_points_in_y_direction_for_this_mpi_rank - long_name = number of points in y direction for this MPI rank + long_name = number of points in the y direction units = count dimensions = () type = integer @@ -252,7 +252,7 @@ intent = in [km] standard_name = vertical_dimension_of_soil - long_name = soil vertical layer dimension + long_name = vertical dimension of soil layers units = count dimensions = () type = integer @@ -294,7 +294,7 @@ intent= in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land - long_name = water equiv of acc snow depth over land + long_name = water equivalent of accumulated snow depth over land units = mm dimensions = (horizontal_dimension) type = real From 7188fc8a7a73f9de29e470b8a86df90b67eb39e3 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 9 Oct 2024 12:57:01 -0400 Subject: [PATCH 116/154] move declaration of land_iau_mod DDT instances from CCPP physics to host model --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 60 ++++++++++-------- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 39 +++++++----- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 63 +++++++++++++++++++ 3 files changed, 121 insertions(+), 41 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index cd7968dba..3249a6e65 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -21,13 +21,17 @@ module land_iau_mod use machine, only: kind_phys, kind_dyn - use physcons, only: pi => con_pi use netcdf implicit none private + !GJF: These variables may need to get moved to the host model and passed in, depending on their use. + ! They are currently allocated/initialized in the CCPP init stage and are used throughout the + ! simulation in the timestep_init phase. Since this module memory exists on the heap, this + ! may cause issues for models that have multiple CCPP instances in one executable if the data + ! differs between CCPP instances. real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) integer, allocatable :: wk3_slmsk(:, :, :) @@ -87,7 +91,6 @@ module land_iau_mod end type land_iau_control_type - type(land_iau_state_type) :: Land_IAU_state public land_iau_control_type, land_iau_external_data_type, land_iau_mod_set_control, & land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, calculate_landinc_mask @@ -232,11 +235,12 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me end subroutine land_iau_mod_set_control -subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) - type (land_iau_control_type), intent(inout) :: Land_IAU_Control - type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg +subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) + type (land_iau_control_type), intent(inout) :: Land_IAU_Control + type (land_iau_external_data_type), intent(inout) :: Land_IAU_Data + type(land_iau_state_type), intent(inout) :: Land_IAU_state + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg ! local character(len=128) :: fname @@ -372,7 +376,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) enddo if (ntimes.EQ.1) then ! only need to get incrments once since constant forcing over window - call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) + call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) endif if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) @@ -392,12 +396,13 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) end subroutine land_iau_mod_init -subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) +subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) implicit none - type (land_iau_control_type), intent(in) :: Land_IAU_Control + type(land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data + type(land_iau_state_type), intent(inout) :: Land_IAU_state character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -421,11 +426,12 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg end subroutine land_iau_mod_finalize - subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) + subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) implicit none type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data + type(land_iau_state_type), intent(inout) :: Land_IAU_state character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys) t1,t2,sx,wx,wt,dtp @@ -483,7 +489,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 Land_IAU_Data%in_interval=.false. else - if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control,Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) + if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact,Land_IAU_state%rdt Land_IAU_Data%in_interval=.true. endif @@ -517,18 +523,19 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, e Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) - call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state%rdt, Land_IAU_state%wt) + call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) endif endif end subroutine land_iau_mod_getiauforcing -subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) +subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) implicit none - type (land_iau_control_type), intent(in) :: Land_IAU_Control + type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - real(kind=kind_phys) delt, rdt, wt + type(land_iau_state_type), intent(inout) :: Land_IAU_state + real(kind=kind_phys) delt integer i,j,k integer :: is, ie, js, je, npz integer :: ntimes @@ -543,23 +550,24 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & - " rdt wt delt ", rdt, wt, delt + " rdt wt delt ", Land_IAU_state%rdt, Land_IAU_state%wt, delt do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%stc_inc(i,j,k))*rdt*wt - Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%slc_inc(i,j,k))*rdt*wt + Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%stc_inc(i,j,k))*Land_IAU_state%rdt*Land_IAU_state%wt + Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%slc_inc(i,j,k))*Land_IAU_state%rdt*Land_IAU_state%wt end do enddo enddo end subroutine updateiauforcing - subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) + subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) implicit none - type (land_iau_control_type), intent(in) :: Land_IAU_Control - type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - real(kind=kind_phys) delt, rdt,wt + type(land_iau_control_type), intent(in ) :: Land_IAU_Control + type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data + type(land_iau_state_type), intent(in ) :: Land_IAU_state + real(kind=kind_phys) delt integer i, j, k integer :: is, ie, js, je, npz @@ -569,12 +577,12 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, rdt, wt) je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil ! this is only called if using 1 increment file - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',Land_IAU_state%rdt do j = js, je do i = is, ie do k = 1, npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) = wt*Land_IAU_state%inc1%stc_inc(i,j,k)*rdt - Land_IAU_Data%slc_inc(i,j,k) = wt*Land_IAU_state%inc1%slc_inc(i,j,k)*rdt + Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_state%wt*Land_IAU_state%inc1%stc_inc(i,j,k)*Land_IAU_state%rdt + Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_state%wt*Land_IAU_state%inc1%slc_inc(i,j,k)*Land_IAU_state%rdt end do Land_IAU_Data%snow_land_mask(i, j) = wk3_slmsk(1, i, j) enddo diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index fbc9f15d1..218a0df29 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -14,7 +14,8 @@ module noahmpdrv use module_sf_noahmplsm ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) - use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & + use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & + land_iau_state_type, & land_iau_mod_set_control, land_iau_mod_init, & land_iau_mod_getiauforcing, land_iau_mod_finalize, & calculate_landinc_mask @@ -26,14 +27,7 @@ module noahmpdrv private public :: noahmpdrv_init, noahmpdrv_run, & - noahmpdrv_timestep_init, noahmpdrv_finalize - - !> \Land IAU data and control - ! Land IAU Control holds settings' information, maily read from namelist (e.g., block of global domain that belongs to a process , - ! whether to do IAU increment at this time step, time step informatoin, etc) - type (land_iau_control_type) :: Land_IAU_Control - ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step - type (land_iau_external_data_type) :: Land_IAU_Data !(number of blocks):each proc holds nblks + noahmpdrv_timestep_init, noahmpdrv_finalize contains @@ -48,7 +42,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & nlunit, pores, resid, & do_mynnsfclay,do_mynnedmf, & errmsg, errflg, & - mpi_root, & + land_iau_control, land_iau_data, land_iau_state, mpi_root, & fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, tile_num, & nblks, blksz, xlon, xlat, & lsoil, lsnow_lsm, dtp, fhour) @@ -70,6 +64,13 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! land iau mod + + ! Land IAU Control holds settings' information, maily read from namelist (e.g., block of global domain that belongs to a process , + ! whether to do IAU increment at this time step, time step informatoin, etc) + type(land_iau_control_type), intent(inout) :: Land_IAU_Control + ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step + type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data !(number of blocks):each proc holds nblks + type(land_iau_state_type), intent(inout) :: Land_IAU_state integer, intent(in) :: mpi_root ! = GFS_Control%master character(*), intent(in) :: fn_nml character(len=:), intent(in), dimension(:) :: input_nml_file @@ -135,7 +136,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) ! Initialize IAU for land if (.not. Land_IAU_Control%do_land_iau) return - call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, errmsg, errflg) ! xlon, xlat, errmsg, errflg) + call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) ! xlon, xlat, errmsg, errflg) end subroutine noahmpdrv_init @@ -155,6 +156,7 @@ end subroutine noahmpdrv_init subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !me, mpi_root, isot, ivegsrc, soiltyp, vegtype, weasd, & + land_iau_control, land_iau_data, land_iau_state, & stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, use machine, only: kind_phys @@ -175,7 +177,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & integer , dimension(:) , intent(in) :: soiltyp ! soil type (integer index) integer , dimension(:) , intent(in) :: vegtype ! vegetation type (integer index) real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] - + + type(land_iau_control_type) , intent(inout) :: Land_IAU_Control + type(land_iau_external_data_type) , intent(inout) :: Land_IAU_Data + type(land_iau_state_type) , intent(inout) :: Land_IAU_State real(kind=kind_phys), dimension(:,:) , intent(inout) :: stc ! soiltemp [K] real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc !liquid soil moisture [m3/m3]' real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! @@ -183,6 +188,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & integer, intent(out) :: errflg ! IAU update + real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat, slc_inc_flat real(kind=kind_phys), dimension(km) :: dz ! layer thickness ! real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) @@ -231,7 +237,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & endif !> read iau increments - call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) + call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) if (errflg .ne. 0) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" @@ -434,10 +440,13 @@ end subroutine noahmpdrv_timestep_init !! \section arg_table_noahmpdrv_finalize Argument Table !! \htmlinclude noahmpdrv_finalize.html !! - subroutine noahmpdrv_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, + subroutine noahmpdrv_finalize (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) ! smc, t2mmp, q2mp, use machine, only: kind_phys implicit none + type(land_iau_control_type) , intent(in ) :: Land_IAU_Control + type(land_iau_external_data_type) , intent(inout) :: Land_IAU_Data + type(land_iau_state_type) , intent(inout) :: Land_IAU_State character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg integer :: j, k, ib @@ -446,7 +455,7 @@ subroutine noahmpdrv_finalize (errmsg, errflg) ! smc, t2mmp, q2mp, errflg = 0 if (.not. Land_IAU_Control%do_land_iau) return - call land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, errmsg, errflg) !Land_IAU_Control%finalize() + call land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) !Land_IAU_Control%finalize() end subroutine noahmpdrv_finalize diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index c8a0dd9dc..a09f257fd 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -97,6 +97,27 @@ dimensions = () type = integer intent = out +[land_iau_control] + standard_name = land_data_assimilation_control + long_name = land data assimilation control + units = mixed + dimensions = () + type = land_iau_control_type + intent = inout +[land_iau_data] + standard_name = land_data_assimilation_data + long_name = land data assimilation data + units = mixed + dimensions = () + type = land_iau_external_data_type + intent = inout +[land_iau_state] + standard_name = land_data_assimilation_interpolated_data + long_name = land data assimilation space- and time-interpolated + units = mixed + dimensions = () + type = land_iau_state_type + intent = inout [mpi_root] standard_name = mpi_root long_name = master MPI-rank @@ -300,6 +321,27 @@ type = real kind = kind_phys intent = inout +[land_iau_control] + standard_name = land_data_assimilation_control + long_name = land data assimilation control + units = mixed + dimensions = () + type = land_iau_control_type + intent = inout +[land_iau_data] + standard_name = land_data_assimilation_data + long_name = land data assimilation data + units = mixed + dimensions = () + type = land_iau_external_data_type + intent = inout +[land_iau_state] + standard_name = land_data_assimilation_interpolated_data + long_name = land data assimilation space- and time-interpolated + units = mixed + dimensions = () + type = land_iau_state_type + intent = inout [stc] standard_name = soil_temperature long_name = soil temperature @@ -344,6 +386,27 @@ [ccpp-arg-table] name = noahmpdrv_finalize type = scheme +[land_iau_control] + standard_name = land_data_assimilation_control + long_name = land data assimilation control + units = mixed + dimensions = () + type = land_iau_control_type + intent = in +[land_iau_data] + standard_name = land_data_assimilation_data + long_name = land data assimilation data + units = mixed + dimensions = () + type = land_iau_external_data_type + intent = inout +[land_iau_state] + standard_name = land_data_assimilation_interpolated_data + long_name = land data assimilation space- and time-interpolated + units = mixed + dimensions = () + type = land_iau_state_type + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From bf3e1e1659c9ad1240738bcd4e32c5d1301d6277 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 9 Oct 2024 19:59:09 +0000 Subject: [PATCH 117/154] add metadata for land IAU types --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 13 +++++ .../SFC_Models/Land/Noahmp/lnd_iau_mod.meta | 58 +++++++++++++++++++ 2 files changed, 71 insertions(+) create mode 100644 physics/SFC_Models/Land/Noahmp/lnd_iau_mod.meta diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 3249a6e65..6c501167b 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -18,6 +18,9 @@ !> by Xi.Chen and Philip Pegion, PSL !------------------------------------------------------------------------------- +!> \section arg_table_land_iau_mod Argument table +!! \htmlinclude land_iau_mod.html +!! module land_iau_mod use machine, only: kind_phys, kind_dyn @@ -40,6 +43,9 @@ module land_iau_mod real(kind=kind_phys),allocatable :: slc_inc(:,:,:) end type land_iau_internal_data_type +!> \section arg_table_land_iau_external_data_type Argument Table +!! \htmlinclude land_iau_external_data_type.html +!! type land_iau_external_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:) @@ -47,6 +53,9 @@ module land_iau_mod integer,allocatable :: snow_land_mask(:, :) end type land_iau_external_data_type +!!> \section arg_table_land_iau_state_type Argument Table +!! \htmlinclude land_iau_state_type.html +!! type land_iau_state_type type(land_iau_internal_data_type) :: inc1 type(land_iau_internal_data_type) :: inc2 @@ -57,6 +66,10 @@ module land_iau_mod real(kind=kind_phys) :: rdt end type land_iau_state_type + +!!!> \section arg_table_land_iau_control_type Argument Table +!! \htmlinclude land_iau_control_type.html +!! type land_iau_control_type integer :: isc integer :: jsc diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.meta b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.meta new file mode 100644 index 000000000..8541af659 --- /dev/null +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.meta @@ -0,0 +1,58 @@ +[ccpp-table-properties] + name = land_iau_external_data_type + type = ddt + dependencies = + +[ccpp-arg-table] + name = land_iau_external_data_type + type = ddt + +######################################################################## + +[ccpp-table-properties] + name = land_iau_state_type + type = ddt + dependencies = + +[ccpp-arg-table] + name = land_iau_state_type + type = ddt + +######################################################################## + +[ccpp-table-properties] + name = land_iau_control_type + type = ddt + dependencies = + +[ccpp-arg-table] + name = land_iau_control_type + type = ddt + +######################################################################## +[ccpp-table-properties] + name = land_iau_mod + type = module + dependencies = machine.F + +[ccpp-arg-table] + name = land_iau_mod + type = module +[land_iau_external_data_type] + standard_name = land_iau_external_data_type + long_name = definition of type land_iau_external_data_type + units = DDT + dimensions = () + type = land_iau_external_data_type +[land_iau_state_type] + standard_name = land_iau_state_type + long_name = definition of type land_iau_state_type + units = DDT + dimensions = () + type = land_iau_state_type +[land_iau_control_type] + standard_name = land_iau_control_type + long_name = definition of type land_iau_control_type + units = DDT + dimensions = () + type = land_iau_control_type From 4782f68666a0e719a217ba42d485e4f65ab3b914 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 9 Oct 2024 22:12:26 +0000 Subject: [PATCH 118/154] fix compilation errors --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 4 ++-- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 6c501167b..a1495c433 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -104,7 +104,7 @@ module land_iau_mod end type land_iau_control_type - public land_iau_control_type, land_iau_external_data_type, land_iau_mod_set_control, & + public land_iau_control_type, land_iau_external_data_type, land_iau_state_type, land_iau_mod_set_control, & land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, calculate_landinc_mask contains @@ -130,7 +130,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me logical :: exists character(len=512) :: ioerrmsg - character(len=:), dimension(:) :: input_nml_file => null() + character(len=:), pointer, dimension(:) :: input_nml_file => null() character(len=4) :: iosstr !> land iau setting read from namelist diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 218a0df29..8b624c062 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -73,7 +73,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & type(land_iau_state_type), intent(inout) :: Land_IAU_state integer, intent(in) :: mpi_root ! = GFS_Control%master character(*), intent(in) :: fn_nml - character(len=:), intent(in), dimension(:) :: input_nml_file + character(len=:), pointer, intent(in), dimension(:) :: input_nml_file integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks integer, intent(in) :: tile_num !GFS_control_type%tile_num integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz From 6e3bc2f49b389d55e94544407cda905c14be4bd3 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 15 Oct 2024 18:10:53 -0400 Subject: [PATCH 119/154] set land_iau_control from host --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 4 +- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 54 ++++++++++--------- 2 files changed, 30 insertions(+), 28 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index a1495c433..205623004 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -409,7 +409,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e end subroutine land_iau_mod_init -subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) +subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_state, errmsg, errflg) implicit none @@ -563,7 +563,7 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & - " rdt wt delt ", Land_IAU_state%rdt, Land_IAU_state%wt, delt + " rdt wt delt_t ", Land_IAU_state%rdt, Land_IAU_state%wt, delt do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 8b624c062..497f81570 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -15,10 +15,10 @@ module noahmpdrv ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & - land_iau_state_type, & - land_iau_mod_set_control, land_iau_mod_init, & - land_iau_mod_getiauforcing, land_iau_mod_finalize, & - calculate_landinc_mask + land_iau_state_type + + use land_iau_mod, only: land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & + calculate_landinc_mask ! land_iau_mod_set_control, implicit none @@ -37,15 +37,16 @@ module noahmpdrv !! \section arg_table_noahmpdrv_init Argument Table !! \htmlinclude noahmpdrv_init.html !! - subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & + subroutine noahmpdrv_init(lsm, lsm_noahmp, & isot, ivegsrc, & nlunit, pores, resid, & do_mynnsfclay,do_mynnedmf, & errmsg, errflg, & - land_iau_control, land_iau_data, land_iau_state, mpi_root, & - fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, tile_num, & - nblks, blksz, xlon, xlat, & - lsoil, lsnow_lsm, dtp, fhour) + Land_IAU_Control, Land_IAU_Data, Land_IAU_state) + ! , me, mpi_root, & + ! fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, tile_num, & + ! nblks, blksz, xlon, xlat, & + ! lsoil, lsnow_lsm, dtp, fhour) use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg @@ -55,8 +56,7 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & implicit none integer, intent(in) :: lsm - integer, intent(in) :: lsm_noahmp - integer, intent(in) :: me ! mpi_rank + integer, intent(in) :: lsm_noahmp integer, intent(in) :: isot, ivegsrc, nlunit real (kind=kind_phys), dimension(:), intent(out) :: pores, resid logical, intent(in) :: do_mynnsfclay @@ -71,17 +71,19 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data !(number of blocks):each proc holds nblks type(land_iau_state_type), intent(inout) :: Land_IAU_state - integer, intent(in) :: mpi_root ! = GFS_Control%master - character(*), intent(in) :: fn_nml - character(len=:), pointer, intent(in), dimension(:) :: input_nml_file - integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks - integer, intent(in) :: tile_num !GFS_control_type%tile_num - integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz - real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - real(kind_phys), dimension(:), intent(in) :: xlat ! latitude - - integer, intent(in) :: lsoil, lsnow_lsm - real(kind=kind_phys), intent(in) :: dtp, fhour + + ! integer, intent(in) :: me ! mpi_rank + ! integer, intent(in) :: mpi_root ! = GFS_Control%master + ! character(*), intent(in) :: fn_nml + ! character(len=:), pointer, intent(in), dimension(:) :: input_nml_file + ! integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks + ! integer, intent(in) :: tile_num !GFS_control_type%tile_num + ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon + ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude + + ! integer, intent(in) :: lsoil, lsnow_lsm + ! real(kind=kind_phys), intent(in) :: dtp, fhour ! Initialize CCPP error handling variables errmsg = '' @@ -130,10 +132,10 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, & pores (:) = maxsmc (:) resid (:) = drysmc (:) - ! Read Land IAU settings - call land_iau_mod_set_control(Land_IAU_Control, fn_nml, input_nml_file, & - me, mpi_root, isc,jsc, nx, ny, tile_num, nblks, blksz, & - lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) + ! ! Read Land IAU settings + ! call land_iau_mod_set_control(Land_IAU_Control, fn_nml, input_nml_file, & + ! me, mpi_root, isc,jsc, nx, ny, tile_num, nblks, blksz, & + ! lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) ! Initialize IAU for land if (.not. Land_IAU_Control%do_land_iau) return call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) ! xlon, xlat, errmsg, errflg) From 1a6778566bc5e8d99ed1363998ab902f7eb6fcd0 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 16 Oct 2024 07:41:27 -0400 Subject: [PATCH 120/154] calculate snowsoil mask at runtime --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 52 +++++++++---------- 1 file changed, 24 insertions(+), 28 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 205623004..edd8f62b0 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -36,7 +36,7 @@ module land_iau_mod ! may cause issues for models that have multiple CCPP instances in one executable if the data ! differs between CCPP instances. real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) - integer, allocatable :: wk3_slmsk(:, :, :) +! integer, allocatable :: wk3_slmsk(:, :, :) ! Calculate snow soil mask at runtime from (dynamic) swe type land_iau_internal_data_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:) @@ -50,7 +50,7 @@ module land_iau_mod real(kind=kind_phys),allocatable :: stc_inc(:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. - integer,allocatable :: snow_land_mask(:, :) + ! integer,allocatable :: snow_land_mask(:, :) ! Calculate snow soil mask at runtime from (dynamic) swe end type land_iau_external_data_type !!> \section arg_table_land_iau_state_type Argument Table @@ -268,8 +268,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e real(kind=kind_phys) :: dt, rdt integer :: im, jm, km, nfiles, ntimes - integer :: n_soill, n_snowl !soil and snow layers - logical :: do_land_iau integer :: is, ie, js, je integer :: npz integer :: i, j @@ -278,9 +276,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e errmsg = '' errflg = 0 - do_land_iau = Land_IAU_Control%do_land_iau - n_soill = Land_IAU_Control%lsoil !4 for sfc updates -! n_snowl = Land_IAU_Control%lsnowl npz = Land_IAU_Control%lsoil km = Land_IAU_Control%lsoil @@ -297,7 +292,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e allocate(Land_IAU_Data%stc_inc(nlon, nlat, km)) allocate(Land_IAU_Data%slc_inc(nlon, nlat, km)) - allocate(Land_IAU_Data%snow_land_mask(nlon, nlat)) + ! allocate(Land_IAU_Data%snow_land_mask(nlon, nlat)) ! allocate arrays that will hold iau state allocate (Land_IAU_state%inc1%stc_inc(nlon, nlat, km)) @@ -332,6 +327,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e ! increment files in fv3 tiles if (trim(Land_IAU_Control%iau_inc_files(1)) .eq. '' .or. Land_IAU_Control%iaufhrs(1) .lt. 0) then ! only 1 file expected print*, "warning! in Land IAU but increment file name is empty or iaufhrs(1) is negative" + Land_IAU_Control%do_land_iau=.false. return endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then @@ -394,7 +390,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) + ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) do k = 1, npz ! do k = 1,n_soill ! do j = 1, nlat @@ -425,11 +421,11 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_state if (allocated (wk3_stc)) deallocate (wk3_stc) if (allocated (wk3_slc)) deallocate (wk3_slc) - if (allocated (wk3_slmsk)) deallocate (wk3_slmsk) + ! if (allocated (wk3_slmsk)) deallocate (wk3_slmsk) if (allocated(Land_IAU_Data%stc_inc)) deallocate (Land_IAU_Data%stc_inc) if (allocated(Land_IAU_Data%slc_inc)) deallocate (Land_IAU_Data%slc_inc) - if (allocated(Land_IAU_Data%snow_land_mask)) deallocate (Land_IAU_Data%snow_land_mask) + ! if (allocated(Land_IAU_Data%snow_land_mask)) deallocate (Land_IAU_Data%snow_land_mask) if (allocated(Land_IAU_state%inc1%stc_inc)) deallocate(Land_IAU_state%inc1%stc_inc) if (allocated(Land_IAU_state%inc1%slc_inc)) deallocate(Land_IAU_state%inc1%slc_inc) @@ -535,7 +531,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif - Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) + ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) endif endif @@ -597,7 +593,7 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_state%wt*Land_IAU_state%inc1%stc_inc(i,j,k)*Land_IAU_state%rdt Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_state%wt*Land_IAU_state%inc1%slc_inc(i,j,k)*Land_IAU_state%rdt end do - Land_IAU_Data%snow_land_mask(i, j) = wk3_slmsk(1, i, j) + ! Land_IAU_Data%snow_land_mask(i, j) = wk3_slmsk(1, i, j) enddo enddo @@ -665,7 +661,7 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) allocate(wk3_stc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) allocate(wk3_slc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) - allocate(wk3_slmsk(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny)) + ! allocate(wk3_slmsk(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny)) do i = 1, size(stc_vars) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(stc_vars(i)) @@ -701,20 +697,20 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) wk3_slc(:, :, :, i) = 0. endif enddo - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(slsn_mask) - status = nf90_inq_varid(ncid, trim(slsn_mask), varid) - if (status == nf90_noerr) then !if (ierr == 0) then - do it = 1, n_t - call get_var3d_values_int(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & - it, 1, wk3_slmsk(it, :, :), status) - call netcdf_err(status, 'reading var: '//trim(slsn_mask), errflg, errmsg) - if (errflg .ne. 0) return - enddo - else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, 'warning: no values for ',trim(slsn_mask), ' found', & - 'assuming value of 1 for all grid cells. Please make sure the increment files have soil snow mask var' - wk3_slmsk(:, :, :) = 1 - endif + ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(slsn_mask) + ! status = nf90_inq_varid(ncid, trim(slsn_mask), varid) + ! if (status == nf90_noerr) then !if (ierr == 0) then + ! do it = 1, n_t + ! call get_var3d_values_int(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & + ! it, 1, wk3_slmsk(it, :, :), status) + ! call netcdf_err(status, 'reading var: '//trim(slsn_mask), errflg, errmsg) + ! if (errflg .ne. 0) return + ! enddo + ! else + ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, 'warning: no values for ',trim(slsn_mask), ' found', & + ! 'assuming value of 1 for all grid cells. Please make sure the increment files have soil snow mask var' + ! wk3_slmsk(:, :, :) = 1 + ! endif status =nf90_close(ncid) call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) From c58be12171ad858978c5002dc3e0d0a7fe6f58e8 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 16 Oct 2024 15:00:29 -0400 Subject: [PATCH 121/154] combine DDTs holding increments; get rid of scheme level global array --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 173 ++++++++++-------- 1 file changed, 95 insertions(+), 78 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index edd8f62b0..0ff126c9c 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -35,13 +35,13 @@ module land_iau_mod ! simulation in the timestep_init phase. Since this module memory exists on the heap, this ! may cause issues for models that have multiple CCPP instances in one executable if the data ! differs between CCPP instances. - real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) +! real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) ! integer, allocatable :: wk3_slmsk(:, :, :) ! Calculate snow soil mask at runtime from (dynamic) swe - type land_iau_internal_data_type - real(kind=kind_phys),allocatable :: stc_inc(:,:,:) - real(kind=kind_phys),allocatable :: slc_inc(:,:,:) - end type land_iau_internal_data_type +! type land_iau_internal_data_type +! real(kind=kind_phys),allocatable :: stc_inc(:,:,:) +! real(kind=kind_phys),allocatable :: slc_inc(:,:,:) +! end type land_iau_internal_data_type !> \section arg_table_land_iau_external_data_type Argument Table !! \htmlinclude land_iau_external_data_type.html @@ -51,19 +51,24 @@ module land_iau_mod real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. ! integer,allocatable :: snow_land_mask(:, :) ! Calculate snow soil mask at runtime from (dynamic) swe + real(kind=kind_phys) :: hr1 ! moved from _state_type + real(kind=kind_phys) :: hr2 end type land_iau_external_data_type !!> \section arg_table_land_iau_state_type Argument Table !! \htmlinclude land_iau_state_type.html !! + ! land_iau_state will hold inrements, read during land_iau_mod_init type land_iau_state_type - type(land_iau_internal_data_type) :: inc1 - type(land_iau_internal_data_type) :: inc2 - real(kind=kind_phys) :: hr1 - real(kind=kind_phys) :: hr2 - real(kind=kind_phys) :: wt - real(kind=kind_phys) :: wt_normfact - real(kind=kind_phys) :: rdt + ! type(land_iau_internal_data_type) :: inc1 + ! type(land_iau_internal_data_type) :: inc2 + real(kind=kind_phys),allocatable :: stc_inc(:,:,:,:) + real(kind=kind_phys),allocatable :: slc_inc(:,:,:,:) + ! real(kind=kind_phys) :: hr1 ! moved to land_iau_external_data_type because they may vary with time + ! real(kind=kind_phys) :: hr2 + ! real(kind=kind_phys) :: wt ! moved to _control_type because they are constant + ! real(kind=kind_phys) :: wt_normfact + ! real(kind=kind_phys) :: rdt end type land_iau_state_type @@ -101,6 +106,11 @@ module land_iau_mod real(kind=kind_phys) :: fhour !< current forecast hour integer :: ntimes + + ! moved from land_iau_state_type because they are constant + real(kind=kind_phys) :: wt + real(kind=kind_phys) :: wt_normfact + real(kind=kind_phys) :: rdt end type land_iau_control_type @@ -265,7 +275,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e logical :: exists integer :: ncid, dimid, varid, status, IDIM - real(kind=kind_phys) :: dt, rdt + real(kind=kind_phys) :: dt !, rdt integer :: im, jm, km, nfiles, ntimes integer :: is, ie, js, je @@ -290,19 +300,19 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e print*, "rank is ie js je nlon nlat", Land_IAU_Control%me, is, ie, js, je, nlon, nlat + ! allocate arrays that will hold iau state allocate(Land_IAU_Data%stc_inc(nlon, nlat, km)) allocate(Land_IAU_Data%slc_inc(nlon, nlat, km)) ! allocate(Land_IAU_Data%snow_land_mask(nlon, nlat)) -! allocate arrays that will hold iau state - allocate (Land_IAU_state%inc1%stc_inc(nlon, nlat, km)) - allocate (Land_IAU_state%inc1%slc_inc(nlon, nlat, km)) - allocate (Land_IAU_state%inc2%stc_inc(nlon, nlat, km)) - allocate (Land_IAU_state%inc2%slc_inc(nlon, nlat, km)) - - Land_IAU_state%hr1=Land_IAU_Control%iaufhrs(1) - Land_IAU_state%wt = 1.0 ! IAU increment filter weights (default 1.0) - Land_IAU_state%wt_normfact = 1.0 + ! allocate (Land_IAU_state%inc1%stc_inc(nlon, nlat, km)) + ! allocate (Land_IAU_state%inc1%slc_inc(nlon, nlat, km)) + ! allocate (Land_IAU_state%inc2%stc_inc(nlon, nlat, km)) + ! allocate (Land_IAU_state%inc2%slc_inc(nlon, nlat, km)) + + Land_IAU_Data%hr1=Land_IAU_Control%iaufhrs(1) + Land_IAU_Control%wt = 1.0 ! IAU increment filter weights (default 1.0) + Land_IAU_Control%wt_normfact = 1.0 if (Land_IAU_Control%iau_filter_increments) then ! compute increment filter weights, sum to obtain normalization factor dtp=Land_IAU_Control%dtp @@ -321,13 +331,15 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e normfact = normfact + wt if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt enddo - Land_IAU_state%wt_normfact = (2*nstep+1)/normfact + Land_IAU_Control%wt_normfact = (2*nstep+1)/normfact endif ! increment files in fv3 tiles if (trim(Land_IAU_Control%iau_inc_files(1)) .eq. '' .or. Land_IAU_Control%iaufhrs(1) .lt. 0) then ! only 1 file expected - print*, "warning! in Land IAU but increment file name is empty or iaufhrs(1) is negative" - Land_IAU_Control%do_land_iau=.false. + print*, "Error! in Land IAU init: increment file name is empty or iaufhrs(1) is negative" + errmsg = "Error! in Land IAU init: increment file name is empty or iaufhrs(1) is negative" + errflg = 1 + ! Land_IAU_Control%do_land_iau=.false. return endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then @@ -365,41 +377,39 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e deallocate(idt) endif dt = (Land_IAU_Control%iau_delthrs*3600.) - rdt = 1.0/dt - Land_IAU_state%rdt = rdt - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_state%rdt + Land_IAU_Control%rdt = 1.0/dt !rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_Control%rdt ! Read all increment files at iau init time (at beginning of cycle) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) - call read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) !, wk3_stc, wk3_slc + call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%stc_inc, Land_IAU_state%slc_inc, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) ! increments already in the fv3 grid--no need for interpolation - do k = 1, npz ! do k = 1,n_soill ! - do j = 1, nlat - do i = 1, nlon - Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(1, i, j, k) - Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(1, i, j, k) - end do - enddo - enddo + ! do k = 1, npz ! do k = 1,n_soill ! + ! do j = 1, nlat + ! do i = 1, nlon + ! Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(1, i, j, k) + ! Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(1, i, j, k) + ! end do + ! enddo + ! enddo if (ntimes.EQ.1) then ! only need to get incrments once since constant forcing over window call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) endif - if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them - Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(2) - - ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) - - do k = 1, npz ! do k = 1,n_soill ! - do j = 1, nlat - do i = 1, nlon - Land_IAU_state%inc2%stc_inc(i,j,k) = wk3_stc(2, i, j, k) - Land_IAU_state%inc2%slc_inc(i,j,k) = wk3_slc(2, i, j, k) - end do - enddo - enddo + if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them + ! interpolation is now done in land_iau_mod_getiauforcing + Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(2) + ! ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) + ! do k = 1, npz ! do k = 1,n_soill ! + ! do j = 1, nlat + ! do i = 1, nlon + ! Land_IAU_state%inc2%stc_inc(i,j,k) = wk3_stc(2, i, j, k) + ! Land_IAU_state%inc2%slc_inc(i,j,k) = wk3_slc(2, i, j, k) + ! end do + ! enddo + ! enddo endif ! print*,'end of IAU init',dt,rdt @@ -419,19 +429,21 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_state errmsg = '' errflg = 0 - if (allocated (wk3_stc)) deallocate (wk3_stc) - if (allocated (wk3_slc)) deallocate (wk3_slc) - ! if (allocated (wk3_slmsk)) deallocate (wk3_slmsk) - if (allocated(Land_IAU_Data%stc_inc)) deallocate (Land_IAU_Data%stc_inc) if (allocated(Land_IAU_Data%slc_inc)) deallocate (Land_IAU_Data%slc_inc) ! if (allocated(Land_IAU_Data%snow_land_mask)) deallocate (Land_IAU_Data%snow_land_mask) - if (allocated(Land_IAU_state%inc1%stc_inc)) deallocate(Land_IAU_state%inc1%stc_inc) - if (allocated(Land_IAU_state%inc1%slc_inc)) deallocate(Land_IAU_state%inc1%slc_inc) + if (allocated(Land_IAU_state%stc_inc)) deallocate(Land_IAU_state%stc_inc) + if (allocated(Land_IAU_state%slc_inc)) deallocate(Land_IAU_state%slc_inc) + + ! if (allocated (wk3_stc)) deallocate (wk3_stc) + ! if (allocated (wk3_slc)) deallocate (wk3_slc) + ! ! if (allocated (wk3_slmsk)) deallocate (wk3_slmsk) - if (allocated(Land_IAU_state%inc2%stc_inc)) deallocate(Land_IAU_state%inc2%stc_inc) - if (allocated(Land_IAU_state%inc2%slc_inc)) deallocate(Land_IAU_state%inc2%slc_inc) + ! if (allocated(Land_IAU_state%inc1%stc_inc)) deallocate(Land_IAU_state%inc1%stc_inc) + ! if (allocated(Land_IAU_state%inc1%slc_inc)) deallocate(Land_IAU_state%inc1%slc_inc) + ! if (allocated(Land_IAU_state%inc2%stc_inc)) deallocate(Land_IAU_state%inc2%stc_inc + ! if (allocated(Land_IAU_state%inc2%slc_inc)) deallocate(Land_IAU_state%inc2%slc_inc) end subroutine land_iau_mod_finalize @@ -440,7 +452,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ implicit none type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - type(land_iau_state_type), intent(inout) :: Land_IAU_state + type(land_iau_state_type), intent(in) :: Land_IAU_State character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys) t1,t2,sx,wx,wt,dtp @@ -455,6 +467,8 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ Land_IAU_Data%in_interval=.false. if (ntimes.LE.0) then + errmsg = 'in land_iau_mod_getiauforcing, but ntimes <=0, probably no increment data. Exiting.' + errflg = 0 return endif @@ -483,10 +497,10 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ else wt = 1. endif - Land_IAU_state%wt = Land_IAU_state%wt_normfact*wt - !if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact + Land_IAU_Control%wt = Land_IAU_Control%wt_normfact*wt + !if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact else - Land_IAU_state%wt = 0. + Land_IAU_Control%wt = 0. endif endif @@ -498,8 +512,10 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 Land_IAU_Data%in_interval=.false. else - if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact,Land_IAU_state%rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact,Land_IAU_Control%rdt + endif + if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) Land_IAU_Data%in_interval=.true. endif return @@ -513,7 +529,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',Land_IAU_Control%iaufhrs(1),Land_IAU_Control%fhour,Land_IAU_Control%iaufhrs(nfiles) Land_IAU_Data%in_interval=.false. else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_state%wt/Land_IAU_state%wt_normfact,Land_IAU_state%rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact,Land_IAU_Control%rdt Land_IAU_Data%in_interval=.true. do k=ntimes, 1, -1 if (Land_IAU_Control%iaufhrs(k) > Land_IAU_Control%fhour) then @@ -521,9 +537,9 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ endif enddo ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'itnext=',itnext - if (Land_IAU_Control%fhour >= Land_IAU_state%hr2) then ! need to read in next increment file - Land_IAU_state%hr1=Land_IAU_state%hr2 - Land_IAU_state%hr2=Land_IAU_Control%iaufhrs(itnext) + if (Land_IAU_Control%fhour >= Land_IAU_Data%hr2) then ! need to read in next increment file + Land_IAU_Data%hr1=Land_IAU_Data%hr2 + Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(itnext) Land_IAU_state%inc1=Land_IAU_state%inc2 ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(Land_IAU_Control%iau_inc_files(itnext)) @@ -557,14 +573,14 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) ntimes = Land_IAU_Control%ntimes - delt = (Land_IAU_state%hr2-(Land_IAU_Control%fhour))/(Land_IAU_state%hr2-Land_IAU_state%hr1) + delt = (Land_IAU_Data%hr2-(Land_IAU_Control%fhour))/(Land_IAU_Data%hr2-Land_IAU_Data%hr1) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & - " rdt wt delt_t ", Land_IAU_state%rdt, Land_IAU_state%wt, delt + " rdt wt delt_t ", Land_IAU_Control%rdt, Land_IAU_Control%wt, delt do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%stc_inc(i,j,k))*Land_IAU_state%rdt*Land_IAU_state%wt - Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%slc_inc(i,j,k))*Land_IAU_state%rdt*Land_IAU_state%wt + Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%stc_inc(i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt + Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%slc_inc(i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt end do enddo enddo @@ -575,7 +591,7 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) implicit none type(land_iau_control_type), intent(in ) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - type(land_iau_state_type), intent(in ) :: Land_IAU_state + type(land_iau_state_type), intent(in ) :: Land_IAU_State real(kind=kind_phys) delt integer i, j, k integer :: is, ie, js, je, npz @@ -586,12 +602,12 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil ! this is only called if using 1 increment file - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',Land_IAU_state%rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',Land_IAU_Control%rdt do j = js, je do i = is, ie do k = 1, npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_state%wt*Land_IAU_state%inc1%stc_inc(i,j,k)*Land_IAU_state%rdt - Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_state%wt*Land_IAU_state%inc1%slc_inc(i,j,k)*Land_IAU_state%rdt + Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_Control%wt*Land_IAU_State%stc_inc(1,i,j,k)*Land_IAU_Control%rdt + Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_Control%wt*Land_IAU_State%slc_inc(1,i,j,k)*Land_IAU_Control%rdt end do ! Land_IAU_Data%snow_land_mask(i, j) = wk3_slmsk(1, i, j) enddo @@ -599,9 +615,10 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) end subroutine setiauforcing -subroutine read_iau_forcing_fv3(Land_IAU_Control, errmsg, errflg) +subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errflg) - type (land_iau_control_type), intent(in) :: Land_IAU_Control + type (land_iau_control_type), intent(in) :: Land_IAU_Control + real(kind=kind_phys), allocatable, intent(out) :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg From 590bb8027eabaa30624c70f64e043a5c3d7311d4 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 16 Oct 2024 16:13:03 -0400 Subject: [PATCH 122/154] modify subroutines set/update increments --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 118 +++++++++--------- 1 file changed, 60 insertions(+), 58 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 0ff126c9c..67a4b3a92 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -467,7 +467,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ Land_IAU_Data%in_interval=.false. if (ntimes.LE.0) then - errmsg = 'in land_iau_mod_getiauforcing, but ntimes <=0, probably no increment data. Exiting.' + errmsg = 'in land_iau_mod_getiauforcing, but ntimes <=0, probably no increment files. Exiting.' errflg = 0 return endif @@ -515,8 +515,8 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact,Land_IAU_Control%rdt endif - if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) Land_IAU_Data%in_interval=.true. + if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) endif return endif @@ -529,42 +529,45 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',Land_IAU_Control%iaufhrs(1),Land_IAU_Control%fhour,Land_IAU_Control%iaufhrs(nfiles) Land_IAU_Data%in_interval=.false. else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact,Land_IAU_Control%rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact,Land_IAU_Control%rdt + endif Land_IAU_Data%in_interval=.true. do k=ntimes, 1, -1 if (Land_IAU_Control%iaufhrs(k) > Land_IAU_Control%fhour) then itnext=k endif enddo -! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'itnext=',itnext + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'Land iau increments at times ', itnext-1, ' and ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) + endif if (Land_IAU_Control%fhour >= Land_IAU_Data%hr2) then ! need to read in next increment file Land_IAU_Data%hr1=Land_IAU_Data%hr2 Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(itnext) - Land_IAU_state%inc1=Land_IAU_state%inc2 - - ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'reading next lnd iau increment file',trim(Land_IAU_Control%iau_inc_files(itnext)) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'copying next lnd iau increment ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) - Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) + ! Land_IAU_state%inc1=Land_IAU_state%inc2 + ! Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) + ! Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) - call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) + call updateiauforcing(itnext, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) endif endif end subroutine land_iau_mod_getiauforcing -subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) +subroutine updateiauforcing(t2, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) implicit none + integer, intent(in) :: t2 type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data - type(land_iau_state_type), intent(inout) :: Land_IAU_state + type(land_iau_state_type), intent(in) :: Land_IAU_State real(kind=kind_phys) delt integer i,j,k - integer :: is, ie, js, je, npz + integer :: is, ie, js, je, npz, t1 integer :: ntimes + t1 = t2 - 1 is = 1 !Land_IAU_Control%isc ie = is + Land_IAU_Control%nx-1 js = 1 !Land_IAU_Control%jsc @@ -579,8 +582,8 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_state%inc1%stc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%stc_inc(i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt - Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_state%inc1%slc_inc(i,j,k) + (1.-delt)* Land_IAU_state%inc2%slc_inc(i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt + Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_State%stc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%stc_inc(t2,i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt + Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_State%slc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%slc_inc(t2,i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt end do enddo enddo @@ -738,46 +741,46 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf end subroutine read_iau_forcing_fv3 !> Calculate soil mask for land on model grid. -!! Output is 1 - soil, 2 - snow-covered, 0 - land ice, -1 not land. -!! -!! @param[in] lensfc Number of land points for this tile -!! @param[in] veg_type_landice Value of vegetion class that indicates land-ice -!! @param[in] stype Soil type -!! @param[in] swe Model snow water equivalent -!! @param[in] vtype Model vegetation type -!! @param[out] mask Land mask for increments -!! @author Clara Draper @date March 2021 -!! @author Yuan Xue: introduce stype to make the mask calculation more generic -subroutine calculate_landinc_mask(swe,vtype,stype,lensfc,veg_type_landice, mask) - - implicit none + !! Output is 1 - soil, 2 - snow-covered, 0 - land ice, -1 not land. + !! + !! @param[in] lensfc Number of land points for this tile + !! @param[in] veg_type_landice Value of vegetion class that indicates land-ice + !! @param[in] stype Soil type + !! @param[in] swe Model snow water equivalent + !! @param[in] vtype Model vegetation type + !! @param[out] mask Land mask for increments + !! @author Clara Draper @date March 2021 + !! @author Yuan Xue: introduce stype to make the mask calculation more generic + subroutine calculate_landinc_mask(swe,vtype,stype,lensfc,veg_type_landice, mask) + + implicit none - integer, intent(in) :: lensfc, veg_type_landice - real, intent(in) :: swe(lensfc) - integer, intent(in) :: vtype(lensfc),stype(lensfc) - integer, intent(out) :: mask(lensfc) + integer, intent(in) :: lensfc, veg_type_landice + real, intent(in) :: swe(lensfc) + integer, intent(in) :: vtype(lensfc),stype(lensfc) + integer, intent(out) :: mask(lensfc) - integer :: i + integer :: i - mask = -1 ! not land + mask = -1 ! not land - ! land (but not land-ice) - do i=1,lensfc - if (stype(i) .GT. 0) then - if (swe(i) .GT. 0.001) then ! snow covered land - mask(i) = 2 - else ! non-snow covered land - mask(i) = 1 + ! land (but not land-ice) + do i=1,lensfc + if (stype(i) .GT. 0) then + if (swe(i) .GT. 0.001) then ! snow covered land + mask(i) = 2 + else ! non-snow covered land + mask(i) = 1 + endif + end if ! else should work here too + if ( vtype(i) == veg_type_landice ) then ! land-ice + mask(i) = 0 endif - end if ! else should work here too - if ( vtype(i) == veg_type_landice ) then ! land-ice - mask(i) = 0 - endif - end do + end do -end subroutine calculate_landinc_mask + end subroutine calculate_landinc_mask - SUBROUTINE NETCDF_ERR(ERR, STRING, errflg, errmsg_out) + subroutine netcdf_err(ERR, STRING, errflg, errmsg_out) !-------------------------------------------------------------- ! IF AT NETCDF CALL RETURNS AN ERROR, PRINT OUT A MESSAGE @@ -804,7 +807,7 @@ SUBROUTINE NETCDF_ERR(ERR, STRING, errflg, errmsg_out) errflg = 1 return - END SUBROUTINE NETCDF_ERR + end subroutine netcdf_err subroutine get_nc_dimlen(ncid, dim_name, dim_len, errflg, errmsg_out ) integer, intent(in):: ncid @@ -840,11 +843,11 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) errflg = 0 status = nf90_inq_varid(ncid, trim(var_name), varid) - CALL NETCDF_ERR(status, 'getting varid: '//trim(var_name), errflg, errmsg_out) + call netcdf_err(status, 'getting varid: '//trim(var_name), errflg, errmsg_out) if (errflg .ne. 0) return status = nf90_get_var(ncid, varid, var_arr) ! start = (/1/), count = (/dim_len/)) - CALL NETCDF_ERR(status, 'reading var: '//trim(var_name), errflg, errmsg_out) + call netcdf_err(status, 'reading var: '//trim(var_name), errflg, errmsg_out) end subroutine get_var1d @@ -853,15 +856,14 @@ subroutine get_var3d_values(ncid, varid, is,ix, js,jy, ks,kz, var3d, status) integer, intent(in):: is, ix, js, jy, ks,kz real(kind=kind_phys), intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) integer, intent(out):: status - ! integer, dimension(3):: start, nreco - ! start(1) = is; start(2) = js; start(3) = ks - ! nreco(1) = ie - is + 1 - ! nreco(2) = je - js + 1 - ! nreco(3) = ke - ks + 1 + ! integer :: errflg + ! character(len=*) :: errmsg_out status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) start = (/is, js, ks/), count = (/ix, jy, kz/)) - ! start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) + + ! call netcdf_err(status, 'get_var3d_values', errflg, errmsg_out) + end subroutine get_var3d_values From e98f8d85a7112d975071ee3bddc9a33a3d074020 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 17 Oct 2024 08:00:26 -0400 Subject: [PATCH 123/154] default weight factors --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 67a4b3a92..65bed4d11 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -256,6 +256,10 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me ix = ix + blksz(nb) enddo + Land_IAU_Control%wt = 1.0 ! IAU increment filter weights (default 1.0) + Land_IAU_Control%wt_normfact = 1.0 + Land_IAU_Control%rdt = 0 ! 1/ dt + end subroutine land_iau_mod_set_control subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) From 89a1d0bf32f436dc0cfd415906f8ac9544864d2b Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 17 Oct 2024 08:37:50 -0400 Subject: [PATCH 124/154] move weight factors to _IAU_Data --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 57 +++++++++---------- 1 file changed, 27 insertions(+), 30 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 65bed4d11..c36013c73 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -51,8 +51,12 @@ module land_iau_mod real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. ! integer,allocatable :: snow_land_mask(:, :) ! Calculate snow soil mask at runtime from (dynamic) swe - real(kind=kind_phys) :: hr1 ! moved from _state_type - real(kind=kind_phys) :: hr2 + ! moved from land_iau_state_type + real(kind=kind_phys) :: hr1 + real(kind=kind_phys) :: hr2 + real(kind=kind_phys) :: wt + real(kind=kind_phys) :: wt_normfact + real(kind=kind_phys) :: rdt end type land_iau_external_data_type !!> \section arg_table_land_iau_state_type Argument Table @@ -64,9 +68,9 @@ module land_iau_mod ! type(land_iau_internal_data_type) :: inc2 real(kind=kind_phys),allocatable :: stc_inc(:,:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:,:) - ! real(kind=kind_phys) :: hr1 ! moved to land_iau_external_data_type because they may vary with time + ! real(kind=kind_phys) :: hr1 ! moved to land_iau_external_data_type ! real(kind=kind_phys) :: hr2 - ! real(kind=kind_phys) :: wt ! moved to _control_type because they are constant + ! real(kind=kind_phys) :: wt ! real(kind=kind_phys) :: wt_normfact ! real(kind=kind_phys) :: rdt end type land_iau_state_type @@ -106,11 +110,6 @@ module land_iau_mod real(kind=kind_phys) :: fhour !< current forecast hour integer :: ntimes - - ! moved from land_iau_state_type because they are constant - real(kind=kind_phys) :: wt - real(kind=kind_phys) :: wt_normfact - real(kind=kind_phys) :: rdt end type land_iau_control_type @@ -256,10 +255,6 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me ix = ix + blksz(nb) enddo - Land_IAU_Control%wt = 1.0 ! IAU increment filter weights (default 1.0) - Land_IAU_Control%wt_normfact = 1.0 - Land_IAU_Control%rdt = 0 ! 1/ dt - end subroutine land_iau_mod_set_control subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) @@ -315,8 +310,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e ! allocate (Land_IAU_state%inc2%slc_inc(nlon, nlat, km)) Land_IAU_Data%hr1=Land_IAU_Control%iaufhrs(1) - Land_IAU_Control%wt = 1.0 ! IAU increment filter weights (default 1.0) - Land_IAU_Control%wt_normfact = 1.0 + Land_IAU_Data%wt = 1.0 ! IAU increment filter weights (default 1.0) + Land_IAU_Data%wt_normfact = 1.0 if (Land_IAU_Control%iau_filter_increments) then ! compute increment filter weights, sum to obtain normalization factor dtp=Land_IAU_Control%dtp @@ -335,7 +330,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e normfact = normfact + wt if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt enddo - Land_IAU_Control%wt_normfact = (2*nstep+1)/normfact + Land_IAU_Data%wt_normfact = (2*nstep+1)/normfact endif ! increment files in fv3 tiles @@ -381,8 +376,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e deallocate(idt) endif dt = (Land_IAU_Control%iau_delthrs*3600.) - Land_IAU_Control%rdt = 1.0/dt !rdt - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_Control%rdt + Land_IAU_Data%rdt = 1.0/dt !rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_Data%rdt ! Read all increment files at iau init time (at beginning of cycle) ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) @@ -454,7 +449,7 @@ end subroutine land_iau_mod_finalize subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) implicit none - type (land_iau_control_type), intent(in) :: Land_IAU_Control + type(land_iau_control_type), intent(inout) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data type(land_iau_state_type), intent(in) :: Land_IAU_State character(len=*), intent(out) :: errmsg @@ -501,10 +496,10 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ else wt = 1. endif - Land_IAU_Control%wt = Land_IAU_Control%wt_normfact*wt - !if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact + Land_IAU_Data%wt = Land_IAU_Data%wt_normfact*wt + !if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact else - Land_IAU_Control%wt = 0. + Land_IAU_Data%wt = 0. endif endif @@ -517,7 +512,8 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ Land_IAU_Data%in_interval=.false. else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact,Land_IAU_Control%rdt + print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ', & + t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact,Land_IAU_Data%rdt endif Land_IAU_Data%in_interval=.true. if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) @@ -534,7 +530,8 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ Land_IAU_Data%in_interval=.false. else if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ',t1,Land_IAU_Control%fhour,t2,Land_IAU_Control%wt/Land_IAU_Control%wt_normfact,Land_IAU_Control%rdt + print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ', & + t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact,Land_IAU_Data%rdt endif Land_IAU_Data%in_interval=.true. do k=ntimes, 1, -1 @@ -582,12 +579,12 @@ subroutine updateiauforcing(t2, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) delt = (Land_IAU_Data%hr2-(Land_IAU_Control%fhour))/(Land_IAU_Data%hr2-Land_IAU_Data%hr1) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & - " rdt wt delt_t ", Land_IAU_Control%rdt, Land_IAU_Control%wt, delt + " rdt wt delt_t ", Land_IAU_Data%rdt, Land_IAU_Data%wt, delt do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_State%stc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%stc_inc(t2,i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt - Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_State%slc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%slc_inc(t2,i,j,k))*Land_IAU_Control%rdt*Land_IAU_Control%wt + Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_State%stc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%stc_inc(t2,i,j,k))*Land_IAU_Data%rdt*Land_IAU_Data%wt + Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_State%slc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%slc_inc(t2,i,j,k))*Land_IAU_Data%rdt*Land_IAU_Data%wt end do enddo enddo @@ -609,12 +606,12 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil ! this is only called if using 1 increment file - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',Land_IAU_Control%rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',Land_IAU_Data%rdt do j = js, je do i = is, ie do k = 1, npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_Control%wt*Land_IAU_State%stc_inc(1,i,j,k)*Land_IAU_Control%rdt - Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_Control%wt*Land_IAU_State%slc_inc(1,i,j,k)*Land_IAU_Control%rdt + Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_Data%wt*Land_IAU_State%stc_inc(1,i,j,k)*Land_IAU_Data%rdt + Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_Data%wt*Land_IAU_State%slc_inc(1,i,j,k)*Land_IAU_Data%rdt end do ! Land_IAU_Data%snow_land_mask(i, j) = wk3_slmsk(1, i, j) enddo From fa3591e321a74110b01b9ec07fdf586f3ee82e97 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Thu, 17 Oct 2024 08:54:32 -0400 Subject: [PATCH 125/154] update noahmpdrv meta --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 19 +-- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 146 ++---------------- 2 files changed, 24 insertions(+), 141 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 497f81570..3060cc1ed 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -42,8 +42,8 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, & nlunit, pores, resid, & do_mynnsfclay,do_mynnedmf, & errmsg, errflg, & - Land_IAU_Control, Land_IAU_Data, Land_IAU_state) - ! , me, mpi_root, & + Land_IAU_Control, Land_IAU_Data, Land_IAU_state, & + me, mpi_root) ! fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, tile_num, & ! nblks, blksz, xlon, xlat, & ! lsoil, lsnow_lsm, dtp, fhour) @@ -54,26 +54,27 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, & use noahmp_tables implicit none - + + integer, intent(in) :: me ! mpi_rank + integer, intent(in) :: mpi_root ! = GFS_Control%master integer, intent(in) :: lsm - integer, intent(in) :: lsm_noahmp + integer, intent(in) :: lsm_noahmp integer, intent(in) :: isot, ivegsrc, nlunit real (kind=kind_phys), dimension(:), intent(out) :: pores, resid logical, intent(in) :: do_mynnsfclay logical, intent(in) :: do_mynnedmf character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! land iau mod - + + ! land iau mod ! Land IAU Control holds settings' information, maily read from namelist (e.g., block of global domain that belongs to a process , ! whether to do IAU increment at this time step, time step informatoin, etc) type(land_iau_control_type), intent(inout) :: Land_IAU_Control ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data !(number of blocks):each proc holds nblks - type(land_iau_state_type), intent(inout) :: Land_IAU_state + type(land_iau_state_type), intent(inout) :: Land_IAU_state ! holds data read from file (before interpolation) + - ! integer, intent(in) :: me ! mpi_rank - ! integer, intent(in) :: mpi_root ! = GFS_Control%master ! character(*), intent(in) :: fn_nml ! character(len=:), pointer, intent(in), dimension(:) :: input_nml_file ! integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index a09f257fd..349d5bb4e 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -10,6 +10,20 @@ [ccpp-arg-table] name = noahmpdrv_init type = scheme +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpi_root] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in [lsm] standard_name = control_for_land_surface_scheme long_name = flag for land surface model @@ -24,13 +38,6 @@ dimensions = () type = integer intent = in -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in [isot] standard_name = control_for_soil_type_dataset long_name = soil type dataset choice @@ -118,131 +125,6 @@ dimensions = () type = land_iau_state_type intent = inout -[mpi_root] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in -[fn_nml] - standard_name = filename_of_namelist - long_name = namelist filename - units = none - type = character - dimensions = () - kind = len=* - intent = in -[input_nml_file] - standard_name = filename_of_internal_namelist - long_name = namelist filename for internal file reads - units = none - type = character - dimensions = (ccpp_constant_one:number_of_lines_in_internal_namelist) - kind = len=256 - intent = in -[isc] - standard_name = starting_x_index_for_this_mpi_rank - long_name = starting index in the x direction for this MPI rank - units = count - dimensions = () - type = integer - intent = in -[jsc] - standard_name = starting_y_index_for_this_mpi_rank - long_name = starting index in the y direction for this MPI rank - units = count - dimensions = () - type = integer - intent = in -[ncols] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nx] - standard_name = number_of_points_in_x_direction_for_this_mpi_rank - long_name = number of points in the x direction - units = count - dimensions = () - type = integer - intent = in -[ny] - standard_name = number_of_points_in_y_direction_for_this_mpi_rank - long_name = number of points in the y direction - units = count - dimensions = () - type = integer - intent = in -[tile_num] - standard_name = index_of_cubed_sphere_tile - long_name = tile number - units = none - dimensions = () - type = integer - intent = in -[nblks] - standard_name = ccpp_block_count - long_name = for explicit data blocking: number of blocks - units = count - dimensions = () - type = integer - intent = in -[blksz] - standard_name = ccpp_block_sizes - long_name = for explicit data blocking: block sizes of all blocks - units = count - dimensions = (ccpp_constant_one:ccpp_block_count) - type = integer - intent = in -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[xlat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in -[lsoil] - standard_name = vertical_dimension_of_soil - long_name = number of soil layers - units = count - dimensions = () - type = integer - intent = in -[lsnow_lsm] - standard_name = vertical_dimension_of_surface_snow - long_name = maximum number of snow layers for land surface model - units = count - dimensions = () - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in ######################################################################## [ccpp-arg-table] From a9c44e65d5d342dbf8f04ce8b0b1b7dfc5bcb42d Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 20 Oct 2024 09:35:53 -0400 Subject: [PATCH 126/154] fix time interval bounds --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 37 +++++++++++-------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index c36013c73..5fa8235d6 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -508,14 +508,14 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ !8.8.24 TBCL: noahmpdrv_timestep_init doesn't get visited at t1, so include t2 ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then -! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 + ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 Land_IAU_Data%in_interval=.false. else + Land_IAU_Data%in_interval=.true. if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ', & t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact,Land_IAU_Data%rdt - endif - Land_IAU_Data%in_interval=.true. + endif if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) endif return @@ -529,26 +529,28 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',Land_IAU_Control%iaufhrs(1),Land_IAU_Control%fhour,Land_IAU_Control%iaufhrs(nfiles) Land_IAU_Data%in_interval=.false. else + Land_IAU_Data%in_interval=.true. if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ', & t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact,Land_IAU_Data%rdt - endif - Land_IAU_Data%in_interval=.true. + endif do k=ntimes, 1, -1 - if (Land_IAU_Control%iaufhrs(k) > Land_IAU_Control%fhour) then + if (Land_IAU_Control%iaufhrs(k) >= Land_IAU_Control%fhour) then itnext=k endif enddo - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'Land iau increments at times ', itnext-1, ' and ', itnext !trim(Land_IAU_Control%iau_inc_files(itnext)) - endif - if (Land_IAU_Control%fhour >= Land_IAU_Data%hr2) then ! need to read in next increment file + + if (Land_IAU_Control%fhour > Land_IAU_Data%hr2) then ! need to read in next increment file Land_IAU_Data%hr1=Land_IAU_Data%hr2 Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(itnext) ! Land_IAU_state%inc1=Land_IAU_state%inc2 ! Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) ! Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'Land iau increments at times ', itnext-1, ' and ', itnext, & + ' hr1, hr2 = ', Land_IAU_Data%hr1, Land_IAU_Data%hr2 + endif ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) call updateiauforcing(itnext, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) endif @@ -563,7 +565,7 @@ subroutine updateiauforcing(t2, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data type(land_iau_state_type), intent(in) :: Land_IAU_State - real(kind=kind_phys) delt + real(kind=kind_phys) delt_t integer i,j,k integer :: is, ie, js, je, npz, t1 integer :: ntimes @@ -577,14 +579,17 @@ subroutine updateiauforcing(t2, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) ntimes = Land_IAU_Control%ntimes - delt = (Land_IAU_Data%hr2-(Land_IAU_Control%fhour))/(Land_IAU_Data%hr2-Land_IAU_Data%hr1) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau updateiauforcing ntimes ',ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & - " rdt wt delt_t ", Land_IAU_Data%rdt, Land_IAU_Data%wt, delt + delt_t = (Land_IAU_Data%hr2-(Land_IAU_Control%fhour))/(Land_IAU_Data%hr2-Land_IAU_Data%hr1) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'in land_iau updateiauforcing ntimes ', & + ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & + " rdt wt delt_t ", Land_IAU_Data%rdt, Land_IAU_Data%wt, delt_t + endif do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! - Land_IAU_Data%stc_inc(i,j,k) =(delt*Land_IAU_State%stc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%stc_inc(t2,i,j,k))*Land_IAU_Data%rdt*Land_IAU_Data%wt - Land_IAU_Data%slc_inc(i,j,k) =(delt*Land_IAU_State%slc_inc(t1,i,j,k) + (1.-delt)* Land_IAU_State%slc_inc(t2,i,j,k))*Land_IAU_Data%rdt*Land_IAU_Data%wt + Land_IAU_Data%stc_inc(i,j,k) =(delt_t*Land_IAU_State%stc_inc(t1,i,j,k) + (1.-delt_t)* Land_IAU_State%stc_inc(t2,i,j,k))*Land_IAU_Data%rdt*Land_IAU_Data%wt + Land_IAU_Data%slc_inc(i,j,k) =(delt_t*Land_IAU_State%slc_inc(t1,i,j,k) + (1.-delt_t)* Land_IAU_State%slc_inc(t2,i,j,k))*Land_IAU_Data%rdt*Land_IAU_Data%wt end do enddo enddo From 28dc544001a6ee7650ac8fb262376fda567b94dd Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 20 Oct 2024 10:52:21 -0400 Subject: [PATCH 127/154] handle valid time range better --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 38 ++++++++++++------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 5fa8235d6..9a0c62dea 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -57,6 +57,8 @@ module land_iau_mod real(kind=kind_phys) :: wt real(kind=kind_phys) :: wt_normfact real(kind=kind_phys) :: rdt + ! track the increment steps here + integer :: itnext end type land_iau_external_data_type !!> \section arg_table_land_iau_state_type Argument Table @@ -359,6 +361,10 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau_init: ntimes = ',ntimes Land_IAU_Control%ntimes = ntimes if (ntimes < 1) then + print*, "Error! in Land IAU init: ntimes < 1" + errmsg = "Error! in Land IAU init: ntimes < 1" + errflg = 1 + ! Land_IAU_Control%do_land_iau=.false. return endif if (ntimes > 1) then @@ -396,10 +402,12 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e if (ntimes.EQ.1) then ! only need to get incrments once since constant forcing over window call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) + Land_IAU_Data%itnext = 0 endif if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them ! interpolation is now done in land_iau_mod_getiauforcing Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(2) + Land_IAU_Data%itnext = 2 ! ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) ! do k = 1, npz ! do k = 1,n_soill ! ! do j = 1, nlat @@ -455,7 +463,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys) t1,t2,sx,wx,wt,dtp - integer n,i,j,k,kstep,nstep,itnext + integer n,i,j,k,kstep,nstep !,itnext integer :: ntimes ! Initialize CCPP error handling variables @@ -522,7 +530,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ endif if (ntimes > 1) then - itnext=2 + !itnext=2 !Land_IAU_Data%itnext = 2 !8.8.24 TBCL: noahmpdrv_timestep_init doesn't get visited at t1, so include t2 ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then @@ -534,34 +542,34 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ', & t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact,Land_IAU_Data%rdt endif - do k=ntimes, 1, -1 - if (Land_IAU_Control%iaufhrs(k) >= Land_IAU_Control%fhour) then - itnext=k - endif - enddo - + ! do k=ntimes, 1, -1 + ! if (Land_IAU_Control%iaufhrs(k) >= Land_IAU_Control%fhour) then + ! itnext=k + ! endif + ! enddo if (Land_IAU_Control%fhour > Land_IAU_Data%hr2) then ! need to read in next increment file + Land_IAU_Data%itnext = Land_IAU_Data%itnext + 1 Land_IAU_Data%hr1=Land_IAU_Data%hr2 - Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(itnext) + Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(Land_IAU_Data%itnext) ! Land_IAU_state%inc1=Land_IAU_state%inc2 ! Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) ! Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'Land iau increments at times ', itnext-1, ' and ', itnext, & + print *,'Land iau increments at times ', Land_IAU_Data%itnext-1, ' and ', Land_IAU_Data%itnext, & ' hr1, hr2 = ', Land_IAU_Data%hr1, Land_IAU_Data%hr2 endif ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) - call updateiauforcing(itnext, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) + call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) endif endif end subroutine land_iau_mod_getiauforcing -subroutine updateiauforcing(t2, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) +subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) implicit none - integer, intent(in) :: t2 + type (land_iau_control_type), intent(in) :: Land_IAU_Control type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data type(land_iau_state_type), intent(in) :: Land_IAU_State @@ -569,7 +577,9 @@ subroutine updateiauforcing(t2, Land_IAU_Control, Land_IAU_Data, Land_IAU_State) integer i,j,k integer :: is, ie, js, je, npz, t1 integer :: ntimes - + integer :: t2 + + t2 = Land_IAU_Data%itnext t1 = t2 - 1 is = 1 !Land_IAU_Control%isc ie = is + Land_IAU_Control%nx-1 From 7cac448ffb60ab00aaca991ce207ff84c38b3bac Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Sun, 20 Oct 2024 12:26:05 -0400 Subject: [PATCH 128/154] minor edit --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 3060cc1ed..a680fc885 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -252,7 +252,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !> update land states with iau increments if (.not. Land_IAU_Data%in_interval) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "current time step not in IAU interval " + print*, "noahmpdrv_timestep_init: current time step not in Land iau interval " endif return endif From 2097bd01b25b8b03cbb47d94aeb309624df8c250 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 21 Oct 2024 10:44:02 -0400 Subject: [PATCH 129/154] do netcdf error handling inside get_var3d_values --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 48 ++++++++++++------- 1 file changed, 31 insertions(+), 17 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 9a0c62dea..7a87c8332 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -706,9 +706,9 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf if (status == nf90_noerr) then !if (ierr == 0) then do it = 1, n_t ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) - call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, wk3_stc(it,:, :, i), status) - ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, stc_inc_out(it,:, :, i), status) - call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) + call get_var3d_values(ncid, varid, trim(stc_vars(i)), Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & + it, 1, wk3_stc(it,:, :, i), status, errflg, errmsg) + ! call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return enddo else @@ -722,9 +722,9 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) if (status == nf90_noerr) then !if (ierr == 0) then do it = 1, n_t - call get_var3d_values(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, it, 1, wk3_slc(it, :, :, i), status) - ! call get_var3d_values(ncid, varid, 1,im, jbeg,jend, it, 1, slc_inc_out(it, :, :, i), status) - call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg) + call get_var3d_values(ncid, varid, trim(slc_vars(i)), Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & + it, 1, wk3_slc(it, :, :, i), status, errflg, errmsg) + ! call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return end do else @@ -737,9 +737,9 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf ! status = nf90_inq_varid(ncid, trim(slsn_mask), varid) ! if (status == nf90_noerr) then !if (ierr == 0) then ! do it = 1, n_t - ! call get_var3d_values_int(ncid, varid, Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & - ! it, 1, wk3_slmsk(it, :, :), status) - ! call netcdf_err(status, 'reading var: '//trim(slsn_mask), errflg, errmsg) + ! call get_var3d_values_int(ncid, varid, trim(slsn_mask), Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & + ! it, 1, wk3_slmsk(it, :, :), status, errflg, errmsg) + ! ! call netcdf_err(status, 'reading var: '//trim(slsn_mask), errflg, errmsg) ! if (errflg .ne. 0) return ! enddo ! else @@ -747,13 +747,13 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf ! 'assuming value of 1 for all grid cells. Please make sure the increment files have soil snow mask var' ! wk3_slmsk(:, :, :) = 1 ! endif + + !8.3.24 set too small increments to zero + where(abs(wk3_stc) < Land_IAU_Control%min_T_increment) wk3_stc = 0.0 status =nf90_close(ncid) call netcdf_err(status, 'closing file '//trim(fname), errflg, errmsg) - !8.3.24 set too small increments to zero - where(abs(wk3_stc) < Land_IAU_Control%min_T_increment) wk3_stc = 0.0 - end subroutine read_iau_forcing_fv3 !> Calculate soil mask for land on model grid. @@ -867,31 +867,45 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) end subroutine get_var1d - subroutine get_var3d_values(ncid, varid, is,ix, js,jy, ks,kz, var3d, status) + subroutine get_var3d_values(ncid, varid, var_name, is,ix, js,jy, ks,kz, var3d, status, errflg, errmsg_out) integer, intent(in):: ncid, varid integer, intent(in):: is, ix, js, jy, ks,kz + character(len=*), intent(in):: var_name real(kind=kind_phys), intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) integer, intent(out):: status - ! integer :: errflg - ! character(len=*) :: errmsg_out + integer :: errflg + character(len=*) :: errmsg_out + + !Errors messages handled through CCPP error handling variables + errmsg_out = '' + errflg = 0 status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) start = (/is, js, ks/), count = (/ix, jy, kz/)) - ! call netcdf_err(status, 'get_var3d_values', errflg, errmsg_out) + call netcdf_err(status, 'get_var3d_values '//trim(var_name), errflg, errmsg_out) end subroutine get_var3d_values - subroutine get_var3d_values_int(ncid, varid, is,ix, js,jy, ks,kz, var3d, status) + subroutine get_var3d_values_int(ncid, varid, var_name, is,ix, js,jy, ks,kz, var3d, status, errflg, errmsg_out) integer, intent(in):: ncid, varid integer, intent(in):: is, ix, js, jy, ks,kz + character(len=*), intent(in):: var_name integer, intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) integer, intent(out):: status + integer :: errflg + character(len=*) :: errmsg_out + + !Errors messages handled through CCPP error handling variables + errmsg_out = '' + errflg = 0 status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) start = (/is, js, ks/), count = (/ix, jy, kz/)) ! start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) + + call netcdf_err(status, 'get_var3d_values_int '//trim(var_name), errflg, errmsg_out) end subroutine get_var3d_values_int From 403312a8b0e73bad455413beb01786a919e1e781 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 21 Oct 2024 10:50:56 -0400 Subject: [PATCH 130/154] error handling for read_iau_forcing_fv3 --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 7a87c8332..981d6dca1 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -389,6 +389,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%stc_inc, Land_IAU_state%slc_inc, errmsg, errflg) !, wk3_stc, wk3_slc ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) + if (errflg .ne. 0) return ! increments already in the fv3 grid--no need for interpolation ! do k = 1, npz ! do k = 1,n_soill ! From df8ed4821c2e6e0024a6820119243c4b529377bc Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 21 Oct 2024 13:52:15 -0400 Subject: [PATCH 131/154] remove redeclared constants in _timestep_int --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 26 +++++++++++-------- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 24 ++++++++++++++++- 2 files changed, 38 insertions(+), 12 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index a680fc885..846ceff57 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -160,7 +160,8 @@ end subroutine noahmpdrv_init subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !me, mpi_root, isot, ivegsrc, soiltyp, vegtype, weasd, & land_iau_control, land_iau_data, land_iau_state, & - stc, slc, smc, errmsg, errflg) ! smc, t2mmp, q2mp, + stc, slc, smc, errmsg, errflg, & ! smc, t2mmp, q2mp, + con_g, con_t0c, con_hfus) use machine, only: kind_phys use namelist_soilveg @@ -189,9 +190,11 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & real(kind=kind_phys), dimension(:,:) , intent(inout) :: smc ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: con_g ! grav + real(kind=kind_phys), intent(in) :: con_t0c ! tfreez + real(kind=kind_phys), intent(in) :: con_hfus ! hfus - ! IAU update - + ! IAU update real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat, slc_inc_flat real(kind=kind_phys), dimension(km) :: dz ! layer thickness ! real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) @@ -215,9 +218,10 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! real (kind=kind_phys), dimension(max_soiltyp) :: maxsmc, bb, satpsi ! real, dimension(30) :: maxsmc, bb, satpsi - real(kind=kind_phys), parameter :: tfreez=273.16 !< con_t0c in physcons - real(kind=kind_phys), parameter :: hfus=0.3336e06 !< latent heat of fusion(j/kg) - real(kind=kind_phys), parameter :: grav=9.80616 !< gravity accel.(m/s2) + ! real(kind=kind_phys), parameter :: tfreez=273.16 !< con_t0c in physcons + ! real(kind=kind_phys), parameter :: hfus=0.3336e06 !< latent heat of fusion(j/kg) con_hfus + ! real(kind=kind_phys), parameter :: con_g !grav=9.80616 !< gravity accel.(m/s2) + real(kind=kind_phys) :: smp !< for computing supercooled water real(kind=kind_phys) :: hc_incr @@ -318,7 +322,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & soil_freeze=.false. soil_ice=.false. do k = 1, lsoil_incr ! k = 1, km - if ( stc(ij,k) < tfreez) soil_freeze=.true. + if ( stc(ij,k) < con_t0c) soil_freeze=.true. if ( smc(ij,k) - slc(ij,k) > 0.001 ) soil_ice=.true. if (Land_IAU_Control%upd_stc) then @@ -329,7 +333,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & endif endif - if ( (stc(ij,k) < tfreez) .and. (.not. soil_freeze) .and. (k==1) ) nfrozen_upd = nfrozen_upd + 1 + if ( (stc(ij,k) < con_t0c) .and. (.not. soil_freeze) .and. (k==1) ) nfrozen_upd = nfrozen_upd + 1 ! do not do updates if this layer or any above is frozen if ( (.not. soil_freeze ) .and. (.not. soil_ice ) ) then @@ -383,14 +387,14 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !case 1: frz ==> frz, recalculate slc, smc remains !case 2: unfrz ==> frz, recalculate slc, smc remains !both cases are considered in the following if case - if (stc(i,l) .LT. tfreez )then + if (stc(i,l) .LT. con_t0c )then !recompute supercool liquid water,smc_anl remain unchanged - smp = hfus*(tfreez-stc(i,l))/(grav*stc(i,l)) !(m) + smp = con_hfus*(con_t0c-stc(i,l))/(con_g*stc(i,l)) !(m) slc_new=maxsmc(soiltype)*(smp/satpsi(soiltype))**(-1./bb(soiltype)) slc(i,l) = max( min( slc_new, smc(i,l)), 0.0 ) endif !case 3: frz ==> unfrz, melt all soil ice (if any) - if (stc(i,l) .GT. tfreez )then !do not rely on stc_bck + if (stc(i,l) .GT. con_t0c )then !do not rely on stc_bck slc(i,l)=smc(i,l) endif enddo diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 349d5bb4e..c6cce3f53 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -263,7 +263,29 @@ dimensions = () type = integer intent = out - +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + ####################################################################### [ccpp-arg-table] name = noahmpdrv_finalize From 4c78f46ad26345a9b8e6b0e7f7868c34ccb68c2a Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Mon, 21 Oct 2024 14:17:04 -0400 Subject: [PATCH 132/154] fix compilation errors --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index c6cce3f53..256f47574 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -278,6 +278,7 @@ dimensions = () type = real kind = kind_phys + intent = in [con_hfus] standard_name = latent_heat_of_fusion_of_water_at_0C long_name = latent heat of fusion @@ -285,7 +286,8 @@ dimensions = () type = real kind = kind_phys - + intent = in + ####################################################################### [ccpp-arg-table] name = noahmpdrv_finalize From f25bf2db47247cb55f7d36ef8941c1059ef66009 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 29 Oct 2024 08:20:51 -0400 Subject: [PATCH 133/154] clean up, remove debug print outs --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 176 ++++-------------- 1 file changed, 37 insertions(+), 139 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 981d6dca1..4f51f2ac6 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -30,19 +30,6 @@ module land_iau_mod private - !GJF: These variables may need to get moved to the host model and passed in, depending on their use. - ! They are currently allocated/initialized in the CCPP init stage and are used throughout the - ! simulation in the timestep_init phase. Since this module memory exists on the heap, this - ! may cause issues for models that have multiple CCPP instances in one executable if the data - ! differs between CCPP instances. -! real(kind=kind_phys), allocatable :: wk3_stc(:, :, :, :), wk3_slc(:, :, :, :) -! integer, allocatable :: wk3_slmsk(:, :, :) ! Calculate snow soil mask at runtime from (dynamic) swe - -! type land_iau_internal_data_type -! real(kind=kind_phys),allocatable :: stc_inc(:,:,:) -! real(kind=kind_phys),allocatable :: slc_inc(:,:,:) -! end type land_iau_internal_data_type - !> \section arg_table_land_iau_external_data_type Argument Table !! \htmlinclude land_iau_external_data_type.html !! @@ -64,17 +51,10 @@ module land_iau_mod !!> \section arg_table_land_iau_state_type Argument Table !! \htmlinclude land_iau_state_type.html !! - ! land_iau_state will hold inrements, read during land_iau_mod_init + ! land_iau_state will hold 'raw' (not interpolated) inrements, read during land_iau_mod_init type land_iau_state_type - ! type(land_iau_internal_data_type) :: inc1 - ! type(land_iau_internal_data_type) :: inc2 real(kind=kind_phys),allocatable :: stc_inc(:,:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:,:) - ! real(kind=kind_phys) :: hr1 ! moved to land_iau_external_data_type - ! real(kind=kind_phys) :: hr2 - ! real(kind=kind_phys) :: wt - ! real(kind=kind_phys) :: wt_normfact - ! real(kind=kind_phys) :: rdt end type land_iau_state_type @@ -92,7 +72,6 @@ module land_iau_mod integer, allocatable :: blk_strt_indx(:) integer :: lsoil !< number of soil layers - ! this is the max dim (TBC: check it is consitent for noahmpdrv) integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model logical :: do_land_iau real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours @@ -157,7 +136,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me logical :: land_iau_do_stcsmc_adjustment = .false. real(kind=kind_phys) :: land_iau_min_T_increment = 0.0001 - NAMELIST /land_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & !land_iau_gaussian_inc_file, & + NAMELIST /land_iau_nml/ do_land_iau, land_iau_delthrs, land_iau_inc_files, land_iau_fhrs, & land_iau_filter_increments, & lsoil_incr, land_iau_upd_stc, land_iau_upd_slc, land_iau_do_stcsmc_adjustment, land_iau_min_T_increment @@ -173,21 +152,18 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me input_nml_file => input_nml_file_i read(input_nml_file, nml=land_iau_nml, ERR=888, END=999, iostat=ios) #else - ! if (file_exist(fn_nml)) then inquire (file=trim(fn_nml), exist=exists) ! TBCL: this maybe be replaced by nlunit passed from ccpp - if (.not. exists) then - write(6,*) 'lnd_iau_mod_set_control: namelist file ',trim(fn_nml),' does not exist' + if (.not. exists) then errmsg = 'lnd_iau_mod_set_control: namelist file '//trim(fn_nml)//' does not exist' errflg = 1 return else - Land_IAU_Control%fn_nml = trim(fn_nml) ! maynot need this + Land_IAU_Control%fn_nml = trim(fn_nml) open (unit=nlunit, file=trim(fn_nml), action='READ', status='OLD', iostat=ios, iomsg=ioerrmsg) rewind(nlunit) read (nlunit, nml=land_iau_nml, ERR=888, END=999, iostat=ios) close (nlunit) - if (ios /= 0) then - write(6,*) trim(ioerrmsg) + if (ios /= 0) then errmsg = 'lnd_iau_mod_set_control: error reading namelist file '//trim(fn_nml) & // 'the error message from file handler:' //trim(ioerrmsg) errflg = 1 @@ -197,10 +173,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me #endif 888 if (ios /= 0) then ! .and. ios /= iostat_end) then - write(iosstr, '(I0)') ios - if (me == mpi_root) then - write(6,*) 'lnd_iau_mod_set_control: I/O error code '//trim(iosstr)//' at land_iau namelist read' - endif + write(iosstr, '(I0)') ios errmsg = 'lnd_iau_mod_set_control: I/O error code '//trim(iosstr)//' at land_iau namelist read' errflg = 1 return @@ -248,8 +221,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me allocate(Land_IAU_Control%blk_strt_indx(nblks)) ! Land_IAU_Control%blk_strt_indx: start index of each block, for flattened (ncol=nx*ny) arrays - ! required in noahmpdriv_run to get subsection of the stc array for each - ! proces/thread + ! required in noahmpdriv_run to get subsection of the stc array for each proces/thread ix = 1 do nb=1, nblks Land_IAU_Control%blksz(nb) = blksz(nb) @@ -296,20 +268,11 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e je = js + Land_IAU_Control%ny-1 nlon = Land_IAU_Control%nx nlat = Land_IAU_Control%ny - !nblks = Land_IAU_Control%nblks - !blksz = Land_IAU_Control%blksz(1) - - print*, "rank is ie js je nlon nlat", Land_IAU_Control%me, is, ie, js, je, nlon, nlat ! allocate arrays that will hold iau state allocate(Land_IAU_Data%stc_inc(nlon, nlat, km)) allocate(Land_IAU_Data%slc_inc(nlon, nlat, km)) ! allocate(Land_IAU_Data%snow_land_mask(nlon, nlat)) - - ! allocate (Land_IAU_state%inc1%stc_inc(nlon, nlat, km)) - ! allocate (Land_IAU_state%inc1%slc_inc(nlon, nlat, km)) - ! allocate (Land_IAU_state%inc2%stc_inc(nlon, nlat, km)) - ! allocate (Land_IAU_state%inc2%slc_inc(nlon, nlat, km)) Land_IAU_Data%hr1=Land_IAU_Control%iaufhrs(1) Land_IAU_Data%wt = 1.0 ! IAU increment filter weights (default 1.0) @@ -335,20 +298,22 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e Land_IAU_Data%wt_normfact = (2*nstep+1)/normfact endif - ! increment files in fv3 tiles + ! increment files are in fv3 tiles if (trim(Land_IAU_Control%iau_inc_files(1)) .eq. '' .or. Land_IAU_Control%iaufhrs(1) .lt. 0) then ! only 1 file expected - print*, "Error! in Land IAU init: increment file name is empty or iaufhrs(1) is negative" errmsg = "Error! in Land IAU init: increment file name is empty or iaufhrs(1) is negative" errflg = 1 ! Land_IAU_Control%do_land_iau=.false. return endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,"land_iau_init: Increment file ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) + print*,"Land_iau_init: Increment file name: ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) endif ! determine number of valid forecast hours -!TODO: can read this from the increment file ("Time" dim) + ! is read from the increment file ("Time" dim) + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *, " Number of forecast times (in hours) with valid increment values" + endif ntimesall = size(Land_IAU_Control%iaufhrs) ntimes = 0 do k=1,ntimesall @@ -358,10 +323,9 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e endif ntimes = ntimes + 1 enddo - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau_init: ntimes = ',ntimes + Land_IAU_Control%ntimes = ntimes if (ntimes < 1) then - print*, "Error! in Land IAU init: ntimes < 1" errmsg = "Error! in Land IAU init: ntimes < 1" errflg = 1 ! Land_IAU_Control%do_land_iau=.false. @@ -372,8 +336,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e idt = Land_IAU_Control%iaufhrs(2:ntimes)-Land_IAU_Control%iaufhrs(1:ntimes-1) do k=1,ntimes-1 if (idt(k) .ne. Land_IAU_Control%iaufhrs(2)-Land_IAU_Control%iaufhrs(1)) then - print *,'in land_iau_init: forecast intervals in iaufhrs must be constant' - ! call mpp_error (FATAL,' forecast intervals in iaufhrs must be constant') errmsg = 'Fatal error in land_iau_init. forecast intervals in iaufhrs must be constant' errflg = 1 return @@ -383,43 +345,24 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e endif dt = (Land_IAU_Control%iau_delthrs*3600.) Land_IAU_Data%rdt = 1.0/dt !rdt - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'land_iau interval, rdt',Land_IAU_Control%iau_delthrs,Land_IAU_Data%rdt - + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'Land_iau_init: IAU interval(dt), rdt (1/dt)',Land_IAU_Control%iau_delthrs,Land_IAU_Data%rdt + endif ! Read all increment files at iau init time (at beginning of cycle) - ! allocate (wk3_stc(n_t, 1:im,jbeg:jend, 1:km)) + ! increments are already in the fv3 grid--no need for interpolation call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%stc_inc, Land_IAU_state%slc_inc, errmsg, errflg) !, wk3_stc, wk3_slc - ! call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%inc1%stc_inc, Land_IAU_state%inc1%slc_inc, errmsg, errflg) if (errflg .ne. 0) return - - ! increments already in the fv3 grid--no need for interpolation - ! do k = 1, npz ! do k = 1,n_soill ! - ! do j = 1, nlat - ! do i = 1, nlon - ! Land_IAU_state%inc1%stc_inc(i,j,k) = wk3_stc(1, i, j, k) - ! Land_IAU_state%inc1%slc_inc(i,j,k) = wk3_slc(1, i, j, k) - ! end do - ! enddo - ! enddo if (ntimes.EQ.1) then ! only need to get incrments once since constant forcing over window call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) Land_IAU_Data%itnext = 0 endif - if (ntimes.GT.1) then !have multiple files, but only need 2 at a time and interpoalte for timesteps between them - ! interpolation is now done in land_iau_mod_getiauforcing + if (ntimes.GT.1) then !have increments at multiple forecast hours, + ! but only need 2 at a time and interpoalte for timesteps between them + ! interpolation is done in land_iau_mod_getiauforcing Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(2) Land_IAU_Data%itnext = 2 - ! ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(1, :, :) - ! do k = 1, npz ! do k = 1,n_soill ! - ! do j = 1, nlat - ! do i = 1, nlon - ! Land_IAU_state%inc2%stc_inc(i,j,k) = wk3_stc(2, i, j, k) - ! Land_IAU_state%inc2%slc_inc(i,j,k) = wk3_slc(2, i, j, k) - ! end do - ! enddo - ! enddo endif -! print*,'end of IAU init',dt,rdt end subroutine land_iau_mod_init @@ -444,15 +387,6 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_state if (allocated(Land_IAU_state%stc_inc)) deallocate(Land_IAU_state%stc_inc) if (allocated(Land_IAU_state%slc_inc)) deallocate(Land_IAU_state%slc_inc) - ! if (allocated (wk3_stc)) deallocate (wk3_stc) - ! if (allocated (wk3_slc)) deallocate (wk3_slc) - ! ! if (allocated (wk3_slmsk)) deallocate (wk3_slmsk) - - ! if (allocated(Land_IAU_state%inc1%stc_inc)) deallocate(Land_IAU_state%inc1%stc_inc) - ! if (allocated(Land_IAU_state%inc1%slc_inc)) deallocate(Land_IAU_state%inc1%slc_inc) - ! if (allocated(Land_IAU_state%inc2%stc_inc)) deallocate(Land_IAU_state%inc2%stc_inc - ! if (allocated(Land_IAU_state%inc2%slc_inc)) deallocate(Land_IAU_state%inc2%slc_inc) - end subroutine land_iau_mod_finalize subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) @@ -475,8 +409,8 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ Land_IAU_Data%in_interval=.false. if (ntimes.LE.0) then - errmsg = 'in land_iau_mod_getiauforcing, but ntimes <=0, probably no increment files. Exiting.' - errflg = 0 + errmsg = 'called land_iau_mod_getiauforcing, but ntimes <=0, probably there is no increment file. Exiting.' + errflg = 1 return endif @@ -489,10 +423,8 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ endif if (Land_IAU_Control%iau_filter_increments) then ! compute increment filter weight - ! t1 is beginning of window, t2 end of window - ! Land_IAU_Control%fhour current time - ! in window kstep=-nstep,nstep (2*nstep+1 total) - ! time step Land_IAU_Control%dtp + ! t1 is beginning of window, t2 end of window, and Land_IAU_Control%fhour is current time + ! in window kstep=-nstep,nstep (2*nstep+1 total) with time step of Land_IAU_Control%dtp dtp=Land_IAU_Control%dtp nstep = 0.5*Land_IAU_Control%iau_delthrs*3600/dtp ! compute normalized filter weight @@ -506,7 +438,6 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ wt = 1. endif Land_IAU_Data%wt = Land_IAU_Data%wt_normfact*wt - !if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'kstep,t1,t,t2,filter wt=',kstep,t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact else Land_IAU_Data%wt = 0. endif @@ -514,15 +445,14 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ if (ntimes.EQ.1) then ! check to see if we are in the IAU window, no need to update the states since they are fixed over the window -!8.8.24 TBCL: noahmpdrv_timestep_init doesn't get visited at t1, so include t2 +!TBCL: noahmpdrv_timestep_init doesn't get visited at t1 (when running from global workflow), so include t2? ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then - ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',t1,Land_IAU_Control%fhour,t2 Land_IAU_Data%in_interval=.false. else Land_IAU_Data%in_interval=.true. if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ', & + print *,'land_iau_mod_getiauforcing: applying forcing at t for t1,t,t2,filter wt rdt ', & t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact,Land_IAU_Data%rdt endif if (Land_IAU_Control%iau_filter_increments) call setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state) @@ -531,34 +461,23 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ endif if (ntimes > 1) then - !itnext=2 !Land_IAU_Data%itnext = 2 -!8.8.24 TBCL: noahmpdrv_timestep_init doesn't get visited at t1, so include t2 - ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then -! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'no iau forcing',Land_IAU_Control%iaufhrs(1),Land_IAU_Control%fhour,Land_IAU_Control%iaufhrs(nfiles) Land_IAU_Data%in_interval=.false. else Land_IAU_Data%in_interval=.true. if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'apply lnd iau forcing t1,t,t2,filter wt rdt= ', & + print *,'land_iau_mod_getiauforcing: applying forcing at t for t1,t,t2,filter wt rdt ', & t1,Land_IAU_Control%fhour,t2,Land_IAU_Data%wt/Land_IAU_Data%wt_normfact,Land_IAU_Data%rdt - endif - ! do k=ntimes, 1, -1 - ! if (Land_IAU_Control%iaufhrs(k) >= Land_IAU_Control%fhour) then - ! itnext=k - ! endif - ! enddo + endif if (Land_IAU_Control%fhour > Land_IAU_Data%hr2) then ! need to read in next increment file Land_IAU_Data%itnext = Land_IAU_Data%itnext + 1 Land_IAU_Data%hr1=Land_IAU_Data%hr2 Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(Land_IAU_Data%itnext) - ! Land_IAU_state%inc1=Land_IAU_state%inc2 - ! Land_IAU_state%inc2%stc_inc(:, :, :) = wk3_stc(itnext, :, :, :) !Land_IAU_state%inc1%stc_inc(is:ie, js:je, km)) - ! Land_IAU_state%inc2%slc_inc(:, :, :) = wk3_slc(itnext, :, :, :) endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'Land iau increments at times ', Land_IAU_Data%itnext-1, ' and ', Land_IAU_Data%itnext, & - ' hr1, hr2 = ', Land_IAU_Data%hr1, Land_IAU_Data%hr2 + print *,'land_iau_mod_getiauforcing: Land iau increments interplated between time steps ', & + Land_IAU_Data%itnext-1, ' and ', Land_IAU_Data%itnext, & + ' times (hr1, hr2) ', Land_IAU_Data%hr1, Land_IAU_Data%hr2 endif ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) @@ -622,14 +541,13 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil ! this is only called if using 1 increment file - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'in land_iau setiauforcing rdt = ',Land_IAU_Data%rdt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) do j = js, je do i = is, ie do k = 1, npz ! do k = 1,n_soill ! Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_Data%wt*Land_IAU_State%stc_inc(1,i,j,k)*Land_IAU_Data%rdt Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_Data%wt*Land_IAU_State%slc_inc(1,i,j,k)*Land_IAU_Data%rdt end do - ! Land_IAU_Data%snow_land_mask(i, j) = wk3_slmsk(1, i, j) enddo enddo @@ -642,14 +560,13 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg - integer :: i, it, km !j, k, l, npz, + integer :: i, it, km logical :: exists integer :: ncid, status, varid integer :: ierr character(len=500) :: fname character(len=2) :: tile_str integer :: n_t, n_y, n_x - ! integer :: isc, jsc character(len=32), dimension(4) :: stc_vars = [character(len=32) :: 'soilt1_inc', 'soilt2_inc', 'soilt3_inc', 'soilt4_inc'] character(len=32), dimension(4) :: slc_vars = [character(len=32) :: 'slc1_inc', 'slc2_inc', 'slc3_inc', 'slc4_inc'] @@ -664,8 +581,6 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf write(tile_str, '(I0)') Land_IAU_Control%tile_num fname = 'INPUT/'//trim(Land_IAU_Control%iau_inc_files(1))//".tile"//trim(tile_str)//".nc" - ! isc = Land_IAU_Control%isc - ! jsc = Land_IAU_Control%jsc inquire (file=trim(fname), exist=exists) if (exists) then @@ -721,11 +636,10 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf do i = 1, size(slc_vars) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(slc_vars(i)) status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) - if (status == nf90_noerr) then !if (ierr == 0) then + if (status == nf90_noerr) then !if (status == 0) do it = 1, n_t call get_var3d_values(ncid, varid, trim(slc_vars(i)), Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & it, 1, wk3_slc(it, :, :, i), status, errflg, errmsg) - ! call netcdf_err(status, 'reading var: '//trim(slc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return end do else @@ -734,22 +648,8 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf wk3_slc(:, :, :, i) = 0. endif enddo - ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(slsn_mask) - ! status = nf90_inq_varid(ncid, trim(slsn_mask), varid) - ! if (status == nf90_noerr) then !if (ierr == 0) then - ! do it = 1, n_t - ! call get_var3d_values_int(ncid, varid, trim(slsn_mask), Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & - ! it, 1, wk3_slmsk(it, :, :), status, errflg, errmsg) - ! ! call netcdf_err(status, 'reading var: '//trim(slsn_mask), errflg, errmsg) - ! if (errflg .ne. 0) return - ! enddo - ! else - ! if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, 'warning: no values for ',trim(slsn_mask), ' found', & - ! 'assuming value of 1 for all grid cells. Please make sure the increment files have soil snow mask var' - ! wk3_slmsk(:, :, :) = 1 - ! endif - !8.3.24 set too small increments to zero + !set too small increments to zero where(abs(wk3_stc) < Land_IAU_Control%min_T_increment) wk3_stc = 0.0 status =nf90_close(ncid) @@ -800,8 +700,7 @@ end subroutine calculate_landinc_mask subroutine netcdf_err(ERR, STRING, errflg, errmsg_out) !-------------------------------------------------------------- - ! IF AT NETCDF CALL RETURNS AN ERROR, PRINT OUT A MESSAGE - ! AND STOP PROCESSING. + ! Process the error flag from a NETCDF call and return it as (human readable) MESSAGE !-------------------------------------------------------------- IMPLICIT NONE @@ -819,7 +718,6 @@ subroutine netcdf_err(ERR, STRING, errflg, errmsg_out) IF (ERR == NF90_NOERR) RETURN ERRMSG = NF90_STRERROR(ERR) - PRINT*,'FATAL ERROR in Land IAU ', TRIM(STRING), ': ', TRIM(ERRMSG) errmsg_out = 'FATAL ERROR in Land IAU '//TRIM(STRING)//': '//TRIM(ERRMSG) errflg = 1 return From 941323bacb6104136cd750a0a07b896d65f5c83a Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Tue, 29 Oct 2024 11:05:42 -0400 Subject: [PATCH 134/154] restore if (cpllnd .and. cpllnd2atm) check --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 846ceff57..b0169401d 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -499,7 +499,7 @@ subroutine noahmpdrv_run & iopt_trs,iopt_diag,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, rhonewsn1,& con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & - con_fvirt, con_rd, con_hfus, thsfc_loc, & + con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd,cpllnd2atm, & ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & @@ -673,6 +673,9 @@ subroutine noahmpdrv_run & logical , intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation + logical , intent(in) :: cpllnd ! Flag for land coupling (atm->lnd) + logical , intent(in) :: cpllnd2atm ! Flag for land coupling (lnd->atm) + real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! ground surface skin temperature [K] @@ -1033,7 +1036,7 @@ subroutine noahmpdrv_run & logical :: is_snowing ! used for penman calculation logical :: is_freeze_rain ! used for penman calculation integer :: i, k - + ! ! --- local derived constants: ! @@ -1050,6 +1053,11 @@ subroutine noahmpdrv_run & errmsg = '' errflg = 0 +! +! --- Just return if external land component is activated for two-way interaction +! + if (cpllnd .and. cpllnd2atm) return + do i = 1, im if (flag_iter(i) .and. dry(i)) then From 753676c660d86443c9a9a4043e192ca88f324ea5 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 29 Oct 2024 11:09:54 -0400 Subject: [PATCH 135/154] clean noahmpdrv --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 22 +++--- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 68 ++++--------------- 2 files changed, 26 insertions(+), 64 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 4f51f2ac6..d9c5b7e92 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -68,24 +68,24 @@ module land_iau_mod integer :: ny integer :: tile_num integer :: nblks - integer, allocatable :: blksz(:) ! this could vary for the last block + integer, allocatable :: blksz(:) ! this could vary for the last block integer, allocatable :: blk_strt_indx(:) - integer :: lsoil !< number of soil layers + integer :: lsoil !< number of soil layers integer :: lsnow_lsm !< maximum number of snow layers internal to land surface model logical :: do_land_iau real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours - character(len=240) :: iau_inc_files(7)! list of increment files + character(len=240) :: iau_inc_files(7) ! list of increment files real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files logical :: iau_filter_increments - integer :: lsoil_incr ! soil layers (from top) updated by DA + integer :: lsoil_incr ! soil layers (from top) updated by DA logical :: upd_stc logical :: upd_slc logical :: do_stcsmc_adjustment !do moisture/temperature adjustment for consistency after increment add real(kind=kind_phys) :: min_T_increment integer :: me !< MPI rank designator - integer :: mpi_root !< MPI rank of master atmosphere processor + integer :: mpi_root !< MPI rank of master atmosphere processor character(len=64) :: fn_nml !< namelist filename for surface data cycling real(kind=kind_phys) :: dtp !< physics timestep in seconds real(kind=kind_phys) :: fhour !< current forecast hour @@ -101,16 +101,16 @@ module land_iau_mod subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me, mpi_root, & isc, jsc, nx, ny, tile_num, nblks, blksz, & - lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) !nlunit + lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) type (land_iau_control_type), intent(inout) :: Land_IAU_Control - character(*), intent(in) :: fn_nml !< namelist filename for surface data cycling + character(*), intent(in) :: fn_nml !< namelist filename for surface data cycling character(len=:), intent(in), dimension(:), pointer :: input_nml_file_i integer, intent(in) :: me, mpi_root !< MPI rank of master atmosphere processor integer, intent(in) :: isc, jsc, nx, ny, tile_num, nblks, lsoil, lsnow_lsm - integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz - real(kind=kind_phys), intent(in) :: dtp !< physics timestep in seconds - real(kind=kind_phys), intent(in) :: fhour !< current forecast hour + integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz + real(kind=kind_phys), intent(in) :: dtp !< physics timestep in seconds + real(kind=kind_phys), intent(in) :: fhour !< current forecast hour character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -127,7 +127,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me logical :: do_land_iau = .false. real(kind=kind_phys) :: land_iau_delthrs = 0 !< iau time interval (to scale increments) character(len=240) :: land_iau_inc_files(7) = '' !< list of increment files - real(kind=kind_phys) :: land_iau_fhrs(7) = -1 !< forecast hours associated with increment files + real(kind=kind_phys) :: land_iau_fhrs(7) = -1 !< forecast hours associated with increment files logical :: land_iau_filter_increments = .false. !< filter IAU increments integer :: lsoil_incr = 4 diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 846ceff57..42297d334 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -13,7 +13,7 @@ module noahmpdrv use module_sf_noahmplsm - ! Land IAU increments for soil temperature (can also do soil moisture increments if needed) + ! Land IAU increments for soil temperature (plan to extend to soil moisture increments) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & land_iau_state_type @@ -44,9 +44,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, & errmsg, errflg, & Land_IAU_Control, Land_IAU_Data, Land_IAU_state, & me, mpi_root) - ! fn_nml, input_nml_file, isc, jsc, ncols, nx, ny, tile_num, & - ! nblks, blksz, xlon, xlat, & - ! lsoil, lsnow_lsm, dtp, fhour) use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg @@ -66,26 +63,16 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! land iau mod - ! Land IAU Control holds settings' information, maily read from namelist (e.g., block of global domain that belongs to a process , + ! land iau mod DDTs + ! Land IAU Control holds settings' information, maily read from namelist + ! (e.g., block of global domain that belongs to current process, ! whether to do IAU increment at this time step, time step informatoin, etc) type(land_iau_control_type), intent(inout) :: Land_IAU_Control - ! Land IAU Data holds spatially and temporally interpolated soil temperature increments per time step - type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data !(number of blocks):each proc holds nblks - type(land_iau_state_type), intent(inout) :: Land_IAU_state ! holds data read from file (before interpolation) - - - ! character(*), intent(in) :: fn_nml - ! character(len=:), pointer, intent(in), dimension(:) :: input_nml_file - ! integer, intent(in) :: isc, jsc, ncols, nx, ny, nblks !=GFS_Control%ncols, %nx, %ny, nblks - ! integer, intent(in) :: tile_num !GFS_control_type%tile_num - ! integer, dimension(:), intent(in) :: blksz !(one:) !GFS_Control%blksz - ! real(kind_phys), dimension(:), intent(in) :: xlon ! longitude !GFS_Data(cdata%blk_no)%Grid%xlon - ! real(kind_phys), dimension(:), intent(in) :: xlat ! latitude - - ! integer, intent(in) :: lsoil, lsnow_lsm - ! real(kind=kind_phys), intent(in) :: dtp, fhour - + ! land iau state holds increment data read from file (before interpolation) + type(land_iau_state_type), intent(inout) :: Land_IAU_state + ! Land IAU Data holds spatially and temporally interpolated increments per time step + type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data ! arry of (number of blocks):each proc holds nblks + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -125,7 +112,6 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, & call read_mp_table_parameters(errmsg, errflg) ! initialize psih and psim - if ( do_mynnsfclay ) then call psi_init(psi_opt,errmsg,errflg) endif @@ -133,34 +119,22 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, & pores (:) = maxsmc (:) resid (:) = drysmc (:) - ! ! Read Land IAU settings - ! call land_iau_mod_set_control(Land_IAU_Control, fn_nml, input_nml_file, & - ! me, mpi_root, isc,jsc, nx, ny, tile_num, nblks, blksz, & - ! lsoil, lsnow_lsm, dtp, fhour, errmsg, errflg) - ! Initialize IAU for land + ! Initialize IAU for land--land_iau_control was set by host model if (.not. Land_IAU_Control%do_land_iau) return - call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) ! xlon, xlat, errmsg, errflg) + call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called before noahmpdrv_run -!! to update states with iau increments, if available--- +!! to update states with iau increments, if available !! \section arg_table_noahmpdrv_timestep_init Argument Table !! \htmlinclude noahmpdrv_timestep_init.html !! -!! For Noah-MP, the adjustment scheme shown below is applied to soil moisture and temp: -!! Case 1: frozen ==> frozen, recalculate slc following opt_frz=1, smc remains -!! Case 2: unfrozen ==> frozen, recalculate slc following opt_frz=1, smc remains -!! Case 3: frozen ==> unfrozen, melt all soil ice (if any) -!! Case 4: unfrozen ==> unfrozen along with other cases, (e.g., soil temp=tfrz),do nothing -!! Note: For Case 3, Yuan Xue thoroughly evaluated a total of four options and -!! current option is found to be the best as of 11/09/2023 - -subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !me, mpi_root, +subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & isot, ivegsrc, soiltyp, vegtype, weasd, & land_iau_control, land_iau_data, land_iau_state, & - stc, slc, smc, errmsg, errflg, & ! smc, t2mmp, q2mp, + stc, slc, smc, errmsg, errflg, & con_g, con_t0c, con_hfus) use machine, only: kind_phys @@ -197,33 +171,21 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & ! IAU update real(kind=kind_phys),allocatable, dimension(:,:) :: stc_inc_flat, slc_inc_flat real(kind=kind_phys), dimension(km) :: dz ! layer thickness - ! real(kind=kind_phys) :: stc_bck(ncols, km), d_stc(ncols, km) - ! integer, allocatable, dimension(:) :: diff_indices -!TODO: 7.31.24: This is hard-coded in noahmpdrv +!TODO: This is hard-coded in noahmpdrv real(kind=kind_phys) :: zsoil(4) = (/ -0.1, -0.4, -1.0, -2.0 /) !zsoil(km) integer :: lsoil_incr - ! integer :: veg_type_landice - integer, allocatable :: mask_tile(:) integer,allocatable :: stc_updated(:), slc_updated(:) logical :: soil_freeze, soil_ice - ! integer :: n_freeze, n_thaw integer :: soiltype, n_stc, n_slc real(kind=kind_phys) :: slc_new integer :: i, j, ij, l, k, ib integer :: lensfc - - ! real (kind=kind_phys), dimension(max_soiltyp) :: maxsmc, bb, satpsi - ! real, dimension(30) :: maxsmc, bb, satpsi - ! real(kind=kind_phys), parameter :: tfreez=273.16 !< con_t0c in physcons - ! real(kind=kind_phys), parameter :: hfus=0.3336e06 !< latent heat of fusion(j/kg) con_hfus - ! real(kind=kind_phys), parameter :: con_g !grav=9.80616 !< gravity accel.(m/s2) real(kind=kind_phys) :: smp !< for computing supercooled water - real(kind=kind_phys) :: hc_incr integer :: nother, nsnowupd From ee1b463f2327fd0e5c9917819f93d19589aabf70 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Tue, 29 Oct 2024 12:04:56 -0400 Subject: [PATCH 136/154] remove debug prints --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 12 +++++------ physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 21 ++++++------------- 2 files changed, 12 insertions(+), 21 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index d9c5b7e92..2d79863c4 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -293,7 +293,9 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e wt = 1.0 endif normfact = normfact + wt - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,'filter wts',k,kstep,wt + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *,'Land IAU init: IAU filter weights params k, kstep, wt ',k, kstep, wt + endif enddo Land_IAU_Data%wt_normfact = (2*nstep+1)/normfact endif @@ -302,7 +304,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e if (trim(Land_IAU_Control%iau_inc_files(1)) .eq. '' .or. Land_IAU_Control%iaufhrs(1) .lt. 0) then ! only 1 file expected errmsg = "Error! in Land IAU init: increment file name is empty or iaufhrs(1) is negative" errflg = 1 - ! Land_IAU_Control%do_land_iau=.false. return endif if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then @@ -312,7 +313,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e ! determine number of valid forecast hours ! is read from the increment file ("Time" dim) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *, " Number of forecast times (in hours) with valid increment values" + print *, "Land_iau_init: timesetps and forecast times (in hours) with valid increment values" endif ntimesall = size(Land_IAU_Control%iaufhrs) ntimes = 0 @@ -326,9 +327,8 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e Land_IAU_Control%ntimes = ntimes if (ntimes < 1) then - errmsg = "Error! in Land IAU init: ntimes < 1" + errmsg = "Error! in Land IAU init: ntimes < 1 (no valid hour with increments); do_land_iau should not be .true." errflg = 1 - ! Land_IAU_Control%do_land_iau=.false. return endif if (ntimes > 1) then @@ -350,7 +350,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e endif ! Read all increment files at iau init time (at beginning of cycle) ! increments are already in the fv3 grid--no need for interpolation - call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%stc_inc, Land_IAU_state%slc_inc, errmsg, errflg) !, wk3_stc, wk3_slc + call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%stc_inc, Land_IAU_state%slc_inc, errmsg, errflg) if (errflg .ne. 0) return if (ntimes.EQ.1) then ! only need to get incrments once since constant forcing over window diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 680be4df4..1b63ed22a 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -323,22 +323,14 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) -! (consistency) adjustments for updated soil temp and moisture - - ! call set_soilveg_noahmp(isot, ivegsrc, maxsmc, bb, satpsi, errflg) - call read_mp_table_parameters(errmsg, errflg) - ! maxsmc(1:slcats) = smcmax_table(1:slcats) - ! bb(1:slcats) = bexp_table(1:slcats) - ! satpsi(1:slcats) = psisat_table(1:slcats) + !!do moisture/temperature adjustment for consistency after increment add + call read_mp_table_parameters(errmsg, errflg) if (errflg .ne. 0) then - print *, 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' errmsg = 'FATAL ERROR in noahmpdrv_timestep_init: problem in set_soilveg_noahmp' return endif - n_stc = 0 - n_slc = 0 - !!do moisture/temperature adjustment for consistency after increment add + n_slc = 0 if (Land_IAU_Control%do_stcsmc_adjustment) then if (Land_IAU_Control%upd_stc) then do i=1,lensfc @@ -369,7 +361,6 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & do l = 2, km dz(l) = -zsoil(l) + zsoil(l-1) enddo - ! print *, 'Applying soil moisture mins ' do i=1,lensfc if (slc_updated(i) == 1 ) then n_slc = n_slc+1 @@ -389,7 +380,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & deallocate(mask_tile) - write(*,'(a,i2)') ' statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me + write(*,'(a,i2)') ' noahmpdrv_timestep_init: statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me write(*,'(a,i8)') ' soil grid total', lensfc write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd write(*,'(a,i8)') ' soil grid cells slc updated = ',nslcupd @@ -409,7 +400,7 @@ end subroutine noahmpdrv_timestep_init !! \section arg_table_noahmpdrv_finalize Argument Table !! \htmlinclude noahmpdrv_finalize.html !! - subroutine noahmpdrv_finalize (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) ! smc, t2mmp, q2mp, + subroutine noahmpdrv_finalize (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) use machine, only: kind_phys implicit none @@ -461,7 +452,7 @@ subroutine noahmpdrv_run & iopt_trs,iopt_diag,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, rhonewsn1,& con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & - con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd,cpllnd2atm, & + con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd, cpllnd2atm, & ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & From 84cddc3b621d37ebfc275b11cf0bcbc530f02690 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 07:52:50 -0400 Subject: [PATCH 137/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 1b63ed22a..aa2f45cd0 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -9,7 +9,7 @@ !! as diagnotics calculation. !> This module contains the CCPP-compliant NoahMP land surface model driver. - module noahmpdrv + module noahmpdrv use module_sf_noahmplsm From e428689032a47fc1bb14456096643798590f5411 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 07:54:20 -0400 Subject: [PATCH 138/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index aa2f45cd0..501104b98 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -9,9 +9,9 @@ !! as diagnotics calculation. !> This module contains the CCPP-compliant NoahMP land surface model driver. - module noahmpdrv + module noahmpdrv - use module_sf_noahmplsm + use module_sf_noahmplsm ! Land IAU increments for soil temperature (plan to extend to soil moisture increments) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & From cd03ce70990877b78dab90fadb6fa8e570a06102 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 07:55:12 -0400 Subject: [PATCH 139/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 501104b98..1779da50e 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -9,9 +9,9 @@ !! as diagnotics calculation. !> This module contains the CCPP-compliant NoahMP land surface model driver. - module noahmpdrv + module noahmpdrv - use module_sf_noahmplsm + use module_sf_noahmplsm ! Land IAU increments for soil temperature (plan to extend to soil moisture increments) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & From 1442fdb31bb573e803183bac5c94fb49461464f6 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 07:55:52 -0400 Subject: [PATCH 140/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 1779da50e..07c7cff49 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -9,9 +9,9 @@ !! as diagnotics calculation. !> This module contains the CCPP-compliant NoahMP land surface model driver. - module noahmpdrv + module noahmpdrv - use module_sf_noahmplsm + use module_sf_noahmplsm ! Land IAU increments for soil temperature (plan to extend to soil moisture increments) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & From 9b88ec3bfec0357d4cc42b2665f4b593cc57adb2 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 07:57:43 -0400 Subject: [PATCH 141/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 07c7cff49..52d0f0bcc 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -13,16 +13,16 @@ module noahmpdrv use module_sf_noahmplsm - ! Land IAU increments for soil temperature (plan to extend to soil moisture increments) - use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & +! Land IAU increments for soil temperature (plan to extend to soil moisture increments) + use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & land_iau_state_type - use land_iau_mod, only: land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & + use land_iau_mod, only: land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & calculate_landinc_mask ! land_iau_mod_set_control, - implicit none + implicit none - integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS + integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS private From 3672889b93ff57a1b5adcaaeac4e115be9d14f48 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 07:58:51 -0400 Subject: [PATCH 142/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 52d0f0bcc..a6b9bf41e 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -24,12 +24,12 @@ module noahmpdrv integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS - private + private - public :: noahmpdrv_init, noahmpdrv_run, & + public :: noahmpdrv_init, noahmpdrv_run, & noahmpdrv_timestep_init, noahmpdrv_finalize - contains + contains !> \ingroup NoahMP_LSM !! \brief This subroutine is called during the CCPP initialization phase and calls set_soilveg() to From a61f437b8b0f3d471fc5087c335c4592f2a4e454 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 08:00:36 -0400 Subject: [PATCH 143/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index a6b9bf41e..916cae943 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -37,13 +37,11 @@ module noahmpdrv !! \section arg_table_noahmpdrv_init Argument Table !! \htmlinclude noahmpdrv_init.html !! - subroutine noahmpdrv_init(lsm, lsm_noahmp, & - isot, ivegsrc, & + subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & nlunit, pores, resid, & do_mynnsfclay,do_mynnedmf, & errmsg, errflg, & - Land_IAU_Control, Land_IAU_Data, Land_IAU_state, & - me, mpi_root) + Land_IAU_Control, Land_IAU_Data, Land_IAU_state) use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg From 71ab42571bfa284db03d65e886c9612aef6b1ea7 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 08:14:45 -0400 Subject: [PATCH 144/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 916cae943..59bcf4eb6 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -38,9 +38,9 @@ module noahmpdrv !! \htmlinclude noahmpdrv_init.html !! subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & - nlunit, pores, resid, & - do_mynnsfclay,do_mynnedmf, & - errmsg, errflg, & + nlunit, pores, resid, & + do_mynnsfclay,do_mynnedmf, & + errmsg, errflg, & Land_IAU_Control, Land_IAU_Data, Land_IAU_state) use machine, only: kind_phys From ec2a299098d90ee39c308b4cd7907a41a308bd7c Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Wed, 30 Oct 2024 08:42:06 -0400 Subject: [PATCH 145/154] Update noahmpdrv.F90 --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 59bcf4eb6..916cae943 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -38,9 +38,9 @@ module noahmpdrv !! \htmlinclude noahmpdrv_init.html !! subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & - nlunit, pores, resid, & - do_mynnsfclay,do_mynnedmf, & - errmsg, errflg, & + nlunit, pores, resid, & + do_mynnsfclay,do_mynnedmf, & + errmsg, errflg, & Land_IAU_Control, Land_IAU_Data, Land_IAU_state) use machine, only: kind_phys From 1391585123d573834b0b7c0c2e5a0cafcb1ad955 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 30 Oct 2024 11:42:33 -0400 Subject: [PATCH 146/154] change DDTs in noahmpdrv_init to optional --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 157 ++++++----- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 260 ++---------------- 2 files changed, 102 insertions(+), 315 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index 916cae943..ec3c2d5c3 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -12,14 +12,13 @@ module noahmpdrv use module_sf_noahmplsm - + ! Land IAU increments for soil temperature (plan to extend to soil moisture increments) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & land_iau_state_type use land_iau_mod, only: land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & calculate_landinc_mask ! land_iau_mod_set_control, - implicit none integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS @@ -27,7 +26,7 @@ module noahmpdrv private public :: noahmpdrv_init, noahmpdrv_run, & - noahmpdrv_timestep_init, noahmpdrv_finalize + noahmpdrv_timestep_init, noahmpdrv_finalize contains @@ -38,90 +37,96 @@ module noahmpdrv !! \htmlinclude noahmpdrv_init.html !! subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & - nlunit, pores, resid, & - do_mynnsfclay,do_mynnedmf, & - errmsg, errflg, & + nlunit, pores, resid, & + do_mynnsfclay,do_mynnedmf, & + errmsg, errflg, & Land_IAU_Control, Land_IAU_Data, Land_IAU_state) - use machine, only: kind_phys - use set_soilveg_mod, only: set_soilveg - use namelist_soilveg - use noahmp_tables + use machine, only: kind_phys + use set_soilveg_mod, only: set_soilveg + use namelist_soilveg + use noahmp_tables + + implicit none + integer, intent(in) :: lsm + integer, intent(in) :: lsm_noahmp + integer, intent(in) :: me, isot, ivegsrc, nlunit - implicit none - - integer, intent(in) :: me ! mpi_rank - integer, intent(in) :: mpi_root ! = GFS_Control%master - integer, intent(in) :: lsm - integer, intent(in) :: lsm_noahmp - integer, intent(in) :: isot, ivegsrc, nlunit - real (kind=kind_phys), dimension(:), intent(out) :: pores, resid - logical, intent(in) :: do_mynnsfclay - logical, intent(in) :: do_mynnedmf - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + real (kind=kind_phys), dimension(:), intent(out) :: pores, resid + + logical, intent(in) :: do_mynnsfclay + logical, intent(in) :: do_mynnedmf + + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! land iau mod DDTs ! Land IAU Control holds settings' information, maily read from namelist ! (e.g., block of global domain that belongs to current process, - ! whether to do IAU increment at this time step, time step informatoin, etc) - type(land_iau_control_type), intent(inout) :: Land_IAU_Control - ! land iau state holds increment data read from file (before interpolation) - type(land_iau_state_type), intent(inout) :: Land_IAU_state - ! Land IAU Data holds spatially and temporally interpolated increments per time step - type(land_iau_external_data_type), intent(inout) :: Land_IAU_Data ! arry of (number of blocks):each proc holds nblks - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 + ! whether to do IAU increment at this time step, time step informatoin, etc) + ! made optional to allow NoahMP Component model call this function without having to deal with IAU + type(land_iau_control_type), intent(inout), optional :: Land_IAU_Control + ! land iau state holds increment data read from file (before interpolation) + type(land_iau_state_type), intent(inout), optional :: Land_IAU_state + ! Land IAU Data holds spatially and temporally interpolated increments per time step + type(land_iau_external_data_type), intent(inout), optional :: Land_IAU_Data ! arry of (number of blocks):each proc holds nblks + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Consistency checks + if (lsm/=lsm_noahmp) then + write(errmsg,'(*(a))') 'Logic error: namelist choice of ', & + & 'LSM is different from Noah' + errflg = 1 + return + end if - ! Consistency checks - if (lsm/=lsm_noahmp) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of ', & - & 'LSM is different from Noah' - errflg = 1 - return - end if + if (ivegsrc /= 1) then + errmsg = 'The NOAHMP LSM expects that the ivegsrc physics '// & + 'namelist parameter is 1. Exiting...' + errflg = 1 + return + end if + if (isot /= 1) then + errmsg = 'The NOAHMP LSM expects that the isot physics '// & + 'namelist parameter is 1. Exiting...' + errflg = 1 + return + end if - if (ivegsrc /= 1) then - errmsg = 'The NOAHMP LSM expects that the ivegsrc physics '// & - 'namelist parameter is 1. Exiting...' - errflg = 1 - return - end if - if (isot /= 1) then - errmsg = 'The NOAHMP LSM expects that the isot physics '// & - 'namelist parameter is 1. Exiting...' - errflg = 1 - return - end if + if ( do_mynnsfclay .and. .not. do_mynnedmf) then + errmsg = 'Problem : do_mynnsfclay = .true.' // & + 'but mynnpbl is .false.. Exiting ...' + errflg = 1 + return + end if - if ( do_mynnsfclay .and. .not. do_mynnedmf) then - errmsg = 'Problem : do_mynnsfclay = .true.' // & - 'but mynnpbl is .false.. Exiting ...' - errflg = 1 - return - end if - !--- initialize soil vegetation - call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) + !--- initialize soil vegetation + call set_soilveg(me, isot, ivegsrc, nlunit, errmsg, errflg) - !--- read in noahmp table - call read_mp_table_parameters(errmsg, errflg) + !--- read in noahmp table + call read_mp_table_parameters(errmsg, errflg) - ! initialize psih and psim - if ( do_mynnsfclay ) then - call psi_init(psi_opt,errmsg,errflg) - endif + ! initialize psih and psim - pores (:) = maxsmc (:) - resid (:) = drysmc (:) + if ( do_mynnsfclay ) then + call psi_init(psi_opt,errmsg,errflg) + endif - ! Initialize IAU for land--land_iau_control was set by host model - if (.not. Land_IAU_Control%do_land_iau) return - call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) + pores (:) = maxsmc (:) + resid (:) = drysmc (:) + + if (present(Land_IAU_Control) .and. present(Land_IAU_Data) .and. present(Land_IAU_State)) then + ! Initialize IAU for land--land_iau_control was set by host model + if (.not. Land_IAU_Control%do_land_iau) return + call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) + endif - end subroutine noahmpdrv_init + end subroutine noahmpdrv_init !> \ingroup NoahMP_LSM !! \brief This subroutine is called before noahmpdrv_run @@ -441,7 +446,7 @@ end subroutine noahmpdrv_finalize subroutine noahmpdrv_run & !................................... ! --- inputs: - (im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp,soilcol,& + ( im, km, lsnowl, itime, ps, u1, v1, t1, q1, soiltyp,soilcol,& vegtype, sigmaf, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & prsl1, prslk1, prslki, prsik1, zf,pblh, dry, wind, slopetyp,& shdmin, shdmax, snoalb, sfalb, flag_iter,con_g, & @@ -450,7 +455,7 @@ subroutine noahmpdrv_run & iopt_trs,iopt_diag,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, rhonewsn1,& con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & - con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd, cpllnd2atm, & + con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd, cpllnd2atm,& ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & @@ -546,7 +551,7 @@ subroutine noahmpdrv_run & integer , intent(in) :: im ! horiz dimension and num of used pts integer , intent(in) :: km ! vertical soil layer dimension integer , intent(in) :: lsnowl ! lower bound for snow level arrays - integer , intent(in) :: itime ! NOT USED current forecast iteration + integer , intent(in) :: itime ! NOT USED real(kind=kind_phys), dimension(:) , intent(in) :: ps ! surface pressure [Pa] real(kind=kind_phys), dimension(:) , intent(in) :: u1 ! u-component of wind [m/s] real(kind=kind_phys), dimension(:) , intent(in) :: v1 ! u-component of wind [m/s] @@ -987,7 +992,7 @@ subroutine noahmpdrv_run & logical :: is_snowing ! used for penman calculation logical :: is_freeze_rain ! used for penman calculation integer :: i, k - + ! ! --- local derived constants: ! @@ -2064,4 +2069,4 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! ---------------------------------------------------------------------- end subroutine penman -end module noahmpdrv + end module noahmpdrv diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 256f47574..753550016 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -4,26 +4,11 @@ dependencies = ../../../tools/funcphys.f90,../../../hooks/machine.F dependencies = module_sf_noahmp_glacier.F90,module_sf_noahmplsm.F90,noahmp_tables.f90 dependencies = ../Noah/set_soilveg.f - dependencies = lnd_iau_mod.F90 ######################################################################## [ccpp-arg-table] name = noahmpdrv_init type = scheme -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in -[mpi_root] - standard_name = mpi_root - long_name = master MPI-rank - units = index - dimensions = () - type = integer - intent = in [lsm] standard_name = control_for_land_surface_scheme long_name = flag for land surface model @@ -38,6 +23,13 @@ dimensions = () type = integer intent = in +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in [isot] standard_name = control_for_soil_type_dataset long_name = soil type dataset choice @@ -104,232 +96,8 @@ dimensions = () type = integer intent = out -[land_iau_control] - standard_name = land_data_assimilation_control - long_name = land data assimilation control - units = mixed - dimensions = () - type = land_iau_control_type - intent = inout -[land_iau_data] - standard_name = land_data_assimilation_data - long_name = land data assimilation data - units = mixed - dimensions = () - type = land_iau_external_data_type - intent = inout -[land_iau_state] - standard_name = land_data_assimilation_interpolated_data - long_name = land data assimilation space- and time-interpolated - units = mixed - dimensions = () - type = land_iau_state_type - intent = inout ######################################################################## -[ccpp-arg-table] - name = noahmpdrv_timestep_init - type = scheme -[itime] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[fhour] - standard_name = forecast_time - long_name = current forecast time - units = h - dimensions = () - type = real - kind = kind_phys - intent = in -[delt] - standard_name = timestep_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[km] - standard_name = vertical_dimension_of_soil - long_name = vertical dimension of soil layers - units = count - dimensions = () - type = integer - intent = in -[ncols] - standard_name = horizontal_dimension - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[isot] - standard_name = control_for_soil_type_dataset - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in -[ivegsrc] - standard_name = control_for_vegetation_dataset - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in -[soiltyp] - standard_name = soil_type_classification - long_name = soil type at each grid cell - units = index - dimensions = (horizontal_dimension) - type = integer - intent= in -[vegtype] - standard_name = vegetation_type_classification - long_name = vegetation type at each grid cell - units = index - dimensions = (horizontal_dimension) - type = integer - intent= in -[weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_land - long_name = water equivalent of accumulated snow depth over land - units = mm - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout -[land_iau_control] - standard_name = land_data_assimilation_control - long_name = land data assimilation control - units = mixed - dimensions = () - type = land_iau_control_type - intent = inout -[land_iau_data] - standard_name = land_data_assimilation_data - long_name = land data assimilation data - units = mixed - dimensions = () - type = land_iau_external_data_type - intent = inout -[land_iau_state] - standard_name = land_data_assimilation_interpolated_data - long_name = land data assimilation space- and time-interpolated - units = mixed - dimensions = () - type = land_iau_state_type - intent = inout -[stc] - standard_name = soil_temperature - long_name = soil temperature - units = K - dimensions = (horizontal_dimension,vertical_dimension_of_soil) - type = real - kind = kind_phys - intent = inout -[slc] - standard_name = volume_fraction_of_unfrozen_water_in_soil - long_name = liquid soil moisture - units = frac - dimensions = (horizontal_dimension,vertical_dimension_of_soil) - type = real - kind = kind_phys - intent = inout -[smc] - standard_name = volume_fraction_of_condensed_water_in_soil - long_name = total soil moisture - units = frac - dimensions = (horizontal_dimension,vertical_dimension_of_soil) - type = real - kind = kind_phys - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in -[con_t0c] - standard_name = temperature_at_zero_celsius - long_name = temperature at 0 degree Celsius - units = K - dimensions = () - type = real - kind = kind_phys - intent = in -[con_hfus] - standard_name = latent_heat_of_fusion_of_water_at_0C - long_name = latent heat of fusion - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - -####################################################################### -[ccpp-arg-table] - name = noahmpdrv_finalize - type = scheme -[land_iau_control] - standard_name = land_data_assimilation_control - long_name = land data assimilation control - units = mixed - dimensions = () - type = land_iau_control_type - intent = in -[land_iau_data] - standard_name = land_data_assimilation_data - long_name = land data assimilation data - units = mixed - dimensions = () - type = land_iau_external_data_type - intent = inout -[land_iau_state] - standard_name = land_data_assimilation_interpolated_data - long_name = land data assimilation space- and time-interpolated - units = mixed - dimensions = () - type = land_iau_state_type - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -####################################################################### [ccpp-arg-table] name = noahmpdrv_run type = scheme @@ -872,6 +640,20 @@ dimensions = () type = logical intent = in +[cpllnd] + standard_name = flag_for_land_coupling + long_name = flag controlling cpllnd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cpllnd2atm] + standard_name = flag_for_one_way_land_coupling_to_atmosphere + long_name = flag controlling land coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land From b008e259020b5421989da9704fc57215b6dc1dac Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 30 Oct 2024 11:51:20 -0400 Subject: [PATCH 147/154] update noahmpdrv.meta for edits to accomodate component model NoahMP --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 224 ++++++++++++++++++ 1 file changed, 224 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 753550016..38b21db57 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -96,6 +96,230 @@ dimensions = () type = integer intent = out +[land_iau_control] + standard_name = land_data_assimilation_control + long_name = land data assimilation control + units = mixed + dimensions = () + type = land_iau_control_type + intent = inout +[land_iau_data] + standard_name = land_data_assimilation_data + long_name = land data assimilation data + units = mixed + dimensions = () + type = land_iau_external_data_type + intent = inout +[land_iau_state] + standard_name = land_data_assimilation_interpolated_data + long_name = land data assimilation space- and time-interpolated + units = mixed + dimensions = () + type = land_iau_state_type + intent = inout + +######################################################################## +[ccpp-arg-table] + name = noahmpdrv_timestep_init + type = scheme +[itime] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[delt] + standard_name = timestep_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[km] + standard_name = vertical_dimension_of_soil + long_name = vertical dimension of soil layers + units = count + dimensions = () + type = integer + intent = in +[ncols] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent= in +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent= in +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equivalent of accumulated snow depth over land + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout +[land_iau_control] + standard_name = land_data_assimilation_control + long_name = land data assimilation control + units = mixed + dimensions = () + type = land_iau_control_type + intent = inout +[land_iau_data] + standard_name = land_data_assimilation_data + long_name = land data assimilation data + units = mixed + dimensions = () + type = land_iau_external_data_type + intent = inout +[land_iau_state] + standard_name = land_data_assimilation_interpolated_data + long_name = land data assimilation space- and time-interpolated + units = mixed + dimensions = () + type = land_iau_state_type + intent = inout +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[slc] + standard_name = volume_fraction_of_unfrozen_water_in_soil + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[smc] + standard_name = volume_fraction_of_condensed_water_in_soil + long_name = total soil moisture + units = frac + dimensions = (horizontal_dimension,vertical_dimension_of_soil) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + +####################################################################### +[ccpp-arg-table] + name = noahmpdrv_finalize + type = scheme +[land_iau_control] + standard_name = land_data_assimilation_control + long_name = land data assimilation control + units = mixed + dimensions = () + type = land_iau_control_type + intent = in +[land_iau_data] + standard_name = land_data_assimilation_data + long_name = land data assimilation data + units = mixed + dimensions = () + type = land_iau_external_data_type + intent = inout +[land_iau_state] + standard_name = land_data_assimilation_interpolated_data + long_name = land data assimilation space- and time-interpolated + units = mixed + dimensions = () + type = land_iau_state_type + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out ######################################################################## [ccpp-arg-table] From ebb7b6b70679c88bb3e31fd3865741bbe166661c Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Wed, 30 Oct 2024 14:11:07 -0400 Subject: [PATCH 148/154] fix compile error --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 2d79863c4..1b06ff63e 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -541,7 +541,6 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil ! this is only called if using 1 increment file - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) do j = js, je do i = is, ie do k = 1, npz ! do k = 1,n_soill ! From db2c10f6f45a7a396e29cb6ac018ae6d31b59a2a Mon Sep 17 00:00:00 2001 From: tsga Date: Thu, 31 Oct 2024 12:57:25 +0000 Subject: [PATCH 149/154] fix real type for mask --- physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 1b06ff63e..2be8d52db 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -672,7 +672,7 @@ subroutine calculate_landinc_mask(swe,vtype,stype,lensfc,veg_type_landice, mask) implicit none integer, intent(in) :: lensfc, veg_type_landice - real, intent(in) :: swe(lensfc) + real(kind=kind_phys), intent(in) :: swe(lensfc) integer, intent(in) :: vtype(lensfc),stype(lensfc) integer, intent(out) :: mask(lensfc) From 82f1ec3eb0a498a9cf54f712737dd13138fd43cc Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 15 Nov 2024 08:14:28 -0500 Subject: [PATCH 150/154] add optional=True for lndiau ddts --- physics/SFC_Models/Land/Noahmp/noahmpdrv.meta | 3 +++ 1 file changed, 3 insertions(+) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta index 38b21db57..7d1150c80 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.meta @@ -103,6 +103,7 @@ dimensions = () type = land_iau_control_type intent = inout + optional = True [land_iau_data] standard_name = land_data_assimilation_data long_name = land data assimilation data @@ -110,6 +111,7 @@ dimensions = () type = land_iau_external_data_type intent = inout + optional = True [land_iau_state] standard_name = land_data_assimilation_interpolated_data long_name = land data assimilation space- and time-interpolated @@ -117,6 +119,7 @@ dimensions = () type = land_iau_state_type intent = inout + optional = True ######################################################################## [ccpp-arg-table] From 13e8e786c98093ada1a23c5140c3fbe20473bdc7 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 15 Nov 2024 08:33:11 -0500 Subject: [PATCH 151/154] clean lnd_iau_mod --- .../SFC_Models/Land/Noahmp/lnd_iau_mod.F90 | 90 +++++++------------ 1 file changed, 33 insertions(+), 57 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 index 2be8d52db..40f3eb8f7 100644 --- a/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 +++ b/physics/SFC_Models/Land/Noahmp/lnd_iau_mod.F90 @@ -37,21 +37,19 @@ module land_iau_mod real(kind=kind_phys),allocatable :: stc_inc(:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:) logical :: in_interval = .false. - ! integer,allocatable :: snow_land_mask(:, :) ! Calculate snow soil mask at runtime from (dynamic) swe - ! moved from land_iau_state_type real(kind=kind_phys) :: hr1 real(kind=kind_phys) :: hr2 real(kind=kind_phys) :: wt real(kind=kind_phys) :: wt_normfact - real(kind=kind_phys) :: rdt - ! track the increment steps here - integer :: itnext + real(kind=kind_phys) :: rdt + integer :: itnext ! track the increment steps here end type land_iau_external_data_type !!> \section arg_table_land_iau_state_type Argument Table !! \htmlinclude land_iau_state_type.html !! - ! land_iau_state will hold 'raw' (not interpolated) inrements, read during land_iau_mod_init + ! land_iau_state_type holds 'raw' (not interpolated) inrements, + ! read during land_iau_mod_init type land_iau_state_type real(kind=kind_phys),allocatable :: stc_inc(:,:,:,:) real(kind=kind_phys),allocatable :: slc_inc(:,:,:,:) @@ -152,7 +150,7 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me input_nml_file => input_nml_file_i read(input_nml_file, nml=land_iau_nml, ERR=888, END=999, iostat=ios) #else - inquire (file=trim(fn_nml), exist=exists) ! TBCL: this maybe be replaced by nlunit passed from ccpp + inquire (file=trim(fn_nml), exist=exists) ! TODO: this maybe be replaced by nlunit passed from ccpp if (.not. exists) then errmsg = 'lnd_iau_mod_set_control: namelist file '//trim(fn_nml)//' does not exist' errflg = 1 @@ -172,14 +170,14 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me endif #endif -888 if (ios /= 0) then ! .and. ios /= iostat_end) then +888 if (ios /= 0) then write(iosstr, '(I0)') ios errmsg = 'lnd_iau_mod_set_control: I/O error code '//trim(iosstr)//' at land_iau namelist read' errflg = 1 return end if -999 if (ios /= 0) then ! ios .eq. iostat_end) then +999 if (ios /= 0) then write(iosstr, '(I0)') ios if (me == mpi_root) then WRITE(6, * ) 'lnd_iau_mod_set_control: Warning! EoF ('//trim(iosstr)//') while reading land_iau namelist,' & @@ -220,8 +218,8 @@ subroutine land_iau_mod_set_control(Land_IAU_Control,fn_nml,input_nml_file_i, me allocate(Land_IAU_Control%blksz(nblks)) allocate(Land_IAU_Control%blk_strt_indx(nblks)) - ! Land_IAU_Control%blk_strt_indx: start index of each block, for flattened (ncol=nx*ny) arrays - ! required in noahmpdriv_run to get subsection of the stc array for each proces/thread + ! Land_IAU_Control%blk_strt_indx = start index of each block, for flattened (ncol=nx*ny) arrays + ! It's required in noahmpdriv_run to get subsection of the stc array for each proces/thread ix = 1 do nb=1, nblks Land_IAU_Control%blksz(nb) = blksz(nb) @@ -272,7 +270,6 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e ! allocate arrays that will hold iau state allocate(Land_IAU_Data%stc_inc(nlon, nlat, km)) allocate(Land_IAU_Data%slc_inc(nlon, nlat, km)) - ! allocate(Land_IAU_Data%snow_land_mask(nlon, nlat)) Land_IAU_Data%hr1=Land_IAU_Control%iaufhrs(1) Land_IAU_Data%wt = 1.0 ! IAU increment filter weights (default 1.0) @@ -310,8 +307,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e print*,"Land_iau_init: Increment file name: ", trim(adjustl(Land_IAU_Control%iau_inc_files(1))) endif - ! determine number of valid forecast hours - ! is read from the increment file ("Time" dim) + ! determine number of valid forecast hours; read from the increment file ("Time" dim) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print *, "Land_iau_init: timesetps and forecast times (in hours) with valid increment values" endif @@ -345,9 +341,7 @@ subroutine land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, e endif dt = (Land_IAU_Control%iau_delthrs*3600.) Land_IAU_Data%rdt = 1.0/dt !rdt - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'Land_iau_init: IAU interval(dt), rdt (1/dt)',Land_IAU_Control%iau_delthrs,Land_IAU_Data%rdt - endif + ! Read all increment files at iau init time (at beginning of cycle) ! increments are already in the fv3 grid--no need for interpolation call read_iau_forcing_fv3(Land_IAU_Control, Land_IAU_state%stc_inc, Land_IAU_state%slc_inc, errmsg, errflg) @@ -382,7 +376,6 @@ subroutine land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_state if (allocated(Land_IAU_Data%stc_inc)) deallocate (Land_IAU_Data%stc_inc) if (allocated(Land_IAU_Data%slc_inc)) deallocate (Land_IAU_Data%slc_inc) - ! if (allocated(Land_IAU_Data%snow_land_mask)) deallocate (Land_IAU_Data%snow_land_mask) if (allocated(Land_IAU_state%stc_inc)) deallocate(Land_IAU_state%stc_inc) if (allocated(Land_IAU_state%slc_inc)) deallocate(Land_IAU_state%slc_inc) @@ -398,7 +391,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys) t1,t2,sx,wx,wt,dtp - integer n,i,j,k,kstep,nstep !,itnext + integer n,i,j,k,kstep,nstep integer :: ntimes ! Initialize CCPP error handling variables @@ -445,8 +438,6 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ if (ntimes.EQ.1) then ! check to see if we are in the IAU window, no need to update the states since they are fixed over the window -!TBCL: noahmpdrv_timestep_init doesn't get visited at t1 (when running from global workflow), so include t2? - ! if ( Land_IAU_Control%fhour < t1 .or. Land_IAU_Control%fhour >= t2 ) then if ( Land_IAU_Control%fhour <= t1 .or. Land_IAU_Control%fhour > t2 ) then Land_IAU_Data%in_interval=.false. else @@ -474,12 +465,7 @@ subroutine land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_ Land_IAU_Data%hr1=Land_IAU_Data%hr2 Land_IAU_Data%hr2=Land_IAU_Control%iaufhrs(Land_IAU_Data%itnext) endif - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'land_iau_mod_getiauforcing: Land iau increments interplated between time steps ', & - Land_IAU_Data%itnext-1, ' and ', Land_IAU_Data%itnext, & - ' times (hr1, hr2) ', Land_IAU_Data%hr1, Land_IAU_Data%hr2 - endif - ! Land_IAU_Data%snow_land_mask(:, :) = wk3_slmsk(itnext-1, :, :) + call updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) endif endif @@ -495,26 +481,18 @@ subroutine updateiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) type(land_iau_state_type), intent(in) :: Land_IAU_State real(kind=kind_phys) delt_t integer i,j,k - integer :: is, ie, js, je, npz, t1 - integer :: ntimes - integer :: t2 + integer :: is, ie, js, je, npz, t1, t2 t2 = Land_IAU_Data%itnext t1 = t2 - 1 - is = 1 !Land_IAU_Control%isc + is = 1 ! Land_IAU_Control%isc ie = is + Land_IAU_Control%nx-1 - js = 1 !Land_IAU_Control%jsc + js = 1 ! Land_IAU_Control%jsc je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil - ntimes = Land_IAU_Control%ntimes - delt_t = (Land_IAU_Data%hr2-(Land_IAU_Control%fhour))/(Land_IAU_Data%hr2-Land_IAU_Data%hr1) - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print *,'in land_iau updateiauforcing ntimes ', & - ntimes,Land_IAU_Control%iaufhrs(1:ntimes), & - " rdt wt delt_t ", Land_IAU_Data%rdt, Land_IAU_Data%wt, delt_t - endif + do j = js,je do i = is,ie do k = 1,npz ! do k = 1,n_soill ! @@ -535,15 +513,15 @@ subroutine setiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_State) integer i, j, k integer :: is, ie, js, je, npz - is = 1 !Land_IAU_Control%isc + is = 1 ie = is + Land_IAU_Control%nx-1 - js = 1 !Land_IAU_Control%jsc + js = 1 je = js + Land_IAU_Control%ny-1 npz = Land_IAU_Control%lsoil - ! this is only called if using 1 increment file + do j = js, je do i = is, ie - do k = 1, npz ! do k = 1,n_soill ! + do k = 1, npz Land_IAU_Data%stc_inc(i,j,k) = Land_IAU_Data%wt*Land_IAU_State%stc_inc(1,i,j,k)*Land_IAU_Data%rdt Land_IAU_Data%slc_inc(i,j,k) = Land_IAU_Data%wt*Land_IAU_State%slc_inc(1,i,j,k)*Land_IAU_Data%rdt end do @@ -612,38 +590,37 @@ subroutine read_iau_forcing_fv3(Land_IAU_Control, wk3_stc, wk3_slc, errmsg, errf allocate(wk3_stc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) allocate(wk3_slc(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny, km)) - ! allocate(wk3_slmsk(n_t, Land_IAU_Control%nx, Land_IAU_Control%ny)) do i = 1, size(stc_vars) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(stc_vars(i)) - ! call check_var_exists(ncid, trim(stc_vars(i)), ierr) status = nf90_inq_varid(ncid, trim(stc_vars(i)), varid) - if (status == nf90_noerr) then !if (ierr == 0) then + if (status == nf90_noerr) then do it = 1, n_t ! var stored as soilt1_inc(Time, yaxis_1, xaxis_1) call get_var3d_values(ncid, varid, trim(stc_vars(i)), Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & it, 1, wk3_stc(it,:, :, i), status, errflg, errmsg) - ! call netcdf_err(status, 'reading var: '//trim(stc_vars(i)), errflg, errmsg) if (errflg .ne. 0) return enddo else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, & - 'warning: no increment for ',trim(stc_vars(i)),' found, assuming zero' + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *, 'warning! No increment for ',trim(stc_vars(i)),' found, assuming zero' + endif wk3_stc(:, :, :, i) = 0. endif enddo do i = 1, size(slc_vars) if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *, trim(slc_vars(i)) status = nf90_inq_varid(ncid, trim(slc_vars(i)), varid) - if (status == nf90_noerr) then !if (status == 0) + if (status == nf90_noerr) then do it = 1, n_t call get_var3d_values(ncid, varid, trim(slc_vars(i)), Land_IAU_Control%isc, Land_IAU_Control%nx, Land_IAU_Control%jsc, Land_IAU_Control%ny, & it, 1, wk3_slc(it, :, :, i), status, errflg, errmsg) if (errflg .ne. 0) return end do else - if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) print *,& - 'warning: no increment for ',trim(slc_vars(i)),' found, assuming zero' + if (Land_IAU_Control%me == Land_IAU_Control%mpi_root) then + print *, 'warning! No increment for ',trim(slc_vars(i)),' found, assuming zero' + endif wk3_slc(:, :, :, i) = 0. endif enddo @@ -759,8 +736,8 @@ subroutine get_var1d(ncid, dim_len, var_name, var_arr, errflg, errmsg_out) status = nf90_inq_varid(ncid, trim(var_name), varid) call netcdf_err(status, 'getting varid: '//trim(var_name), errflg, errmsg_out) if (errflg .ne. 0) return + status = nf90_get_var(ncid, varid, var_arr) - ! start = (/1/), count = (/dim_len/)) call netcdf_err(status, 'reading var: '//trim(var_name), errflg, errmsg_out) end subroutine get_var1d @@ -769,7 +746,7 @@ subroutine get_var3d_values(ncid, varid, var_name, is,ix, js,jy, ks,kz, var3d, s integer, intent(in):: ncid, varid integer, intent(in):: is, ix, js, jy, ks,kz character(len=*), intent(in):: var_name - real(kind=kind_phys), intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) + real(kind=kind_phys), intent(out):: var3d(ix, jy, kz) integer, intent(out):: status integer :: errflg character(len=*) :: errmsg_out @@ -778,7 +755,7 @@ subroutine get_var3d_values(ncid, varid, var_name, is,ix, js,jy, ks,kz, var3d, s errmsg_out = '' errflg = 0 - status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) + status = nf90_get_var(ncid, varid, var3d, & start = (/is, js, ks/), count = (/ix, jy, kz/)) call netcdf_err(status, 'get_var3d_values '//trim(var_name), errflg, errmsg_out) @@ -790,7 +767,7 @@ subroutine get_var3d_values_int(ncid, varid, var_name, is,ix, js,jy, ks,kz, var3 integer, intent(in):: ncid, varid integer, intent(in):: is, ix, js, jy, ks,kz character(len=*), intent(in):: var_name - integer, intent(out):: var3d(ix, jy, kz) !var3d(is:ie,js:je,ks:ke) + integer, intent(out):: var3d(ix, jy, kz) integer, intent(out):: status integer :: errflg character(len=*) :: errmsg_out @@ -801,7 +778,6 @@ subroutine get_var3d_values_int(ncid, varid, var_name, is,ix, js,jy, ks,kz, var3 status = nf90_get_var(ncid, varid, var3d, & !start = start, count = nreco) start = (/is, js, ks/), count = (/ix, jy, kz/)) - ! start = (/is, js, ks/), count = (/ie - is + 1, je - js + 1, ke - ks + 1/)) call netcdf_err(status, 'get_var3d_values_int '//trim(var_name), errflg, errmsg_out) From b9e04297fc568d426921f1027b1e5a1036f94fc1 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 15 Nov 2024 08:54:36 -0500 Subject: [PATCH 152/154] clean noahmpdrv_timestep_init --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 80 +++++++------------- 1 file changed, 28 insertions(+), 52 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index ec3c2d5c3..a33da9c8f 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -13,12 +13,13 @@ module noahmpdrv use module_sf_noahmplsm -! Land IAU increments for soil temperature (plan to extend to soil moisture increments) +! These hold and apply Land IAU increments for soil temperature +! (possibly will extend to soil moisture increments) use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & land_iau_state_type use land_iau_mod, only: land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & - calculate_landinc_mask ! land_iau_mod_set_control, + calculate_landinc_mask implicit none integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS @@ -61,14 +62,16 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! land iau mod DDTs - ! Land IAU Control holds settings' information, maily read from namelist - ! (e.g., block of global domain that belongs to current process, - ! whether to do IAU increment at this time step, time step informatoin, etc) - ! made optional to allow NoahMP Component model call this function without having to deal with IAU + ! Land iau mod DDTs ! made optional to allow NoahMP Component model call this function without having to deal with IAU + + ! Land IAU Control holds settings' information, maily read from namelist + ! (e.g., block of global domain that belongs to current process, + ! whether to do IAU increment at this time step, time step informatoin, etc) type(land_iau_control_type), intent(inout), optional :: Land_IAU_Control + ! land iau state holds increment data read from file (before interpolation) - type(land_iau_state_type), intent(inout), optional :: Land_IAU_state + type(land_iau_state_type), intent(inout), optional :: Land_IAU_state + ! Land IAU Data holds spatially and temporally interpolated increments per time step type(land_iau_external_data_type), intent(inout), optional :: Land_IAU_Data ! arry of (number of blocks):each proc holds nblks @@ -121,9 +124,11 @@ subroutine noahmpdrv_init(lsm, lsm_noahmp, me, isot, ivegsrc, & resid (:) = drysmc (:) if (present(Land_IAU_Control) .and. present(Land_IAU_Data) .and. present(Land_IAU_State)) then + ! Initialize IAU for land--land_iau_control was set by host model if (.not. Land_IAU_Control%do_land_iau) return call land_iau_mod_init (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) + endif end subroutine noahmpdrv_init @@ -193,6 +198,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & integer :: nother, nsnowupd integer :: nstcupd, nslcupd, nfrozen, nfrozen_upd + logical :: print_update_stats = .False. ! --- Initialize CCPP error handling variables errmsg = '' @@ -200,33 +206,20 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & if (.not. Land_IAU_Control%do_land_iau) return - !> update current forecast hour - ! GFS_control%jdat(:) = jdat(:) - Land_IAU_Control%fhour=fhour - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*,"itime ",itime," GFScont%fhour ",fhour," IauCon%fhour",Land_IAU_Control%fhour, & - " delt ",delt," IauCont%dtp",Land_IAU_Control%dtp - endif + !> update current forecast hour + Land_IAU_Control%fhour=fhour !> read iau increments - call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state, errmsg, errflg) !call getiauforcing(GFS_control,IAU_data) + call land_iau_mod_getiauforcing(Land_IAU_Control, Land_IAU_Data, Land_IAU_state, errmsg, errflg) if (errflg .ne. 0) then - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "noahmpdrv_timestep_init: lnd_iau_mod_getiauforcing returned nonzero value" - print*, errmsg - endif return endif - !> update land states with iau increments + !> If no increment at the current timestep simply proceed forward if (.not. Land_IAU_Data%in_interval) then - if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "noahmpdrv_timestep_init: current time step not in Land iau interval " - endif return endif - ! if (Land_IAU_Data%in_interval) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then print*, "adding land iau increments " endif @@ -242,23 +235,22 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & allocate(slc_inc_flat(Land_IAU_Control%nx * Land_IAU_Control%ny, km)) !GFS_Control%ncols allocate(stc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) allocate(slc_updated(Land_IAU_Control%nx * Land_IAU_Control%ny)) - !copy background stc + !copy background stc stc_updated = 0 slc_updated = 0 ib = 1 - do j = 1, Land_IAU_Control%ny !ny + do j = 1, Land_IAU_Control%ny do k = 1, km stc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%stc_inc(:,j, k) slc_inc_flat(ib:ib+Land_IAU_Control%nx-1, k) = Land_IAU_Data%slc_inc(:,j, k) enddo - ib = ib + Land_IAU_Control%nx !nlon + ib = ib + Land_IAU_Control%nx enddo - ! delt=GFS_Control%dtf if ((Land_IAU_Control%dtp - delt) > 0.0001) then if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) then - print*, "Warning noahmpdrv_timestep_init delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp + print*, "Warning! noahmpdrv_timestep_init delt ",delt," different from Land_IAU_Control%dtp ",Land_IAU_Control%dtp endif endif @@ -276,14 +268,14 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & !TODO---if only fv3 increment files are used, this can be read from file allocate(mask_tile(lensfc)) - call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !& !veg_type_landice, + call calculate_landinc_mask(weasd, vegtype, soiltyp, lensfc, isice_table, mask_tile) !IAU increments are in units of 1/sec !Land_IAU_Control%dtp !* only updating soil temp for now ij_loop : do ij = 1, lensfc ! mask: 1 - soil, 2 - snow, 0 - land-ice, -1 - not land if (mask_tile(ij) == 1) then - ! if(Land_IAU_Control%me == Land_IAU_Control%mpi_root) print*, "root proc layer 1 stc, inc ", stc(ij,1), stc_inc_flat(ij,1) + soil_freeze=.false. soil_ice=.false. do k = 1, lsoil_incr ! k = 1, km @@ -309,22 +301,16 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & endif ! apply zero limit here (higher, model-specific limits are later) slc(ij,k) = max(slc(ij,k) + slc_inc_flat(ij,k)*delt, 0.0) - smc(ij,k) = max(smc(ij,k) + slc_inc_flat(ij,k)*delt, 0.0) - ! slc_state(ij,k) = max(slc_state(ij,k) + slcinc(ij,k), 0.0) - ! smc_state(ij,k) = max(smc_state(ij,k) + slcinc(ij,k), 0.0) + smc(ij,k) = max(smc(ij,k) + slc_inc_flat(ij,k)*delt, 0.0) endif else if (k==1) nfrozen = nfrozen+1 - ! ! moisture updates not done if this layer or any above is frozen - ! if ( soil_freeze .or. soil_ice ) then - ! if (k==1) nfrozen = nfrozen+1 - ! endif endif enddo endif ! if soil/snow point enddo ij_loop - deallocate(stc_inc_flat, slc_inc_flat) !, tmp2m_inc_flat,spfh2m_inc_flat) + deallocate(stc_inc_flat, slc_inc_flat) !!do moisture/temperature adjustment for consistency after increment add call read_mp_table_parameters(errmsg, errflg) @@ -382,17 +368,7 @@ subroutine noahmpdrv_timestep_init (itime, fhour, delt, km, ncols, & deallocate(stc_updated, slc_updated) deallocate(mask_tile) - - write(*,'(a,i2)') ' noahmpdrv_timestep_init: statistics of grids with stc/smc updates for rank : ', Land_IAU_Control%me - write(*,'(a,i8)') ' soil grid total', lensfc - write(*,'(a,i8)') ' soil grid cells stc updated = ',nstcupd - write(*,'(a,i8)') ' soil grid cells slc updated = ',nslcupd - write(*,'(a,i8)') ' soil grid cells not updated, frozen = ',nfrozen - write(*,'(a,i8)') ' soil grid cells update, became frozen = ',nfrozen_upd - write(*,'(a,i8)') ' (not updated yet) snow grid cells = ', nsnowupd - write(*,'(a,i8)') ' grid cells, without soil or snow = ', nother - write(*,'(a,i8)') ' soil grid cells with stc adjustment', n_stc - write(*,'(a,i8)') ' soil grid cells with slc adjustment', n_slc + write(*,'(a,i4,a,i8)') 'noahmpdrv_timestep_init rank ', Land_IAU_Control%me, ' # of cells with stc update ', nstcupd end subroutine noahmpdrv_timestep_init @@ -418,7 +394,7 @@ subroutine noahmpdrv_finalize (Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errflg = 0 if (.not. Land_IAU_Control%do_land_iau) return - call land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) !Land_IAU_Control%finalize() + call land_iau_mod_finalize(Land_IAU_Control, Land_IAU_Data, Land_IAU_State, errmsg, errflg) end subroutine noahmpdrv_finalize From 4343656a098516517257c0913689f70a81579e74 Mon Sep 17 00:00:00 2001 From: Tseganeh Gichamo <1621305073113305@mil> Date: Fri, 15 Nov 2024 12:40:29 -0500 Subject: [PATCH 153/154] combine use lnd_iau_mod lines --- physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index a33da9c8f..d4971efd9 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -15,11 +15,9 @@ module noahmpdrv ! These hold and apply Land IAU increments for soil temperature ! (possibly will extend to soil moisture increments) - use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, & - land_iau_state_type - - use land_iau_mod, only: land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, & - calculate_landinc_mask + use land_iau_mod, only: land_iau_control_type, land_iau_external_data_type, land_iau_state_type, & + land_iau_mod_init, land_iau_mod_getiauforcing, land_iau_mod_finalize, calculate_landinc_mask + implicit none integer, parameter :: psi_opt = 0 ! 0: MYNN or 1:GFS From 9dffb7e1cd5fceebec065299c791e65e3a30e0c2 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 21 Nov 2024 14:04:01 -0500 Subject: [PATCH 154/154] fix trailing whitespace in mp_thompson.F90 --- physics/MP/Thompson/mp_thompson.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/MP/Thompson/mp_thompson.F90 b/physics/MP/Thompson/mp_thompson.F90 index 8e8e95dfa..b14d9f69b 100644 --- a/physics/MP/Thompson/mp_thompson.F90 +++ b/physics/MP/Thompson/mp_thompson.F90 @@ -8,7 +8,7 @@ module mp_thompson use mpi_f08 use machine, only : kind_phys - + use module_mp_thompson, only : thompson_init, mp_gt_driver, thompson_finalize, calc_effectRad use module_mp_thompson, only : naIN0, naIN1, naCCN0, naCCN1, eps, Nt_c_l, Nt_c_o use module_mp_thompson, only : re_qc_min, re_qc_max, re_qi_min, re_qi_max, re_qs_min, re_qs_max