From e48c99cea2dc1029cedd6d5b40d8ab83f3986a31 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 20 Aug 2019 11:40:17 -0600 Subject: [PATCH 01/59] initial addition of CCPP metadata for NoahMP --- physics/module_sf_noahmp_glacier.f90 | 2988 ++++++++++ physics/module_sf_noahmplsm.f90 | 8197 ++++++++++++++++++++++++++ physics/module_wrf_utl.f90 | 50 + physics/noahmp_tables.f90 | 955 +++ physics/sfc_noahmp_drv.f | 1142 ++++ physics/sfc_noahmp_drv.meta | 1069 ++++ 6 files changed, 14401 insertions(+) create mode 100755 physics/module_sf_noahmp_glacier.f90 create mode 100755 physics/module_sf_noahmplsm.f90 create mode 100755 physics/module_wrf_utl.f90 create mode 100755 physics/noahmp_tables.f90 create mode 100755 physics/sfc_noahmp_drv.f create mode 100644 physics/sfc_noahmp_drv.meta diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 new file mode 100755 index 000000000..a26e108e4 --- /dev/null +++ b/physics/module_sf_noahmp_glacier.f90 @@ -0,0 +1,2988 @@ +module noahmp_glacier_globals + + implicit none + +! ================================================================================================== +!------------------------------------------------------------------------------------------! +! physical constants: ! +!------------------------------------------------------------------------------------------! + + real, parameter :: grav = 9.80616 !acceleration due to gravity (m/s2) + real, parameter :: sb = 5.67e-08 !stefan-boltzmann constant (w/m2/k4) + real, parameter :: vkc = 0.40 !von karman constant + real, parameter :: tfrz = 273.16 !freezing/melting point (k) + real, parameter :: hsub = 2.8440e06 !latent heat of sublimation (j/kg) + real, parameter :: hvap = 2.5104e06 !latent heat of vaporization (j/kg) + real, parameter :: hfus = 0.3336e06 !latent heat of fusion (j/kg) + real, parameter :: cwat = 4.188e06 !specific heat capacity of water (j/m3/k) + real, parameter :: cice = 2.094e06 !specific heat capacity of ice (j/m3/k) + real, parameter :: cpair = 1004.64 !heat capacity dry air at const pres (j/kg/k) + real, parameter :: tkwat = 0.6 !thermal conductivity of water (w/m/k) + real, parameter :: tkice = 2.2 !thermal conductivity of ice (w/m/k) + real, parameter :: tkair = 0.023 !thermal conductivity of air (w/m/k) + real, parameter :: rair = 287.04 !gas constant for dry air (j/kg/k) + real, parameter :: rw = 461.269 !gas constant for water vapor (j/kg/k) + real, parameter :: denh2o = 1000. !density of water (kg/m3) + real, parameter :: denice = 917. !density of ice (kg/m3) + +! =====================================options for different schemes================================ +! options for dynamic vegetation: +! 1 -> off (use table lai; use fveg = shdfac from input) +! 2 -> on (together with opt_crs = 1) +! 3 -> off (use table lai; calculate fveg) +! 4 -> off (use table lai; use maximum vegetation fraction) + + integer :: dveg != 2 ! + +! options for canopy stomatal resistance +! 1-> ball-berry; 2->jarvis + + integer :: opt_crs != 1 !(must 1 when dveg = 2) + +! options for soil moisture factor for stomatal resistance +! 1-> noah (soil moisture) +! 2-> clm (matric potential) +! 3-> ssib (matric potential) + + integer :: opt_btr != 1 !(suggested 1) + +! options for runoff and groundwater +! 1 -> topmodel with groundwater (niu et al. 2007 jgr) ; +! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ; +! 3 -> original surface and subsurface runoff (free drainage) +! 4 -> bats surface and subsurface runoff (free drainage) + + integer :: opt_run != 1 !(suggested 1) + +! options for surface layer drag coeff (ch & cm) +! 1->m-o ; 2->original noah (chen97); 3->myj consistent; 4->ysu consistent. + + integer :: opt_sfc != 1 !(1 or 2 or 3 or 4) + +! options for supercooled liquid water (or ice fraction) +! 1-> no iteration (niu and yang, 2006 jhm); 2: koren's iteration + + integer :: opt_frz != 1 !(1 or 2) + +! options for frozen soil permeability +! 1 -> linear effects, more permeable (niu and yang, 2006, jhm) +! 2 -> nonlinear effects, less permeable (old) + + integer :: opt_inf != 1 !(suggested 1) + +! options for radiation transfer +! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg) +! 2 -> two-stream applied to grid-cell (gap = 0) +! 3 -> two-stream applied to vegetated fraction (gap=1-fveg) + + integer :: opt_rad != 1 !(suggested 1) + +! options for ground snow surface albedo +! 1-> bats; 2 -> class + + integer :: opt_alb != 2 !(suggested 2) + +! options for partitioning precipitation into rainfall & snowfall +! 1 -> jordan (1991); 2 -> bats: when sfctmp sfctmp zero heat flux from bottom (zbot and tbot not used) +! 2 -> tbot at zbot (8m) read from a file (original noah) + + integer :: opt_tbot != 2 !(suggested 2) + +! options for snow/soil temperature time scheme (only layer 1) +! 1 -> semi-implicit; 2 -> full implicit (original noah) + + integer :: opt_stc != 1 !(suggested 1) + +! adjustable parameters for snow processes + + real, parameter :: z0sno = 0.002 !snow surface roughness length (m) (0.002) + real, parameter :: ssi = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + real, parameter :: swemx = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + +!------------------------------------------------------------------------------------------! +end module noahmp_glacier_globals +!------------------------------------------------------------------------------------------! + +module noahmp_glacier_routines + use noahmp_glacier_globals + use module_wrf_utl + implicit none + + public :: noahmp_options_glacier + public :: noahmp_glacier + + private :: atm_glacier + private :: energy_glacier + private :: thermoprop_glacier + private :: csnow_glacier + private :: radiation_glacier + private :: snow_age_glacier + private :: snowalb_bats_glacier + private :: snowalb_class_glacier + private :: glacier_flux + private :: sfcdif1_glacier + private :: tsnosoi_glacier + private :: hrt_glacier + private :: hstep_glacier + private :: rosr12_glacier + private :: phasechange_glacier + + private :: water_glacier + private :: snowwater_glacier + private :: snowfall_glacier + private :: combine_glacier + private :: divide_glacier + private :: combo_glacier + private :: compact_glacier + private :: snowh2o_glacier + + private :: error_glacier + +contains +! +! ================================================================================================== + + subroutine noahmp_glacier (& + iloc ,jloc ,cosz ,nsnow ,nsoil ,dt , & ! in : time/space/model-related + sfctmp ,sfcprs ,uu ,vv ,q2 ,soldn , & ! in : forcing + prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing + qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : + sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : + tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : + fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : + trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : + qsnbot ,ponding ,ponding1,ponding2,t2m ,q2e , & ! out : + emissi, fpice ,ch2b , esnow) + +! -------------------------------------------------------------------------------------------------- +! initial code: guo-yue niu, oct. 2007 +! modified to glacier: michael barlage, june 2012 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !no. of soil layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: uu !wind speed in eastward dir (m/s) + real , intent(in) :: vv !wind speed in northward dir (m/s) + real , intent(in) :: q2 !mixing ratio (kg/kg) lowest model layer + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: tbot !bottom condition for soil temp. [k] + real , intent(in) :: zlvl !reference height (m) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + + +! input/output : need arbitary intial values + real , intent(inout) :: qsnow !snowfall [mm/s] + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , intent(inout) :: albold !snow albedo at last time step (class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + +! prognostic variables + integer , intent(inout) :: isnow !actual no. of snow layers [-] + real , intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + real , intent(inout) :: snowh !snow height [m] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real , intent(inout) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , intent(inout) :: tauss !non-dimensional snow age + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +! output + real , intent(out) :: fsa !total absorbed solar radiation (w/m2) + real , intent(out) :: fsr !total reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evap heat (w/m2) [+ to atm] + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: trad !surface radiative temperature (k) + real , intent(out) :: edir !soil surface evaporation rate (mm/s] + real , intent(out) :: runsrf !surface runoff [mm/s] + real , intent(out) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(out) :: sag !solar rad absorbed by ground (w/m2) + real , intent(out) :: albedo !surface albedo [-] + real , intent(out) :: qsnbot !snowmelt [mm/s] + real , intent(out) :: ponding!surface ponding [mm] + real , intent(out) :: ponding1!surface ponding [mm] + real , intent(out) :: ponding2!surface ponding [mm] + real , intent(out) :: t2m !2-m air temperature over bare ground part [k] + real , intent(out) :: q2e + real , intent(out) :: emissi + real , intent(out) :: fpice + real , intent(out) :: ch2b + real , intent(out) :: esnow + +! local + integer :: iz !do-loop index + integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] + real :: rhoair !density air (kg/m3) + real, dimension(-nsnow+1:nsoil) :: dzsnso !snow/soil layer thickness [m] + real :: thair !potential temperature (k) + real :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real :: eair !vapor pressure air (pa) + real, dimension( 1: 2) :: solad !incoming direct solar rad (w/m2) + real, dimension( 1: 2) :: solai !incoming diffuse solar rad (w/m2) + real, dimension( 1:nsoil) :: sice !soil ice content (m3/m3) + real, dimension(-nsnow+1: 0) :: snicev !partial volume ice of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: snliqv !partial volume liq of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: epore !effective porosity [m3/m3] + real :: qdew !ground surface dew rate [mm/s] + real :: qvap !ground surface evap. rate [mm/s] + real :: lathea !latent heat [j/kg] + real :: qmelt !internal pack melt + real :: swdown !downward solar [w/m2] + real :: beg_wb !beginning water for error check + real :: zbot = -8.0 + + character*256 message + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + call atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + qair ,eair ,rhoair ,solad ,solai ,swdown ) + + beg_wb = sneqv + +! snow/soil layer thickness (m); interface depth: zsnso < 0; layer thickness dzsnso > 0 + + do iz = isnow+1, nsoil + if(iz == isnow+1) then + dzsnso(iz) = - zsnso(iz) + else + dzsnso(iz) = zsnso(iz-1) - zsnso(iz) + end if + end do + +! compute energy budget (momentum & energy fluxes and phase changes) + + call energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !in + eair ,sfcprs ,qair ,sfctmp ,lwdn ,uu , & !in + vv ,solad ,solai ,cosz ,zlvl , & !in + tbot ,zbot ,zsnso ,dzsnso , & !in + tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout + smc ,snice ,snliq ,albold ,cm ,ch , & !inout + tauss ,qsfc , & !inout + imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + + sice = max(0.0, smc - sh2o) + sneqvo = sneqv + + qvap = max( fgev/lathea, 0.) ! positive part of fgev [mm/s] > 0 + qdew = abs( min(fgev/lathea, 0.)) ! negative part of fgev [mm/s] > 0 + edir = qvap - qdew + +! compute water budgets (water storages, et components, and runoff) + + call water_glacier (nsnow ,nsoil ,imelt ,dt ,prcp ,sfctmp , & !in + qvap ,qdew ,ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout + dzsnso ,sh2o ,sice ,ponding,zsnso , & !inout + runsrf ,runsub ,qsnow ,ponding1 ,ponding2,qsnbot,fpice,esnow & !out + ) + +! if(maxval(sice) < 0.0001) then +! write(message,*) "glacier has melted at:",iloc,jloc," are you sure this should be a glacier point?" +! call wrf_debug(10,trim(message)) +! end if + +! water and energy balance check + + call error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & + fsh ,fgev ,ssoil ,sag ,prcp ,edir , & + runsrf ,runsub ,sneqv ,dt ,beg_wb ) + + if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then + snowh = 0.0 + sneqv = 0.0 + end if + + if(swdown.ne.0.) then + albedo = fsr / swdown + else + albedo = -999.9 + end if + + + end subroutine noahmp_glacier +! ================================================================================================== + subroutine atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + qair ,eair ,rhoair ,solad ,solai , & + swdown ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + +! outputs + + real , intent(out) :: thair !potential temperature (k) + real , intent(out) :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real , intent(out) :: eair !vapor pressure air (pa) + real, dimension( 1: 2), intent(out) :: solad !incoming direct solar radiation (w/m2) + real, dimension( 1: 2), intent(out) :: solai !incoming diffuse solar radiation (w/m2) + real , intent(out) :: rhoair !density air (kg/m3) + real , intent(out) :: swdown !downward solar filtered by sun angle [w/m2] + +!locals + + real :: pair !atm bottom level pressure (pa) +! -------------------------------------------------------------------------------------------------- + + pair = sfcprs ! atm bottom level pressure (pa) + thair = sfctmp * (sfcprs/pair)**(rair/cpair) +! qair = q2 / (1.0+q2) ! mixing ratio to specific humidity [kg/kg] + qair = q2 ! in wrf, driver converts to specific humidity + + eair = qair*sfcprs / (0.622+0.378*qair) + rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + + if(cosz <= 0.) then + swdown = 0. + else + swdown = soldn + end if + + solad(1) = swdown*0.7*0.5 ! direct vis + solad(2) = swdown*0.7*0.5 ! direct nir + solai(1) = swdown*0.3*0.5 ! diffuse vis + solai(2) = swdown*0.3*0.5 ! diffuse nir + + end subroutine atm_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !in + eair ,sfcprs ,qair ,sfctmp ,lwdn ,uu , & !in + vv ,solad ,solai ,cosz ,zref , & !in + tbot ,zbot ,zsnso ,dzsnso , & !in + tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout + smc ,snice ,snliq ,albold ,cm ,ch , & !inout + tauss ,qsfc , & !inout + imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + +! -------------------------------------------------------------------------------------------------- +! -------------------------------------------------------------------------------------------------- +! use noahmp_veg_parameters +! use noahmp_rad_parameters +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: qsnow !snowfall on the ground (mm/s) + real , intent(in) :: rhoair !density air (kg/m3) + real , intent(in) :: eair !vapor pressure air (pa) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: qair !specific humidity (kg/kg) + real , intent(in) :: sfctmp !air temperature (k) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: uu !wind speed in e-w dir (m/s) + real , intent(in) :: vv !wind speed in n-s dir (m/s) + real , dimension( 1: 2), intent(in) :: solad !incoming direct solar rad. (w/m2) + real , dimension( 1: 2), intent(in) :: solai !incoming diffuse solar rad. (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle (0-1) + real , intent(in) :: zref !reference height (m) + real , intent(in) :: tbot !bottom condition for soil temp. (k) + real , intent(in) :: zbot !depth for tbot [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bottom depth from snow surf [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !depth of snow & soil layer-bottom [m] + +! input & output + real , intent(inout) :: tg !ground temperature (k) + real , dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real , intent(inout) :: snowh !snow height [m] + real , intent(inout) :: sneqv !snow mass (mm) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real , dimension(-nsnow+1: 0), intent(inout) :: snice !snow ice mass (kg/m2) + real , dimension(-nsnow+1: 0), intent(inout) :: snliq !snow liq mass (kg/m2) + real , intent(inout) :: albold !snow albedo at last time step(class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: tauss !snow aging factor + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +! outputs + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] + real , dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume ice [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume liq. water [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real , intent(out) :: qmelt !snowmelt [mm/s] + real , intent(out) :: ponding!pounding at ground [mm] + real , intent(out) :: sag !solar rad. absorbed by ground (w/m2) + real , intent(out) :: fsa !tot. absorbed solar radiation (w/m2) + real , intent(out) :: fsr !tot. reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw. rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evaporation (w/m2) [+ to atm] + real , intent(out) :: trad !radiative temperature (k) + real , intent(out) :: t2m !2 m height air temperature (k) + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: lathea !latent heat vap./sublimation (j/kg) + real , intent(out) :: q2e + real , intent(out) :: emissi + real , intent(out) :: ch2b !sensible heat conductance, canopy air to zlvl air (m/s) + + +! local + real :: ur !wind speed at height zlvl (m/s) + real :: zlvl !reference height (m) + real :: rsurf !ground surface resistance (s/m) + real :: zpd !zero plane displacement (m) + real :: z0mg !z0 momentum, ground (m) + real :: emg !ground emissivity + real :: fire !emitted ir (w/m2) + real, dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change + real, dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k] + real :: gamma !psychrometric constant (pa/k) + real :: rhsur !raltive humidity in surface soil/snow air space (-) + +! --------------------------------------------------------------------------------------------------- + +! wind speed at reference height: ur >= 1 + + ur = max( sqrt(uu**2.+vv**2.), 1. ) + +! roughness length and displacement height + + z0mg = z0sno + zpd = snowh + + zlvl = zpd + zref + +! thermal properties of soil, snow, lake, and frozen soil + + call thermoprop_glacier (nsoil ,nsnow ,isnow ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out + +! solar radiation: absorbed & reflected by the ground + + call radiation_glacier (dt ,tg ,sneqvo ,sneqv ,cosz , & !in + qsnow ,solad ,solai , & !in + albold ,tauss , & !inout + sag ,fsr ,fsa) !out + +! vegetation and ground emissivity + + emg = 0.98 + +! soil surface resistance for ground evap. + + rhsur = 1.0 + rsurf = 1.0 + +! set psychrometric constant + + lathea = hsub + gamma = cpair*sfcprs/(0.622*lathea) + +! surface temperatures of the ground and energy fluxes + + call glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0mg , & !in + zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + cm ,ch ,tg ,qsfc , & !inout + fira ,fsh ,fgev ,ssoil , & !out + t2m ,q2e ,ch2b) !out + +!energy balance at surface: sag=(irb+shb+evb+ghb) + + fire = lwdn + fira + + if(fire <=0.) call wrf_error_fatal("stop in noah-mp: emitted longwave <0") + + ! compute a net emissivity + emissi = emg + + ! when we're computing a trad, subtract from the emitted ir the + ! reflected portion of the incoming lwdn, so we're just + ! considering the ir originating in the canopy/ground system. + + trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25 + +! 3l snow & 4l soil temperatures + + call tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in + ssoil ,snowh ,zbot ,zsnso ,df , & !in + hcpct , & !in + stc ) !inout + +! adjusting snow surface temperature + if(opt_stc == 2) then + if (snowh > 0.05 .and. tg > tfrz) tg = tfrz + end if + +! energy released or consumed by snow & frozen soil + + call phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out + + + end subroutine energy_glacier +! ================================================================================================== + subroutine thermoprop_glacier (nsoil ,nsnow ,isnow ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out +! ------------------------------------------------------------------------------------------------- +! ------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [s] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers [m] + real , intent(in) :: snowh !snow height [m] + +! outputs + real, dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(out) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(out) :: fact !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + integer :: iz, iz2 + real, dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) + real :: zmid !mid-point soil depth +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + call csnow_glacier (isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out + + do iz = isnow+1, 0 + df (iz) = tksno(iz) + hcpct(iz) = cvsno(iz) + end do + +! compute soil thermal properties (using noah glacial ice approximations) + + do iz = 1, nsoil + zmid = 0.5 * (dzsnso(iz)) + do iz2 = 1, iz-1 + zmid = zmid + dzsnso(iz2) + end do + hcpct(iz) = 1.e6 * ( 0.8194 + 0.1309*zmid ) + df(iz) = 0.32333 + ( 0.10073 * zmid ) + end do + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + do iz = isnow+1,nsoil + fact(iz) = dt/(hcpct(iz)*dzsnso(iz)) + end do + +! snow/soil interface + + if(isnow == 0) then + df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1)) + else + df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1)) + end if + + + end subroutine thermoprop_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine csnow_glacier (isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out +! -------------------------------------------------------------------------------------------------- +! snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + implicit none +!--------------------------------------------------------------------------------------------------- +! inputs + + integer, intent(in) :: isnow !number of snow layers (-) + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! outputs + + real, dimension(-nsnow+1: 0), intent(out) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0), intent(out) :: tksno !thermal conductivity (w/m/k) + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + do iz = isnow+1, 0 + snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) ) + epore(iz) = 1. - snicev(iz) + snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o)) + enddo + + do iz = isnow+1, 0 + bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz) + cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz) +! cvsno(iz) = 0.525e06 ! constant + enddo + +! thermal conductivity of snow + + do iz = isnow+1, 0 + tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 +! tksno(iz) = 0.35 ! constant +! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) +! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) + enddo + + end subroutine csnow_glacier +!=================================================================================================== + subroutine radiation_glacier (dt ,tg ,sneqvo ,sneqv ,cosz , & !in + qsnow ,solad ,solai , & !in + albold ,tauss , & !inout + sag ,fsr ,fsa) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + real, intent(in) :: dt !time step [s] + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, intent(in) :: qsnow !snowfall (mm/s) + real, dimension(1:2) , intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2) , intent(in) :: solai !incoming diffuse solar radiation (w/m2) + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age + +! output + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + +! local + integer :: ib !number of radiation bands + integer :: nband !number of radiation bands + real :: fage !snow age function (0 - new snow) + real, dimension(1:2) :: albsnd !snow albedo (direct) + real, dimension(1:2) :: albsni !snow albedo (diffuse) + real :: alb !current class albedo + real :: abs !temporary absorbed rad + real :: ref !temporary reflected rad + real :: fsno !snow-cover fraction, = 1 if any snow + real, dimension(1:2) :: albice !albedo land ice: 1=vis, 2=nir + + real,parameter :: mpe = 1.e-6 + +! -------------------------------------------------------------------------------------------------- + + nband = 2 + albsnd = 0.0 + albsni = 0.0 + albice(1) = 0.80 !albedo land ice: 1=vis, 2=nir + albice(2) = 0.55 + +! snow age + + call snow_age_glacier (dt,tg,sneqvo,sneqv,tauss,fage) + +! snow albedos: age even when sun is not present + + if(opt_alb == 1) & + call snowalb_bats_glacier (nband,cosz,fage,albsnd,albsni) + if(opt_alb == 2) then + call snowalb_class_glacier(nband,qsnow,dt,alb,albold,albsnd,albsni) + albold = alb + end if + +! zero summed solar fluxes + + sag = 0. + fsa = 0. + fsr = 0. + + fsno = 0.0 + if(sneqv > 0.0) fsno = 1.0 + +! loop over nband wavebands + + do ib = 1, nband + + albsnd(ib) = albice(ib)*(1.-fsno) + albsnd(ib)*fsno + albsni(ib) = albice(ib)*(1.-fsno) + albsni(ib)*fsno + +! solar radiation absorbed by ground surface + + abs = solad(ib)*(1.-albsnd(ib)) + solai(ib)*(1.-albsni(ib)) + sag = sag + abs + fsa = fsa + abs + + ref = solad(ib)*albsnd(ib) + solai(ib)*albsni(ib) + fsr = fsr + ref + + end do + + end subroutine radiation_glacier +! ================================================================================================== + subroutine snow_age_glacier (dt,tg,sneqvo,sneqv,tauss,fage) +! -------------------------------------------------------------------------------------------------- + implicit none +! ------------------------ code history ------------------------------------------------------------ +! from bats +! ------------------------ input/output variables -------------------------------------------------- +!input + real, intent(in) :: dt !main time step (s) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow water per unit ground area (mm) + +! inout + real, intent(inout) :: tauss !non-dimensional snow age + +!output + real, intent(out) :: fage !snow age + +!local + real :: tage !total aging effects + real :: age1 !effects of grain growth due to vapor diffusion + real :: age2 !effects of grain growth at freezing of melt water + real :: age3 !effects of soot + real :: dela !temporary variable + real :: sge !temporary variable + real :: dels !temporary variable + real :: dela0 !temporary variable + real :: arg !temporary variable +! see yang et al. (1997) j.of climate for detail. +!--------------------------------------------------------------------------------------------------- + + if(sneqv.le.0.0) then + tauss = 0. + else if (sneqv.gt.800.) then + tauss = 0. + else +! tauss = 0. + dela0 = 1.e-6*dt + arg = 5.e3*(1./tfrz-1./tg) + age1 = exp(arg) + age2 = exp(amin1(0.,10.*arg)) + age3 = 0.3 + tage = age1+age2+age3 + dela = dela0*tage + dels = amax1(0.0,sneqv-sneqvo) / swemx + sge = (tauss+dela)*(1.0-dels) + tauss = amax1(0.,sge) + endif + + fage= tauss/(tauss+1.) + + end subroutine snow_age_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine snowalb_bats_glacier (nband,cosz,fage,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: cosz !cosine solar zenith angle + real,intent(in) :: fage !snow age correction + +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + + real :: fzen !zenith angle correction + real :: cf1 !temperary variable + real :: sl2 !2.*sl + real :: sl1 !1/sl + real :: sl !adjustable parameter + real, parameter :: c1 = 0.2 !default in bats + real, parameter :: c2 = 0.5 !default in bats +! real, parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's +! real, parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + sl=2.0 + sl1=1./sl + sl2=2.*sl + cf1=((1.+sl1)/(1.+sl2*cosz)-sl1) + fzen=amax1(cf1,0.) + + albsni(1)=0.95*(1.-c1*fage) + albsni(2)=0.65*(1.-c2*fage) + + albsnd(1)=albsni(1)+0.4*fzen*(1.-albsni(1)) ! vis direct + albsnd(2)=albsni(2)+0.4*fzen*(1.-albsni(2)) ! nir direct + + end subroutine snowalb_bats_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine snowalb_class_glacier (nband,qsnow,dt,alb,albold,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: qsnow !snowfall (mm/s) + real,intent(in) :: dt !time step (sec) + real,intent(in) :: albold !snow albedo at last time step + +! in & out + + real, intent(inout) :: alb ! +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.) + +! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + if (qsnow > 0.) then + alb = alb + min(qsnow*dt,swemx) * (0.84-alb)/(swemx) + endif + + albsni(1)= alb ! vis diffuse + albsni(2)= alb ! nir diffuse + albsnd(1)= alb ! vis direct + albsnd(2)= alb ! nir direct + + end subroutine snowalb_class_glacier +! ================================================================================================== + subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0m , & !in + zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + cm ,ch ,tgb ,qsfc , & !inout + irb ,shb ,evb ,ghb , & !out + t2mb ,q2b ,ehb2) !out + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for glacier. + +! bare soil: +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 +! ---------------------------------------------------------------------- +! use module_model_constants +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + real, intent(in) :: emg !ground emissivity + integer, intent(in) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: qair !specific humidity at height zlvl (kg/kg) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: sfcprs !density air (kg/m3) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: gamma !psychrometric constant (pa/k) + real, intent(in) :: rsurf !ground surface resistance (s/m) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + real, intent(in) :: eair !vapor pressure air at height (pa) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture + real, dimension( 1:nsoil), intent(in) :: sh2o !soil liquid water + real, intent(in) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(in) :: snowh !actual snow depth [m] + real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + +! input/output + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + real, intent(inout) :: tgb !ground temperature (k) + real, intent(inout) :: qsfc !mixing ratio at lowest model layer + +! output +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 + real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] + real, intent(out) :: shb !sensible heat flux (w/m2) [+ to atm] + real, intent(out) :: evb !latent heat flux (w/m2) [+ to atm] + real, intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] + real, intent(out) :: t2mb !2 m height air temperature (k) + real, intent(out) :: q2b !bare ground heat conductance + real, intent(out) :: ehb2 !sensible heat conductance for diagnostics + + +! local variables + integer :: niterb !number of iterations for surface temperature + real :: mpe !prevents overflow error if division by zero + real :: dtg !change in tg, last iteration (k) + integer :: mozsgn !number of times moz changes sign + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + real :: h !temporary sensible heat flux (w/m2) + real :: fv !friction velocity (m/s) + real :: cir !coefficients for ir as function of ts**4 + real :: cgh !coefficients for st as function of ts + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cq2b ! + integer :: iter !iteration index + real :: z0h !roughness length, sensible heat, ground (m) + real :: moz !monin-obukhov stability parameter + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + real :: ramb !aerodynamic resistance for momentum (s/m) + real :: rahb !aerodynamic resistance for sensible heat (s/m) + real :: rawb !aerodynamic resistance for water vapor (s/m) + real :: estg !saturation vapor pressure at tg (pa) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + real :: a !temporary calculation + real :: b !temporary calculation + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + real, dimension( 1:nsoil) :: sice !soil ice + + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + niterb = 5 + mpe = 1e-6 + dtg = 0. + mozsgn = 0 + mozold = 0. + h = 0. + fv = 0.1 + + cir = emg*sb + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + +! ----------------------------------------------------------------- + loop3: do iter = 1, niterb ! begin stability iteration + + z0h = z0m + +! for now, only allow sfcdif1 until others can be fixed + + call sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in + qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & fv ,cm ,ch ,ch2) !out + + ramb = max(1.,1./(cm*ur)) + rahb = max(1.,1./(ch*ur)) + rawb = rahb + +! es and d(es)/dt evaluated at tg + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + csh = rhoair*cpair/rahb + cev = rhoair*cpair/gamma/(rsurf+rawb) + +! surface fluxes and dtg + + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp ) + evb = cev * (estg*rhsur - eair ) + ghb = cgh * (tgb - stc(isnow+1)) + + b = sag-irb-shb-evb-ghb + a = 4.*cir*tgb**3 + csh + cev*destg + cgh + dtg = b/a + + irb = irb + 4.*cir*tgb**3*dtg + shb = shb + csh*dtg + evb = evb + cev*destg*dtg + ghb = ghb + cgh*dtg + +! update ground surface temperature + tgb = tgb + dtg + +! for m-o length + h = csh * (tgb - sfctmp) + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + + end do loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + sice = smc - sh2o + if(opt_stc == 1) then + if ((maxval(sice) > 0.0 .or. snowh > 0.0) .and. tgb > tfrz) then + tgb = tfrz + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp) + evb = cev * (estg*rhsur - eair ) !estg reevaluate ? + ghb = sag - (irb+shb+evb) + end if + end if + +! 2m air temperature + ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2b = ehb2 + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + endif + +! update ch + ch = 1./rahb + + end subroutine glacier_flux +! ================================================================================================== + subroutine esat(t, esw, esi, desw, desi) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + implicit none +!--------------------------------------------------------------------------------------------------- +! in + + real, intent(in) :: t !temperature + +!out + + real, intent(out) :: esw !saturation vapor pressure over water (pa) + real, intent(out) :: esi !saturation vapor pressure over ice (pa) + real, intent(out) :: desw !d(esat)/dt over water (pa/k) + real, intent(out) :: desi !d(esat)/dt over ice (pa/k) + +! local + + real :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water + real :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice + real :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water + real :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice + + parameter (a0=6.107799961 , a1=4.436518521e-01, & + a2=1.428945805e-02, a3=2.650648471e-04, & + a4=3.031240396e-06, a5=2.034080948e-08, & + a6=6.136820929e-11) + + parameter (b0=6.109177956 , b1=5.034698970e-01, & + b2=1.886013408e-02, b3=4.176223716e-04, & + b4=5.824720280e-06, b5=4.838803174e-08, & + b6=1.838826904e-10) + + parameter (c0= 4.438099984e-01, c1=2.857002636e-02, & + c2= 7.938054040e-04, c3=1.215215065e-05, & + c4= 1.036561403e-07, c5=3.532421810e-10, & + c6=-7.090244804e-13) + + parameter (d0=5.030305237e-01, d1=3.773255020e-02, & + d2=1.267995369e-03, d3=2.477563108e-05, & + d4=3.005693132e-07, d5=2.158542548e-09, & + d6=7.131097725e-12) + + esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6)))))) + esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) + desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6)))))) + desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6)))))) + + end subroutine esat +! ================================================================================================== + + subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in + qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & fv ,cm ,ch ,ch2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + integer, intent(in) :: iter !iteration index + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0h !roughness length, sensible heat, ground (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: qair !specific humidity at reference height (kg/kg) + real, intent(in) :: sfctmp !temperature at reference height (k) + real, intent(in) :: h !sensible heat flux (w/m2) [+ to atm] + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: mpe !prevents overflow error if division by zero + real, intent(in) :: ur !wind speed (m/s) + +! in & out + real, intent(inout) :: moz !monin-obukhov stability (z/l) + integer, intent(inout) :: mozsgn !number of times moz changes sign + real, intent(inout) :: fm !momentum stability correction, weighted by prior iters + real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters + +! outputs + real, intent(out) :: fv !friction velocity (m/s) + real, intent(out) :: cm !drag coefficient for momentum + real, intent(out) :: ch !drag coefficient for heat + real, intent(out) :: ch2 !drag coefficient for heat + +! locals + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: tmpcm !temporary calculation for cm + real :: tmpch !temporary calculation for ch + real :: mol !monin-obukhov length (m) + real :: tvir !temporary virtual temperature (k) + real :: tmp1,tmp2,tmp3 !temporary calculation + real :: fmnew !stability correction factor, momentum, for current moz + real :: fhnew !stability correction factor, sen heat, for current moz + real :: moz2 !2/l + real :: tmpcm2 !temporary calculation for cm2 + real :: tmpch2 !temporary calculation for ch2 + real :: fm2new !stability correction factor, momentum, for current moz + real :: fh2new !stability correction factor, sen heat, for current moz + real :: tmp12,tmp22,tmp32 !temporary calculation + + real :: cmfm, chfh, cm2fm2, ch2fh2 + + +! ------------------------------------------------------------------------------------------------- +! monin-obukhov stability parameter moz for next iteration + + mozold = moz + + if(zlvl <= zpd) then + write(*,*) 'critical glacier problem: zlvl <= zpd; model stops', zlvl, zpd + call wrf_error_fatal("stop in noah-mp glacier") + endif + + tmpcm = log((zlvl-zpd) / z0m) + tmpch = log((zlvl-zpd) / z0h) + tmpcm2 = log((2.0 + z0m) / z0m) + tmpch2 = log((2.0 + z0h) / z0h) + + if(iter == 1) then + fv = 0.0 + moz = 0.0 + mol = 0.0 + moz2 = 0.0 + else + tvir = (1. + 0.61*qair) * sfctmp + tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + mol = -1. * fv**3 / tmp1 + moz = min( (zlvl-zpd)/mol, 1.) + moz2 = min( (2.0 + z0h)/mol, 1.) + endif + +! accumulate number of times moz changes sign. + + if (mozold*moz .lt. 0.) mozsgn = mozsgn+1 + if (mozsgn .ge. 2) then + moz = 0. + fm = 0. + fh = 0. + moz2 = 0. + fm2 = 0. + fh2 = 0. + endif + +! evaluate stability-dependent variables using moz from prior iteration + if (moz .lt. 0.) then + tmp1 = (1. - 16.*moz)**0.25 + tmp2 = log((1.+tmp1*tmp1)/2.) + tmp3 = log((1.+tmp1)/2.) + fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963 + fhnew = 2*tmp2 + +! 2-meter + tmp12 = (1. - 16.*moz2)**0.25 + tmp22 = log((1.+tmp12*tmp12)/2.) + tmp32 = log((1.+tmp12)/2.) + fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963 + fh2new = 2*tmp22 + else + fmnew = -5.*moz + fhnew = fmnew + fm2new = -5.*moz2 + fh2new = fm2new + endif + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + if (iter == 1) then + fm = fmnew + fh = fhnew + fm2 = fm2new + fh2 = fh2new + else + fm = 0.5 * (fm+fmnew) + fh = 0.5 * (fh+fhnew) + fm2 = 0.5 * (fm2+fm2new) + fh2 = 0.5 * (fh2+fh2new) + endif + +! exchange coefficients + + fh = min(fh,0.9*tmpch) + fm = min(fm,0.9*tmpcm) + fh2 = min(fh2,0.9*tmpch2) + fm2 = min(fm2,0.9*tmpcm2) + + cmfm = tmpcm-fm + chfh = tmpch-fh + cm2fm2 = tmpcm2-fm2 + ch2fh2 = tmpch2-fh2 + if(abs(cmfm) <= mpe) cmfm = mpe + if(abs(chfh) <= mpe) chfh = mpe + if(abs(cm2fm2) <= mpe) cm2fm2 = mpe + if(abs(ch2fh2) <= mpe) ch2fh2 = mpe + cm = vkc*vkc/(cmfm*cmfm) + ch = vkc*vkc/(cmfm*chfh) + ch2 = vkc*vkc/(cm2fm2*ch2fh2) + +! friction velocity + + fv = ur * sqrt(cm) + ch2 = vkc*fv/ch2fh2 + + end subroutine sfcdif1_glacier +! ================================================================================================== + subroutine tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in + ssoil ,snowh ,zbot ,zsnso ,df , & !in + hcpct , & !in + stc ) !inout +! -------------------------------------------------------------------------------------------------- +! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures +! during melting season may exceed melting point (tfrz) but later in phasechange +! subroutine the snow temperatures are reset to tfrz for melting snow. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + + real, intent(in) :: dt !time step (s) + real, intent(in) :: tbot ! + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, intent(in) :: snowh !snow depth (m) + real, intent(in) :: zbot !from soil surface (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bot. depth from snow surf.(m) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +!input and output + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +!local + + integer :: iz + real :: zbotsno !zbot from snow surface + real, dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts + real :: eflxb !energy influx from soil bottom (w/m2) + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) + +! ---------------------------------------------------------------------- + +! prescribe solar penetration into ice/snow + + phi(isnow+1:nsoil) = 0. + +! adjust zbot from soil surface to zbotsno from snow surface + + zbotsno = zbot - snowh !from snow surface + +! compute ice temperatures + + call hrt_glacier (nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbotsno ,df , & + hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + eflxb ) + + call hstep_glacier (nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) + + end subroutine tsnosoi_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine hrt_glacier (nsnow ,nsoil ,isnow ,zsnso , & !in + stc ,tbot ,zbot ,df , & !in + hcpct ,ssoil ,phi , & !in + ai ,bi ,ci ,rhsts , & !out + botflx ) !out +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + real, intent(in) :: tbot !bottom soil temp. at zbot (k) + real, intent(in) :: zbot !depth of lower boundary condition (m) + !from soil surface not snow surface + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !depth of layer-bottom of snow/soil (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: phi !light through water (w/m2) + +! output + + real, dimension(-nsnow+1:nsoil), intent(out) :: rhsts !right-hand side of the matrix + real, dimension(-nsnow+1:nsoil), intent(out) :: ai !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: bi !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: ci !left-hand side coefficient + real, intent(out) :: botflx !energy influx from soil bottom (w/m2) + +! local + + integer :: k + real, dimension(-nsnow+1:nsoil) :: ddz + real, dimension(-nsnow+1:nsoil) :: denom + real, dimension(-nsnow+1:nsoil) :: dtsdz + real, dimension(-nsnow+1:nsoil) :: eflux + real :: temp1 +! ---------------------------------------------------------------------- + + do k = isnow+1, nsoil + if (k == isnow+1) then + denom(k) = - zsnso(k) * hcpct(k) + temp1 = - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k) + else if (k < nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k) + else if (k == nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k) + if(opt_tbot == 1) then + botflx = 0. + end if + if(opt_tbot == 2) then + dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot) + botflx = -df(k) * dtsdz(k) + end if + eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k) + end if + end do + + do k = isnow+1, nsoil + if (k == isnow+1) then + ai(k) = 0.0 + ci(k) = - df(k) * ddz(k) / denom(k) + if (opt_stc == 1) then + bi(k) = - ci(k) + end if + if (opt_stc == 2) then + bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k)) + end if + else if (k < nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = - df(k ) * ddz(k ) / denom(k) + bi(k) = - (ai(k) + ci (k)) + else if (k == nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - (ai(k) + ci(k)) + end if + rhsts(k) = eflux(k)/ (-denom(k)) + end do + + end subroutine hrt_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine hstep_glacier (nsnow ,nsoil ,isnow ,dt , & !in + ai ,bi ,ci ,rhsts , & !inout + stc ) !inout +! ---------------------------------------------------------------------- +! calculate/update the soil temperature field. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil + integer, intent(in) :: nsnow + integer, intent(in) :: isnow + real, intent(in) :: dt + +! output & input + real, dimension(-nsnow+1:nsoil), intent(inout) :: ai + real, dimension(-nsnow+1:nsoil), intent(inout) :: bi + real, dimension(-nsnow+1:nsoil), intent(inout) :: ci + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + real, dimension(-nsnow+1:nsoil), intent(inout) :: rhsts + +! local + integer :: k + real, dimension(-nsnow+1:nsoil) :: rhstsin + real, dimension(-nsnow+1:nsoil) :: ciin +! ---------------------------------------------------------------------- + + do k = isnow+1,nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + end do + +! copy values for input variables before call to rosr12 + + do k = isnow+1,nsoil + rhstsin(k) = rhsts(k) + ciin(k) = ci(k) + end do + +! solve the tri-diagonal matrix equation + + call rosr12_glacier (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow) + +! update snow & soil temperature + + do k = isnow+1,nsoil + stc (k) = stc (k) + ci (k) + end do + + end subroutine hstep_glacier +! ================================================================================================== + subroutine rosr12_glacier (p,a,b,c,d,delta,ntop,nsoil,nsnow) +! ---------------------------------------------------------------------- +! subroutine rosr12 +! ---------------------------------------------------------------------- +! invert (solve) the tri-diagonal matrix problem shown below: +! ### ### ### ### ### ### +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) # +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) # +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)# +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)# +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + implicit none + + integer, intent(in) :: ntop + integer, intent(in) :: nsoil,nsnow + integer :: k, kk + + real, dimension(-nsnow+1:nsoil),intent(in):: a, b, d + real, dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta + +! ---------------------------------------------------------------------- +! initialize eqn coef c for the lowest soil layer +! ---------------------------------------------------------------------- + c (nsoil) = 0.0 + p (ntop) = - c (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for the 1st soil layer +! ---------------------------------------------------------------------- + delta (ntop) = d (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + p (k) = - c (k) * ( 1.0 / (b (k) + a (k) * p (k -1)) ) + delta (k) = (d (k) - a (k)* delta (k -1))* (1.0/ (b (k) + a (k)& + * p (k -1))) + end do +! ---------------------------------------------------------------------- +! set p to delta for lowest soil layer +! ---------------------------------------------------------------------- + p (nsoil) = delta (nsoil) +! ---------------------------------------------------------------------- +! adjust p for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + kk = nsoil - k + (ntop-1) + 1 + p (kk) = p (kk) * p (kk +1) + delta (kk) + end do +! ---------------------------------------------------------------------- + end subroutine rosr12_glacier +! ---------------------------------------------------------------------- +! ================================================================================================== + subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! inputs + + integer, intent(in) :: nsnow !maximum no. of snow layers [=3] + integer, intent(in) :: nsoil !no. of soil layers [=4] + integer, intent(in) :: isnow !actual no. of snow layers [<=3] + real, intent(in) :: dt !land model time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: fact !temporary + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! inputs/outputs + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] + real, intent(inout) :: sneqv + real, intent(inout) :: snowh + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] + +! outputs + real, intent(out) :: qmelt !snowmelt rate [mm/s] + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index + real, intent(out) :: ponding!snowmelt when snow has no layer [mm] + +! local + + integer :: j,k !do loop index + real, dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2] + real, dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2] + real, dimension(-nsnow+1:nsoil) :: wmass0 + real, dimension(-nsnow+1:nsoil) :: wice0 + real, dimension(-nsnow+1:nsoil) :: wliq0 + real, dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm] + real, dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm] + real, dimension(-nsnow+1:nsoil) :: heatr !energy residual or loss after melting/freezing + real :: temp1 !temporary variables [kg/m2] + real :: propor + real :: xmf !total latent heat of phase change + +! ---------------------------------------------------------------------- +! initialization + + qmelt = 0. + ponding = 0. + xmf = 0. + + do j = isnow+1,0 ! all snow layers + mice(j) = snice(j) + mliq(j) = snliq(j) + end do + + do j = 1, nsoil ! all soil layers + mliq(j) = sh2o(j) * dzsnso(j) * 1000. + mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000. + end do + + do j = isnow+1,nsoil ! all layers + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = mice(j) + wliq0(j) = mliq(j) + wmass0(j) = mice(j) + mliq(j) + enddo + + do j = isnow+1,nsoil + if (mice(j) > 0. .and. stc(j) >= tfrz) then ! melting + imelt(j) = 1 + endif + if (mliq(j) > 0. .and. stc(j) < tfrz) then ! freezing + imelt(j) = 2 + endif + + ! if snow exists, but its thickness is not enough to create a layer + if (isnow == 0 .and. sneqv > 0. .and. j == 1) then + if (stc(j) >= tfrz) then + imelt(j) = 1 + endif + endif + enddo + +! calculate the energy surplus and loss for melting and freezing + + do j = isnow+1,nsoil + if (imelt(j) > 0) then + hm(j) = (stc(j)-tfrz)/fact(j) + stc(j) = tfrz + endif + + if (imelt(j) == 1 .and. hm(j) < 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + if (imelt(j) == 2 .and. hm(j) > 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + xm(j) = hm(j)*dt/hfus + enddo + +! the rate of melting and freezing for snow without a layer, needs more work. + + if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then + temp1 = sneqv + sneqv = max(0.,temp1-xm(1)) + propor = sneqv/temp1 + snowh = max(0.,propor * snowh) + heatr(1) = hm(1) - hfus*(temp1-sneqv)/dt + if (heatr(1) > 0.) then + xm(1) = heatr(1)*dt/hfus + hm(1) = heatr(1) + imelt(1) = 1 + else + xm(1) = 0. + hm(1) = 0. + imelt(1) = 0 + endif + qmelt = max(0.,(temp1-sneqv))/dt + xmf = hfus*qmelt + ponding = temp1-sneqv + endif + +! the rate of melting and freezing for snow and soil + + do j = isnow+1,nsoil + if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then + + heatr(j) = 0. + if (xm(j) > 0.) then + mice(j) = max(0., wice0(j)-xm(j)) + heatr(j) = hm(j) - hfus*(wice0(j)-mice(j))/dt + else if (xm(j) < 0.) then + mice(j) = min(wmass0(j), wice0(j)-xm(j)) + heatr(j) = hm(j) - hfus*(wice0(j)-mice(j))/dt + endif + + mliq(j) = max(0.,wmass0(j)-mice(j)) + + if (abs(heatr(j)) > 0.) then + stc(j) = stc(j) + fact(j)*heatr(j) + if (j <= 0) then ! snow + if (mliq(j)*mice(j)>0.) stc(j) = tfrz + end if + endif + + if (j > 0) xmf = xmf + hfus * (wice0(j)-mice(j))/dt + + if (j < 1) then + qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt + endif + endif + enddo + heatr = 0.0 + xm = 0.0 + +! deal with residuals in ice/soil + +! first remove excess heat by reducing temperature of layers + + if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then + do j = 1,nsoil + if ( stc(j) > tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + do k = 1,nsoil + if (j .ne. k .and. stc(k) < tfrz .and. heatr(j) > 0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (abs(heatr(k)) > heatr(j)) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 + else + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz + end if + end if + end do + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess cold by increasing temperature of layers (may not be necessary with above loop) + + if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then + do j = 1,nsoil + if ( stc(j) < tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + do k = 1,nsoil + if (j .ne. k .and. stc(k) > tfrz .and. heatr(j) < -0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (heatr(k) > abs(heatr(j))) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 + else + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz + end if + end if + end do + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess heat by melting ice + + if (any(stc(1:4) > tfrz) .and. any(mice(1:4) > 0.)) then + do j = 1,nsoil + if ( stc(j) > tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + xm(j) = heatr(j)*dt/hfus + do k = 1,nsoil + if (j .ne. k .and. mice(k) > 0. .and. xm(j) > 0.1) then + if (mice(k) > xm(j)) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 + else + xm(j) = xm(j) - mice(k) + xmf = xmf + hfus * mice(k)/dt + mice(k) = 0.0 + stc(k) = tfrz + end if + mliq(k) = max(0.,wmass0(k)-mice(k)) + end if + end do + heatr(j) = xm(j)*hfus/dt + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess cold by freezing liquid of layers (may not be necessary with above loop) + + if (any(stc(1:4) < tfrz) .and. any(mliq(1:4) > 0.)) then + do j = 1,nsoil + if ( stc(j) < tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + xm(j) = heatr(j)*dt/hfus + do k = 1,nsoil + if (j .ne. k .and. mliq(k) > 0. .and. xm(j) < -0.1) then + if (mliq(k) > abs(xm(j))) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 + else + xm(j) = xm(j) + mliq(k) + xmf = xmf - hfus * mliq(k)/dt + mice(k) = wmass0(k) + stc(k) = tfrz + end if + mliq(k) = max(0.,wmass0(k)-mice(k)) + end if + end do + heatr(j) = xm(j)*hfus/dt + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + + do j = isnow+1,0 ! snow + snliq(j) = mliq(j) + snice(j) = mice(j) + end do + + do j = 1, nsoil ! soil + sh2o(j) = mliq(j) / (1000. * dzsnso(j)) + sh2o(j) = max(0.0,min(1.0,sh2o(j))) +! smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j)) + smc(j) = 1.0 + end do + + end subroutine phasechange_glacier +! ================================================================================================== + subroutine water_glacier (nsnow ,nsoil ,imelt ,dt ,prcp ,sfctmp , & !in + qvap ,qdew ,ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout + dzsnso ,sh2o ,sice ,ponding,zsnso , & !inout + runsrf ,runsub ,qsnow ,ponding1 ,ponding2,qsnbot,fpice,esnow & !out + ) !out +! ---------------------------------------------------------------------- +! code history: +! initial code: guo-yue niu, oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [1-melt; 2-freeze] + real, intent(in) :: dt !main time step (s) + real, intent(in) :: prcp !precipitation (mm/s) + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: qvap !soil surface evaporation rate[mm/s] + real, intent(in) :: qdew !soil surface dew rate[mm/s] + real, dimension(-nsnow+1: 0), intent(in) :: ficeold !ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + +! input/output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice content [m3/m3] + real , intent(inout) :: ponding ![mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + +! output + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !baseflow (sturation excess) [mm/s] + real, intent(out) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: fpice !precipitation frozen fraction + real, intent(out) :: esnow ! + +! local + real :: qrain !rain at ground srf (mm) [+] + real :: qseva !soil surface evap rate [mm/s] + real :: qsdew !soil surface dew rate [mm/s] + real :: qsnfro !snow surface frost rate[mm/s] + real :: qsnsub !snow surface sublimation rate [mm/s] + real :: snowhin !snow depth increasing rate (m/s) + real :: snoflow !glacier flow [mm/s] + real :: bdfall !density of new snow (mm water/m snow) + real :: replace !replacement water due to sublimation of glacier + real, dimension( 1:nsoil) :: sice_save !soil ice content [m3/m3] + real, dimension( 1:nsoil) :: sh2o_save !soil liquid water content [m3/m3] + integer :: ilev + + +! ---------------------------------------------------------------------- +! initialize + + snoflow = 0. + runsub = 0. + runsrf = 0. + sice_save = sice + sh2o_save = sh2o + +! -------------------------------------------------------------------- +! partition precipitation into rain and snow (from canwater) + +! jordan (1991) + + if(opt_snf == 1 .or. opt_snf == 4) then + if(sfctmp > tfrz+2.5)then + fpice = 0. + else + if(sfctmp <= tfrz+0.5)then + fpice = 1.0 + else if(sfctmp <= tfrz+2.)then + fpice = 1.-(-54.632 + 0.2*sfctmp) + else + fpice = 0.6 + endif + endif + endif + + if(opt_snf == 2) then + if(sfctmp >= tfrz+2.2) then + fpice = 0. + else + fpice = 1.0 + endif + endif + + if(opt_snf == 3) then + if(sfctmp >= tfrz) then + fpice = 0. + else + fpice = 1.0 + endif + endif +! print*, 'fpice: ',fpice + +! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625 +! fresh snow density + + bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb: change to min v3.7 + + qrain = prcp * (1.-fpice) + qsnow = prcp * fpice + snowhin = qsnow/bdfall +! print *, 'qrain, qsnow',qrain,qsnow,qrain*dt,qsnow*dt + +! sublimation, frost, evaporation, and dew + +! qsnsub = 0. +! if (sneqv > 0.) then +! qsnsub = min(qvap, sneqv/dt) +! endif +! qseva = qvap-qsnsub + +! qsnfro = 0. +! if (sneqv > 0.) then +! qsnfro = qdew +! endif +! qsdew = qdew - qsnfro + + qsnsub = qvap ! send total sublimation/frost to snowwater and deal with it there + qsnfro = qdew + esnow = qsnsub*2.83e+6 + + +! print *, 'qvap',qvap,qvap*dt +! print *, 'qsnsub',qsnsub,qsnsub*dt +! print *, 'qseva',qseva,qseva*dt +! print *, 'qsnfro',qsnfro,qsnfro*dt +! print *, 'qdew',qdew,qdew*dt +! print *, 'qsdew',qsdew,qsdew*dt +!print *, 'before snowwater', sneqv,snowh,snice,snliq,sh2o,sice + call snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in + snowhin,qsnow ,qsnfro ,qsnsub ,qrain , & !in + ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,dzsnso ,zsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +!print *, 'after snowwater', sneqv,snowh,snice,snliq,sh2o,sice +!print *, 'ponding', ponding,ponding1,ponding2 + + !ponding: melting water from snow when there is no layer + + runsrf = (ponding+ponding1+ponding2)/dt + + if(isnow == 0) then + runsrf = runsrf + qsnbot + qrain + else + runsrf = runsrf + qsnbot + endif + + + replace = 0.0 + do ilev = 1,nsoil + replace = replace + dzsnso(ilev)*(sice(ilev) - sice_save(ilev) + sh2o(ilev) - sh2o_save(ilev)) + end do + replace = replace * 1000.0 / dt ! convert to [mm/s] + + sice = min(1.0,sice_save) + sh2o = 1.0 - sice +!print *, 'replace', replace + + ! use runsub as a water balancer, snoflow is snow that disappears, replace is + ! water from below that replaces glacier loss + + runsub = snoflow + replace + + end subroutine water_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in + snowhin,qsnow ,qsnfro ,qsnsub ,qrain , & !in + ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,dzsnso ,zsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (s) + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + real, dimension(-nsnow+1:0) , intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + +! input & output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + +! output + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: snoflow!glacier flow [mm] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local + integer :: iz + real :: bdsnow !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + snoflow = 0.0 + ponding1 = 0.0 + ponding2 = 0.0 + + call snowfall_glacier (nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in + sfctmp , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout + + if(isnow < 0) then !when more than one layer + call compact_glacier (nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,imelt ,ficeold, & !in + isnow ,dzsnso ) !inout + + call combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out + + call divide_glacier (nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout + end if + +!set empty snow layers to zero + + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo + + call snowh2o_glacier (nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + ponding1 ,ponding2 , & !inout + qsnbot ) !out + +!to obtain equilibrium state of snow in glacier region + + if(sneqv > 2000.) then ! 2000 mm -> maximum water depth + bdsnow = snice(0) / dzsnso(0) + snoflow = (sneqv - 2000.) + snice(0) = snice(0) - snoflow + dzsnso(0) = dzsnso(0) - snoflow/bdsnow + snoflow = snoflow / dt + end if + +! sum up snow mass for layered snow + + if(isnow /= 0) then + sneqv = 0. + do iz = isnow+1,0 + sneqv = sneqv + snice(iz) + snliq(iz) + enddo + end if + +! reset zsnso and layer thinkness dzsnso + + do iz = isnow+1, 0 + dzsnso(iz) = -dzsnso(iz) + end do + + dzsnso(1) = zsoil(1) + do iz = 2,nsoil + dzsnso(iz) = (zsoil(iz) - zsoil(iz-1)) + end do + + zsnso(isnow+1) = dzsnso(isnow+1) + do iz = isnow+2 ,nsoil + zsnso(iz) = zsnso(iz-1) + dzsnso(iz) + enddo + + do iz = isnow+1 ,nsoil + dzsnso(iz) = -dzsnso(iz) + end do + + end subroutine snowwater_glacier +! ================================================================================================== + subroutine snowfall_glacier (nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in + sfctmp , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !main time step (s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: sfctmp !surface air temperature [k] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: sneqv !swow water equivalent [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !thickness of snow/soil layers (m) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: newnode ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + newnode = 0 + +! shallow snow / no layer + + if(isnow == 0 .and. qsnow > 0.) then + snowh = snowh + snowhin * dt + sneqv = sneqv + qsnow * dt + end if + +! creating a new layer + + if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then + isnow = -1 + newnode = 1 + dzsnso(0)= snowh + snowh = 0. + stc(0) = min(273.16, sfctmp) ! temporary setup + snice(0) = sneqv + snliq(0) = 0. + end if + +! snow with layers + + if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then + snice(isnow+1) = snice(isnow+1) + qsnow * dt + dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt + endif + +! ---------------------------------------------------------------------- + end subroutine snowfall_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine compact_glacier (nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,imelt ,ficeold, & !in + isnow ,dzsnso ) !inout +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsoil !no. of soil layers [ =4] + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + +! input and output + integer, intent(inout) :: isnow ! actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer thickness [m] + +! local + real, parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3 + real, parameter :: c3 = 2.5e-6 ![1/s] + real, parameter :: c4 = 0.04 ![1/k] + real, parameter :: c5 = 2.0 ! + real, parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] + real, parameter :: eta0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to anderson, it is between 0.52e6~1.38e6 + real :: burden !pressure of overlying snow [kg/m2] + real :: ddz1 !rate of settling of snow pack due to destructive metamorphism. + real :: ddz2 !rate of compaction of snow pack due to overburden. + real :: ddz3 !rate of compaction of snow pack due to melt [1/s] + real :: dexpf !expf=exp(-c4*(273.15-stc)). + real :: td !stc - tfrz [k] + real :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s] + real :: void !void (1 - snice - snliq) + real :: wx !water mass (ice + liquid) [kg/m2] + real :: bi !partial density of ice [kg/m3] + real, dimension(-nsnow+1:0) :: fice !fraction of ice at current time step + + integer :: j + +! ---------------------------------------------------------------------- + burden = 0.0 + + do j = isnow+1, 0 + + wx = snice(j) + snliq(j) + fice(j) = snice(j) / wx + void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j) + + ! allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. snice(j) > 0.1) then + bi = snice(j) / dzsnso(j) + td = max(0.,tfrz-stc(j)) + dexpf = exp(-c4*td) + + ! settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! liquid water term + + if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5 + + ! compaction due to overburden + + ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden + + ! compaction occurring during melt + + if (imelt(j) == 1) then + ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j))) + ddz3 = - ddz3/dt ! sometimes too large + else + ddz3 = 0. + end if + + ! time rate of fractional change in dz (units of s-1) + + pdzdtc = (ddz1 + ddz2 + ddz3)*dt + pdzdtc = max(-0.5,pdzdtc) + + ! the change in dz due to compaction + + dzsnso(j) = dzsnso(j)*(1.+pdzdtc) + end if + + ! pressure of overlying snow + + burden = burden + wx + + end do + + end subroutine compact_glacier +! ================================================================================================== + subroutine combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + real, intent(inout) :: sneqv !snow water equivalent [m] + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: ponding1 + real, intent(inout) :: ponding2 + +! local variables: + + integer :: i,j,k,l ! node indices + integer :: isnow_old ! number of top snow layer + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + real :: zwice ! total ice mass in snow + real :: zwliq ! total liquid water in snow + real :: dzmin(3) ! minimum of top snow layer + data dzmin /0.045, 0.05, 0.2/ +! data dzmin /0.025, 0.025, 0.1/ ! mb: change limit +!----------------------------------------------------------------------- + + isnow_old = isnow + + do j = isnow_old+1,0 + if (snice(j) <= .1) then + if(j /= 0) then + snliq(j+1) = snliq(j+1) + snliq(j) + snice(j+1) = snice(j+1) + snice(j) + else + if (isnow_old < -1) then + snliq(j-1) = snliq(j-1) + snliq(j) + snice(j-1) = snice(j-1) + snice(j) + else + ponding1 = ponding1 + snliq(j) ! isnow will get set to zero below + sneqv = snice(j) ! ponding will get added to ponding from + snowh = dzsnso(j) ! phasechange which should be zero here + snliq(j) = 0.0 ! because there it was only calculated + snice(j) = 0.0 ! for thin snow + dzsnso(j) = 0.0 + endif +! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.) +! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.) + endif + + ! shift all elements above this down by one. + if (j > isnow+1 .and. isnow < -1) then + do i = j, isnow+2, -1 + stc(i) = stc(i-1) + snliq(i) = snliq(i-1) + snice(i) = snice(i-1) + dzsnso(i)= dzsnso(i-1) + end do + end if + isnow = isnow + 1 + end if + end do + +! to conserve water in case of too large surface sublimation + + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + + if(isnow ==0) return ! mb: get out if no longer multi-layer + + sneqv = 0. + snowh = 0. + zwice = 0. + zwliq = 0. + + do j = isnow+1,0 + sneqv = sneqv + snice(j) + snliq(j) + snowh = snowh + dzsnso(j) + zwice = zwice + snice(j) + zwliq = zwliq + snliq(j) + end do + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + +! if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit + if (snowh < 0.05 .and. isnow < 0 ) then + isnow = 0 + sneqv = zwice + ponding2 = ponding2 + zwliq ! limit of isnow < 0 means input ponding + if(sneqv <= 0.) snowh = 0. ! should be zero; see above + end if + +! if (snowh < 0.05 ) then +! isnow = 0 +! sneqv = zwice +! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.) +! if(sneqv <= 0.) snowh = 0. +! end if + +! check the snow depth - snow layers combined + + if (isnow < -1) then + + isnow_old = isnow + mssi = 1 + + do i = isnow_old+1,0 + if (dzsnso(i) < dzmin(mssi)) then + + if (i == isnow+1) then + neibor = i + 1 + else if (i == 0) then + neibor = i - 1 + else + neibor = i + 1 + if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1 + end if + + ! node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call combo_glacier (dzsnso(j), snliq(j), snice(j), & + stc(j), dzsnso(l), snliq(l), snice(l), stc(l) ) + + ! now shift all elements above this down one. + if (j-1 > isnow+1) then + do k = j-1, isnow+2, -1 + stc(k) = stc(k-1) + snice(k) = snice(k-1) + snliq(k) = snliq(k-1) + dzsnso(k) = dzsnso(k-1) + end do + end if + + ! decrease the number of snow layers + isnow = isnow + 1 + if (isnow >= -1) exit + else + + ! the layer thickness is greater than the prescribed minimum value + mssi = mssi + 1 + + end if + end do + + end if + + end subroutine combine_glacier +! ================================================================================================== + +! ---------------------------------------------------------------------- + subroutine combo_glacier(dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + real, intent(in) :: dz2 !nodal thickness of 2 elements being combined [m] + real, intent(in) :: wliq2 !liquid water of element 2 [kg/m2] + real, intent(in) :: wice2 !ice of element 2 [kg/m2] + real, intent(in) :: t2 !nodal temperature of element 2 [k] + real, intent(inout) :: dz !nodal thickness of 1 elements being combined [m] + real, intent(inout) :: wliq !liquid water of element 1 + real, intent(inout) :: wice !ice of element 1 [kg/m2] + real, intent(inout) :: t !node temperature of element 1 [k] + +! local + + real :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2). + real :: wliqc !combined liquid water [kg/m2] + real :: wicec !combined ice [kg/m2] + real :: tc !combined node temperature [k] + real :: h !enthalpy of element 1 [j/m2] + real :: h2 !enthalpy of element 2 [j/m2] + real :: hc !temporary + +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq + h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cice*wicec + cwat*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine combo_glacier +! ================================================================================================== + subroutine divide_glacier (nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, intent(in) :: nsoil !no. of soil layers [ =4] + +! input and output + + integer , intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + +! local variables: + + integer :: j !indices + integer :: msno !number of layer (top) to msno (bot) + real :: drr !thickness of the combined [m] + real, dimension( 1:nsnow) :: dz !snow layer thickness [m] + real, dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3] + real, dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3] + real, dimension( 1:nsnow) :: tsno !node temperature [k] + real :: zwice !temporary + real :: zwliq !temporary + real :: propor!temporary + real :: dtdz !temporary +! ---------------------------------------------------------------------- + + do j = 1,nsnow + if (j <= abs(isnow)) then + dz(j) = dzsnso(j+isnow) + swice(j) = snice(j+isnow) + swliq(j) = snliq(j+isnow) + tsno(j) = stc(j+isnow) + end if + end do + + msno = abs(isnow) + + if (msno == 1) then + ! specify a new snow layer + if (dz(1) > 0.05) then + msno = 2 + dz(1) = dz(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + dz(2) = dz(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) + end if + end if + + if (msno > 1) then + if (dz(1) > 0.05) then + drr = dz(1) - 0.05 + propor = drr/dz(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + propor = 0.05/dz(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dz(1) = 0.05 + + call combo_glacier (dz(2), swliq(2), swice(2), tsno(2), drr, & + zwliq, zwice, tsno(1)) + + ! subdivide a new layer +! if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit + if (msno <= 2 .and. dz(2) > 0.10) then + msno = 3 + dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.) + dz(2) = dz(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + dz(3) = dz(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) - dtdz*dz(2)/2. + if (tsno(3) >= tfrz) then + tsno(3) = tsno(2) + else + tsno(2) = tsno(2) + dtdz*dz(2)/2. + endif + + end if + end if + end if + + if (msno > 2) then + if (dz(2) > 0.2) then + drr = dz(2) - 0.2 + propor = drr/dz(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + propor = 0.2/dz(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dz(2) = 0.2 + call combo_glacier (dz(3), swliq(3), swice(3), tsno(3), drr, & + zwliq, zwice, tsno(2)) + end if + end if + + isnow = -msno + + do j = isnow+1,0 + dzsnso(j) = dz(j-isnow) + snice(j) = swice(j-isnow) + snliq(j) = swliq(j-isnow) + stc(j) = tsno(j-isnow) + end do + + +! do j = isnow+1,nsoil +! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j) +! end do + + end subroutine divide_glacier +! ================================================================================================== + subroutine snowh2o_glacier (nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + ponding1 ,ponding2 , & !inout + qsnbot ) !out +! ---------------------------------------------------------------------- +! renew the mass of ice lens (snice) and liquid (snliq) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers[=3] + integer, intent(in) :: nsoil !no. of soil layers[=4] + real, intent(in) :: dt !time step + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + +! output + + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer depth [m] + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, intent(inout) :: ponding1 + real, intent(inout) :: ponding2 + +! local variables: + + integer :: j !do loop/array indices + real :: qin !water flow into the element (mm/s) + real :: qout !water flow out of the element (mm/s) + real :: wgdif !ice mass after minus sublimation + real, dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer + real, dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer + real, dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice + real :: propor, temp +! ---------------------------------------------------------------------- + +!for the case when sneqv becomes '0' after 'combine' + + if(sneqv == 0.) then + sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) + end if + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. to conserve water, +! excessive sublimation is used to reduce soil water. smaller time steps would tend +! to aviod this problem. + + if(isnow == 0 .and. sneqv > 0.) then + temp = sneqv + sneqv = sneqv - qsnsub*dt + qsnfro*dt + propor = sneqv/temp + snowh = max(0.,propor * snowh) + + if(sneqv < 0.) then + sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.) + sneqv = 0. + snowh = 0. + end if + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + + if(snowh <= 1.e-8 .or. sneqv <= 1.e-6) then + snowh = 0.0 + sneqv = 0.0 + end if + +! for deep snow + + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + + wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt + snice(isnow+1) = wgdif + if (wgdif < 1.e-6 .and. isnow <0) then + call combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1, ponding2 ) !inout + endif + !kwm: subroutine combine can change isnow to make it 0 again? + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + snliq(isnow+1) = snliq(isnow+1) + qrain * dt + snliq(isnow+1) = max(0., snliq(isnow+1)) + endif + + endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)? + +! porosity and partial volume + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice)) + epore(j) = 1. - vol_ice(j) + vol_liq(j) = min(epore(j),snliq(j)/(dzsnso(j)*denh2o)) + end if + end do + + qin = 0. + qout = 0. + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + snliq(j) = snliq(j) + qin + if (j <= -1) then + if (epore(j) < 0.05 .or. epore(j+1) < 0.05) then + qout = 0. + else + qout = max(0.,(vol_liq(j)-ssi*epore(j))*dzsnso(j)) + qout = min(qout,(1.-vol_ice(j+1)-vol_liq(j+1))*dzsnso(j+1)) + end if + else + qout = max(0.,(vol_liq(j) - ssi*epore(j))*dzsnso(j)) + end if + qout = qout*1000. + snliq(j) = snliq(j) - qout + qin = qout + end if + end do + +! liquid water from snow bottom to soil + + qsnbot = qout / dt ! mm/s + + end subroutine snowh2o_glacier +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & + fsh ,fgev ,ssoil ,sag ,prcp ,edir , & + runsrf ,runsub ,sneqv ,dt ,beg_wb ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(in) :: fsa !total absorbed solar radiation (w/m2) + real , intent(in) :: fsr !total reflected solar radiation (w/m2) + real , intent(in) :: fira !total net longwave rad (w/m2) [+ to atm] + real , intent(in) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(in) :: fgev !ground evaporation heat (w/m2) [+ to atm] + real , intent(in) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(in) :: sag + + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: edir !soil surface evaporation rate[mm/s] + real , intent(in) :: runsrf !surface runoff [mm/s] + real , intent(in) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(in) :: sneqv !snow water eqv. [mm] + real , intent(in) :: dt !time step [sec] + real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] + + real :: end_wb !water storage at end of a timestep [mm] + real :: errwat !error in water balance [mm/timestep] + real :: erreng !error in surface energy balance [w/m2] + real :: errsw !error in shortwave radiation balance [w/m2] + character(len=256) :: message +! -------------------------------------------------------------------------------------------------- + errsw = swdown - (fsa + fsr) + if (errsw > 0.01) then ! w/m2 + write(*,*) "sag =",sag + write(*,*) "fsa =",fsa + write(*,*) "fsr =",fsr + write(message,*) 'errsw =',errsw + call wrf_message(trim(message)) + call wrf_error_fatal("radiation budget problem in noahmp glacier") + end if + + erreng = sag-(fira+fsh+fgev+ssoil) + if(erreng > 0.01) then + write(message,*) 'erreng =',erreng + call wrf_message(trim(message)) + write(message,'(i6,1x,i6,1x,5f10.4)')iloc,jloc,sag,fira,fsh,fgev,ssoil + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp glacier") + end if + + end_wb = sneqv + errwat = end_wb-beg_wb-(prcp-edir-runsrf-runsub)*dt + + + end subroutine error_glacier +! ================================================================================================== + + subroutine noahmp_options_glacier(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + implicit none + + integer, intent(in) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + integer, intent(in) :: iopt_crs !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer, intent(in) :: iopt_btr !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer, intent(in) :: iopt_run !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer, intent(in) :: iopt_sfc !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer, intent(in) :: iopt_frz !supercooled liquid water (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_inf !frozen soil permeability (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_rad !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer, intent(in) :: iopt_alb !snow surface albedo (1->bats; 2->class) + integer, intent(in) :: iopt_snf !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer, intent(in) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->noah) + + integer, intent(in) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original noah) + +! ------------------------------------------------------------------------------------------------- + + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + + end subroutine noahmp_options_glacier + +end module noahmp_glacier_routines +! ================================================================================================== + +module module_sf_noahmp_glacier + + use noahmp_glacier_routines + use noahmp_glacier_globals + +end module module_sf_noahmp_glacier + diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 new file mode 100755 index 000000000..139c53277 --- /dev/null +++ b/physics/module_sf_noahmplsm.f90 @@ -0,0 +1,8197 @@ +module module_sf_noahmplsm + use module_wrf_utl + + implicit none + + public :: noahmp_options + public :: noahmp_sflx + + private :: atm + private :: phenology + private :: precip_heat + private :: energy + private :: thermoprop + private :: csnow + private :: tdfcnd + private :: radiation + private :: albedo + private :: snow_age + private :: snowalb_bats + private :: snowalb_class + private :: groundalb + private :: twostream + private :: surrad + private :: vege_flux + private :: sfcdif1 + private :: sfcdif2 + private :: stomata + private :: canres + private :: esat + private :: ragrb + private :: bare_flux + private :: tsnosoi + private :: hrt + private :: hstep + private :: rosr12 + private :: phasechange + private :: frh2o + + private :: water + private :: canwater + private :: snowwater + private :: snowfall + private :: combine + private :: divide + private :: combo + private :: compact + private :: snowh2o + private :: soilwater + private :: zwteq + private :: infil + private :: srt + private :: wdfcnd1 + private :: wdfcnd2 + private :: sstep + private :: groundwater + private :: shallowwatertable + + private :: carbon + private :: co2flux +! private :: bvocflux +! private :: ch4flux + + private :: error + +! =====================================options for different schemes================================ +! **recommended + + integer :: dveg ! options for dynamic vegetation: + ! 1 -> off (use table lai; use fveg = shdfac from input) + ! 2 -> on (together with opt_crs = 1) + ! 3 -> off (use table lai; calculate fveg) + ! **4 -> off (use table lai; use maximum vegetation fraction) + ! **5 -> on (use maximum vegetation fraction) + + integer :: opt_crs ! options for canopy stomatal resistance + ! **1 -> ball-berry + ! 2 -> jarvis + + integer :: opt_btr ! options for soil moisture factor for stomatal resistance + ! **1 -> noah (soil moisture) + ! 2 -> clm (matric potential) + ! 3 -> ssib (matric potential) + + integer :: opt_run ! options for runoff and groundwater + ! **1 -> topmodel with groundwater (niu et al. 2007 jgr) ; + ! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ; + ! 3 -> original surface and subsurface runoff (free drainage) + ! 4 -> bats surface and subsurface runoff (free drainage) + ! 5 -> miguez-macho&fan groundwater scheme (miguez-macho et al. 2007 jgr; fan et al. 2007 jgr) + ! (needs further testing for public use) + + integer :: opt_sfc ! options for surface layer drag coeff (ch & cm) + ! **1 -> m-o + ! **2 -> original noah (chen97) + ! **3 -> myj consistent; 4->ysu consistent. mb: removed in v3.7 for further testing + + integer :: opt_frz ! options for supercooled liquid water (or ice fraction) + ! **1 -> no iteration (niu and yang, 2006 jhm) + ! 2 -> koren's iteration + + integer :: opt_inf ! options for frozen soil permeability + ! **1 -> linear effects, more permeable (niu and yang, 2006, jhm) + ! 2 -> nonlinear effects, less permeable (old) + + integer :: opt_rad ! options for radiation transfer + ! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg) + ! 2 -> two-stream applied to grid-cell (gap = 0) + ! **3 -> two-stream applied to vegetated fraction (gap=1-fveg) + + integer :: opt_alb ! options for ground snow surface albedo + ! 1 -> bats + ! **2 -> class + + integer :: opt_snf ! options for partitioning precipitation into rainfall & snowfall + ! **1 -> jordan (1991) + ! 2 -> bats: when sfctmp sfctmp < tfrz + ! 4 -> use wrf microphysics output + + integer :: opt_tbot ! options for lower boundary condition of soil temperature + ! 1 -> zero heat flux from bottom (zbot and tbot not used) + ! **2 -> tbot at zbot (8m) read from a file (original noah) + + integer :: opt_stc ! options for snow/soil temperature time scheme (only layer 1) + ! **1 -> semi-implicit; flux top boundary condition + ! 2 -> full implicit (original noah); temperature top boundary condition + ! 3 -> same as 1, but fsno for ts calculation (generally improves snow; v3.7) + +!------------------------------------------------------------------------------------------! +! physical constants: ! +!------------------------------------------------------------------------------------------! + + real, parameter :: grav = 9.80616 !acceleration due to gravity (m/s2) + real, parameter :: sb = 5.67e-08 !stefan-boltzmann constant (w/m2/k4) + real, parameter :: vkc = 0.40 !von karman constant + real, parameter :: tfrz = 273.16 !freezing/melting point (k) + real, parameter :: hsub = 2.8440e06 !latent heat of sublimation (j/kg) + real, parameter :: hvap = 2.5104e06 !latent heat of vaporization (j/kg) + real, parameter :: hfus = 0.3336e06 !latent heat of fusion (j/kg) + real, parameter :: cwat = 4.188e06 !specific heat capacity of water (j/m3/k) + real, parameter :: cice = 2.094e06 !specific heat capacity of ice (j/m3/k) + real, parameter :: cpair = 1004.64 !heat capacity dry air at const pres (j/kg/k) + real, parameter :: tkwat = 0.6 !thermal conductivity of water (w/m/k) + real, parameter :: tkice = 2.2 !thermal conductivity of ice (w/m/k) + real, parameter :: tkair = 0.023 !thermal conductivity of air (w/m/k) (not used mb: 20140718) + real, parameter :: rair = 287.04 !gas constant for dry air (j/kg/k) + real, parameter :: rw = 461.269 !gas constant for water vapor (j/kg/k) + real, parameter :: denh2o = 1000. !density of water (kg/m3) + real, parameter :: denice = 917. !density of ice (kg/m3) + + integer, private, parameter :: mband = 2 + + type noahmp_parameters ! define a noahmp parameters type + +!------------------------------------------------------------------------------------------! +! from the veg section of mptable.tbl +!------------------------------------------------------------------------------------------! + + logical :: urban_flag + integer :: iswater + integer :: isbarren + integer :: isice + integer :: eblforest + + real :: ch2op !maximum intercepted h2o per unit lai+sai (mm) + real :: dleaf !characteristic leaf dimension (m) + real :: z0mvt !momentum roughness length (m) + real :: hvt !top of canopy (m) + real :: hvb !bottom of canopy (m) + real :: den !tree density (no. of trunks per m2) + real :: rc !tree crown radius (m) + real :: mfsno !snowmelt m parameter () + real :: saim(12) !monthly stem area index, one-sided + real :: laim(12) !monthly leaf area index, one-sided + real :: sla !single-side leaf area per kg [m2/kg] + real :: dilefc !coeficient for leaf stress death [1/s] + real :: dilefw !coeficient for leaf stress death [1/s] + real :: fragr !fraction of growth respiration !original was 0.3 + real :: ltovrc !leaf turnover [1/s] + + real :: c3psn !photosynthetic pathway: 0. = c4, 1. = c3 + real :: kc25 !co2 michaelis-menten constant at 25c (pa) + real :: akc !q10 for kc25 + real :: ko25 !o2 michaelis-menten constant at 25c (pa) + real :: ako !q10 for ko25 + real :: vcmx25 !maximum rate of carboxylation at 25c (umol co2/m**2/s) + real :: avcmx !q10 for vcmx25 + real :: bp !minimum leaf conductance (umol/m**2/s) + real :: mp !slope of conductance-to-photosynthesis relationship + real :: qe25 !quantum efficiency at 25c (umol co2 / umol photon) + real :: aqe !q10 for qe25 + real :: rmf25 !leaf maintenance respiration at 25c (umol co2/m**2/s) + real :: rms25 !stem maintenance respiration at 25c (umol co2/kg bio/s) + real :: rmr25 !root maintenance respiration at 25c (umol co2/kg bio/s) + real :: arm !q10 for maintenance respiration + real :: folnmx !foliage nitrogen concentration when f(n)=1 (%) + real :: tmin !minimum temperature for photosynthesis (k) + + real :: xl !leaf/stem orientation index + real :: rhol(mband) !leaf reflectance: 1=vis, 2=nir + real :: rhos(mband) !stem reflectance: 1=vis, 2=nir + real :: taul(mband) !leaf transmittance: 1=vis, 2=nir + real :: taus(mband) !stem transmittance: 1=vis, 2=nir + + real :: mrp !microbial respiration parameter (umol co2 /kg c/ s) + real :: cwpvt !empirical canopy wind parameter + + real :: wrrat !wood to non-wood ratio + real :: wdpool !wood pool (switch 1 or 0) depending on woody or not [-] + real :: tdlef !characteristic t for leaf freezing [k] + + integer :: nroot !number of soil layers with root present + real :: rgl !parameter used in radiation stress function + real :: rsmin !minimum stomatal resistance [s m-1] + real :: hs !parameter used in vapor pressure deficit function + real :: topt !optimum transpiration air temperature [k] + real :: rsmax !maximal stomatal resistance [s m-1] + + real :: slarea + real :: eps(5) + +!------------------------------------------------------------------------------------------! +! from the rad section of mptable.tbl +!------------------------------------------------------------------------------------------! + + real :: albsat(mband) !saturated soil albedos: 1=vis, 2=nir + real :: albdry(mband) !dry soil albedos: 1=vis, 2=nir + real :: albice(mband) !albedo land ice: 1=vis, 2=nir + real :: alblak(mband) !albedo frozen lakes: 1=vis, 2=nir + real :: omegas(mband) !two-stream parameter omega for snow + real :: betads !two-stream parameter betad for snow + real :: betais !two-stream parameter betad for snow + real :: eg(2) !emissivity + +!------------------------------------------------------------------------------------------! +! from the globals section of mptable.tbl +!------------------------------------------------------------------------------------------! + + real :: co2 !co2 partial pressure + real :: o2 !o2 partial pressure + real :: timean !gridcell mean topgraphic index (global mean) + real :: fsatmx !maximum surface saturated fraction (global mean) + real :: z0sno !snow surface roughness length (m) (0.002) + real :: ssi !liquid water holding capacity for snowpack (m3/m3) + real :: swemx !new snow mass to fully cover old snow (mm) + +!------------------------------------------------------------------------------------------! +! from the soilparm.tbl tables, as functions of soil category. +!------------------------------------------------------------------------------------------! + real :: bexp !b parameter + real :: smcdry !dry soil moisture threshold where direct evap from top + !layer ends (volumetric) (not used mb: 20140718) + real :: smcwlt !wilting point soil moisture (volumetric) + real :: smcref !reference soil moisture (field capacity) (volumetric) + real :: smcmax !porosity, saturated value of soil moisture (volumetric) + real :: f1 !soil thermal diffusivity/conductivity coef (not used mb: 20140718) + real :: psisat !saturated soil matric potential + real :: dksat !saturated soil hydraulic conductivity + real :: dwsat !saturated soil hydraulic diffusivity + real :: quartz !soil quartz content +!------------------------------------------------------------------------------------------! +! from the genparm.tbl file +!------------------------------------------------------------------------------------------! + real :: slope !slope index (0 - 1) + real :: csoil !vol. soil heat capacity [j/m3/k] + real :: zbot !depth (m) of lower boundary soil temperature + real :: czil !calculate roughness length of heat + + real :: kdt !used in compute maximum infiltration rate (in infil) + real :: frzx !used in compute maximum infiltration rate (in infil) + + end type noahmp_parameters + +contains +! +!== begin noahmp_sflx ============================================================================== + + subroutine noahmp_sflx (parameters, & + iloc , jloc , lat , yearlen , julian , cosz , & ! in : time/space-related + dt , dx , dz8w , nsoil , zsoil , nsnow , & ! in : model configuration + shdfac , shdmax , vegtyp , ice , ist , & ! in : vegetation/soil characteristics + smceq , & ! in : vegetation/soil characteristics + sfctmp , sfcprs , psfc , uu , vv , q2 , & ! in : forcing + qc , soldn , lwdn , & ! in : forcing + prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing + tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing + albold , sneqvo , & ! in/out : + stc , sh2o , smc , tah , eah , fwet , & ! in/out : + canliq , canice , tv , tg , qsfc , qsnow , & ! in/out : + isnow , zsnso , snowh , sneqv , snice , snliq , & ! in/out : + zwt , wa , wt , wslake , lfmass , rtmass , & ! in/out : + stmass , wood , stblcp , fastcp , lai , sai , & ! in/out : + cm , ch , tauss , & ! in/out : + smcwtd ,deeprech , rech , & ! in/out : + z0wrf , & + fsa , fsr , fira , fsh , ssoil , fcev , & ! out : + fgev , fctr , ecan , etran , edir , trad , & ! out : + tgb , tgv , t2mv , t2mb , q2v , q2b , & ! out : + runsrf , runsub , apar , psn , sav , sag , & ! out : + fsno , nee , gpp , npp , fveg , albedo , & ! out : + qsnbot , ponding , ponding1, ponding2, rssun , rssha , & ! out : + bgap , wgap , chv , chb , emissi , & ! out : + shg , shc , shb , evg , evb , ghv , & ! out : + ghb , irg , irc , irb , tr , evc , & ! out : + chleaf , chuc , chv2 , chb2 , fpice , pahv , & + pahg , pahb , pah , esnow) + +! -------------------------------------------------------------------------------------------------- +! initial code: guo-yue niu, oct. 2007 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + + integer , intent(in) :: ice !ice (ice = 1) + integer , intent(in) :: ist !surface type 1->soil; 2->lake + integer , intent(in) :: vegtyp !vegetation type + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !no. of soil layers + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: dt !time step [sec] + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + real , intent(in) :: q2 !mixing ratio (kg/kg) lowest model layer + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: uu !wind speed in eastward dir (m/s) + real , intent(in) :: vv !wind speed in northward dir (m/s) + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(inout) :: zlvl !reference height (m) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + real , intent(in) :: tbot !bottom condition for soil temp. [k] + real , intent(in) :: foln !foliage nitrogen (%) [1-saturated] + real , intent(in) :: shdfac !green vegetation fraction [0.0-1.0] + integer , intent(in) :: yearlen!number of days in the particular year. + real , intent(in) :: julian !julian day of year (floating point) + real , intent(in) :: lat !latitude (radians) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] + real , intent(in) :: prcpconv ! convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpnonc ! non-convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpshcv ! shallow convective precip entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpsnow ! snow entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpgrpl ! graupel entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcphail ! hail entering land model [mm/s] ! mb/an : v3.7 + +!jref:start; in + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(in) :: dx + real , intent(in) :: shdmax !yearly max vegetation fraction +!jref:end + + +! input/output : need arbitary intial values + real , intent(inout) :: qsnow !snowfall [mm/s] + real , intent(inout) :: fwet !wetted or snowed fraction of canopy (-) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , intent(inout) :: eah !canopy air vapor pressure (pa) + real , intent(inout) :: tah !canopy air tmeperature (k) + real , intent(inout) :: albold !snow albedo at last time step (class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: tauss !non-dimensional snow age + +! prognostic variables + integer , intent(inout) :: isnow !actual no. of snow layers [-] + real , intent(inout) :: canliq !intercepted liquid water (mm) + real , intent(inout) :: canice !intercepted ice mass (mm) + real , intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + real , intent(inout) :: snowh !snow height [m] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real , intent(inout) :: tv !vegetation temperature (k) + real , intent(inout) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , intent(inout) :: zwt !depth to water table [m] + real , intent(inout) :: wa !water storage in aquifer [mm] + real , intent(inout) :: wt !water in aquifer&saturated soil [mm] + real , intent(inout) :: wslake !lake water storage (can be neg.) (mm) + real, intent(inout) :: smcwtd !soil water content between bottom of the soil and water table [m3/m3] + real, intent(inout) :: deeprech !recharge to or from the water table when deep [m] + real, intent(inout) :: rech !recharge to or from the water table when shallow [m] (diagnostic) + +! output + real , intent(out) :: z0wrf !combined z0 sent to coupled model + real , intent(out) :: fsa !total absorbed solar radiation (w/m2) + real , intent(out) :: fsr !total reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fcev !canopy evap heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evap heat (w/m2) [+ to atm] + real , intent(out) :: fctr !transpiration heat (w/m2) [+ to atm] + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: trad !surface radiative temperature (k) + real :: ts !surface temperature (k) + real , intent(out) :: ecan !evaporation of intercepted water (mm/s) + real , intent(out) :: etran !transpiration rate (mm/s) + real , intent(out) :: edir !soil surface evaporation rate (mm/s] + real , intent(out) :: runsrf !surface runoff [mm/s] + real , intent(out) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(out) :: psn !total photosynthesis (umol co2/m2/s) [+] + real , intent(out) :: apar !photosyn active energy by canopy (w/m2) + real , intent(out) :: sav !solar rad absorbed by veg. (w/m2) + real , intent(out) :: sag !solar rad absorbed by ground (w/m2) + real , intent(out) :: fsno !snow cover fraction on the ground (-) + real , intent(out) :: fveg !green vegetation fraction [0.0-1.0] + real , intent(out) :: albedo !surface albedo [-] + real :: errwat !water error [kg m{-2}] + real , intent(out) :: qsnbot !snowmelt out bottom of pack [mm/s] + real , intent(out) :: ponding!surface ponding [mm] + real , intent(out) :: ponding1!surface ponding [mm] + real , intent(out) :: ponding2!surface ponding [mm] + real , intent(out) :: esnow + +!jref:start; output + real , intent(out) :: t2mv !2-m air temperature over vegetated part [k] + real , intent(out) :: t2mb !2-m air temperature over bare ground part [k] + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) + real, intent(out) :: bgap + real, intent(out) :: wgap + real, intent(out) :: tgv + real, intent(out) :: tgb + real :: q1 + real, intent(out) :: emissi +!jref:end + +! local + integer :: iz !do-loop index + integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] + real :: cmc !intercepted water (canice+canliq) (mm) + real :: taux !wind stress: e-w (n/m2) + real :: tauy !wind stress: n-s (n/m2) + real :: rhoair !density air (kg/m3) +! real, dimension( 1: 5) :: vocflx !voc fluxes [ug c m-2 h-1] + real, dimension(-nsnow+1:nsoil) :: dzsnso !snow/soil layer thickness [m] + real :: thair !potential temperature (k) + real :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real :: eair !vapor pressure air (pa) + real, dimension( 1: 2) :: solad !incoming direct solar rad (w/m2) + real, dimension( 1: 2) :: solai !incoming diffuse solar rad (w/m2) + real :: qprecc !convective precipitation (mm/s) + real :: qprecl !large-scale precipitation (mm/s) + real :: igs !growing season index (0=off, 1=on) + real :: elai !leaf area index, after burying by snow + real :: esai !stem area index, after burying by snow + real :: bevap !soil water evaporation factor (0 - 1) + real, dimension( 1:nsoil) :: btrani !soil water transpiration factor (0 - 1) + real :: btran !soil water transpiration factor (0 - 1) + real :: qin !groundwater recharge [mm/s] + real :: qdis !groundwater discharge [mm/s] + real, dimension( 1:nsoil) :: sice !soil ice content (m3/m3) + real, dimension(-nsnow+1: 0) :: snicev !partial volume ice of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: snliqv !partial volume liq of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: epore !effective porosity [m3/m3] + real :: totsc !total soil carbon (g/m2) + real :: totlb !total living carbon (g/m2) + real :: t2m !2-meter air temperature (k) + real :: qdew !ground surface dew rate [mm/s] + real :: qvap !ground surface evap. rate [mm/s] + real :: lathea !latent heat [j/kg] + real :: swdown !downward solar [w/m2] + real :: qmelt !snowmelt [mm/s] + real :: beg_wb !water storage at begin of a step [mm] + real,intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm] + real,intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm] + real,intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm] + real,intent(out) :: shg !ground sen. heat [w/m2] [+ to atm] + real,intent(out) :: evg !ground evap. heat [w/m2] [+ to atm] + real,intent(out) :: ghv !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: irb !net longwave rad. [w/m2] [+ to atm] + real,intent(out) :: shb !sensible heat [w/m2] [+ to atm] + real,intent(out) :: evb !evaporation heat [w/m2] [+ to atm] + real,intent(out) :: ghb !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm] + real,intent(out) :: tr !transpiration heat [w/m2] [+ to atm] + real, intent(out) :: fpice !snow fraction in precipitation + real, intent(out) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(out) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(out) :: pahb !precipitation advected heat - bare ground net (w/m2) + real, intent(out) :: pah !precipitation advected heat - total (w/m2) + +!jref:start + real :: fsrv + real :: fsrg + real,intent(out) :: q2v + real,intent(out) :: q2b + real :: q2e + real :: qfx + real,intent(out) :: chv !sensible heat exchange coefficient over vegetated fraction + real,intent(out) :: chb !sensible heat exchange coefficient over bare-ground + real,intent(out) :: chleaf !leaf exchange coefficient + real,intent(out) :: chuc !under canopy exchange coefficient + real,intent(out) :: chv2 !sensible heat exchange coefficient over vegetated fraction + real,intent(out) :: chb2 !sensible heat exchange coefficient over bare-ground +!jref:end + +! carbon +! inputs + real , intent(in) :: co2air !atmospheric co2 concentration (pa) + real , intent(in) :: o2air !atmospheric o2 concentration (pa) + +! inputs and outputs : prognostic variables + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + real , intent(inout) :: stblcp !stable carbon in deep soil [g/m2] + real , intent(inout) :: fastcp !short-lived carbon, shallow soil [g/m2] + real , intent(inout) :: lai !leaf area index [-] + real , intent(inout) :: sai !stem area index [-] + +! outputs + real , intent(out) :: nee !net ecosys exchange (g/m2/s co2) + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c] + real , intent(out) :: npp !net primary productivity [g/m2/s c] + real :: autors !net ecosystem respiration (g/m2/s c) + real :: heters !organic respiration (g/m2/s c) + real :: troot !root-zone averaged temperature (k) + real :: bdfall !bulk density of new snow (kg/m3) ! mb/an: v3.7 + real :: rain !rain rate (mm/s) ! mb/an: v3.7 + real :: snow !liquid equivalent snow rate (mm/s) ! mb/an: v3.7 + real :: fp ! mb/an: v3.7 + real :: prcp ! mb/an: v3.7 +!more local variables for precip heat mb + real :: qintr !interception rate for rain (mm/s) + real :: qdripr !drip rate for rain (mm/s) + real :: qthror !throughfall for rain (mm/s) + real :: qints !interception (loading) rate for snowfall (mm/s) + real :: qdrips !drip (unloading) rate for intercepted snow (mm/s) + real :: qthros !throughfall of snowfall (mm/s) + real :: qrain !rain at ground srf (mm/s) [+] + real :: snowhin !snow depth increasing rate (m/s) + real :: latheav !latent heat vap./sublimation (j/kg) + real :: latheag !latent heat vap./sublimation (j/kg) + logical :: frozen_ground ! used to define latent heat pathway + logical :: frozen_canopy ! used to define latent heat pathway + + ! intent (out) variables need to be assigned a value. these normally get assigned values + ! only if dveg == 2. + nee = 0.0 + npp = 0.0 + gpp = 0.0 + pahv = 0. + pahg = 0. + pahb = 0. + pah = 0. + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + call atm (parameters,sfcprs ,sfctmp ,q2 , & + prcpconv, prcpnonc,prcpshcv,prcpsnow,prcpgrpl,prcphail, & + soldn ,cosz ,thair ,qair , & + eair ,rhoair ,qprecc ,qprecl ,solad ,solai , & + swdown ,bdfall ,rain ,snow ,fp ,fpice , prcp ) + +! snow/soil layer thickness (m) + + do iz = isnow+1, nsoil + if(iz == isnow+1) then + dzsnso(iz) = - zsnso(iz) + else + dzsnso(iz) = zsnso(iz-1) - zsnso(iz) + end if + end do + +! root-zone temperature + + troot = 0. + do iz=1,parameters%nroot + troot = troot + stc(iz)*dzsnso(iz)/(-zsoil(parameters%nroot)) + enddo + +! total water storage for water balance check + + if(ist == 1) then + beg_wb = canliq + canice + sneqv + wa + do iz = 1,nsoil + beg_wb = beg_wb + smc(iz) * dzsnso(iz) * 1000. + end do + end if + +! vegetation phenology + + call phenology (parameters,vegtyp , snowh , tv , lat , yearlen , julian , & !in + lai , sai , troot , elai , esai ,igs) + +!input gvf should be consistent with lai + if(dveg == 1) then + fveg = shdfac + if(fveg <= 0.05) fveg = 0.05 + else if (dveg == 2 .or. dveg == 3) then + fveg = 1.-exp(-0.52*(lai+sai)) + if(fveg <= 0.05) fveg = 0.05 + else if (dveg == 4 .or. dveg == 5) then + fveg = shdmax + if(fveg <= 0.05) fveg = 0.05 + else + write(*,*) "-------- fatal called in sflx -----------" + call wrf_error_fatal("namelist parameter dveg unknown") + endif + if(parameters%urban_flag .or. vegtyp == parameters%isbarren) fveg = 0.0 + if(elai+esai == 0.0) fveg = 0.0 + + call precip_heat(parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in + elai ,esai ,fveg ,ist , & !in + bdfall ,rain ,snow ,fp , & !in + canliq ,canice ,tv ,sfctmp ,tg , & !in + qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out + pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out + fwet ,cmc ) !out + +! compute energy budget (momentum & energy fluxes and phase changes) + + call energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in + isnow ,dt ,rhoair ,sfcprs ,qair , & !in + sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in + co2air ,o2air ,solad ,solai ,cosz ,igs , & !in + eair ,tbot ,zsnso ,zsoil , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,pahv ,pahg ,pahb , & !in + qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in + z0wrf , & + imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out + sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out + tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + trad ,psn ,apar ,ssoil ,btrani ,btran , & !out + ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out + tv ,tg ,stc ,snowh ,eah ,tah , & !inout + sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout + albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout + tauss , & !inout +!jref:start + qc ,qsfc ,psfc , & !in + t2mv ,t2mb ,fsrv , & + fsrg ,rssun ,rssha ,bgap ,wgap, tgv,tgb,& + q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out + emissi ,pah , & + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out +!jref:end + + sice(:) = max(0.0, smc(:) - sh2o(:)) + sneqvo = sneqv + + qvap = max( fgev/latheag, 0.) ! positive part of fgev; barlage change to ground v3.6 + qdew = abs( min(fgev/latheag, 0.)) ! negative part of fgev + edir = qvap - qdew + +! compute water budgets (water storages, et components, and runoff) + + call water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in + vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in + esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in + ficeold,ponding,tg ,ist ,fveg ,iloc,jloc , smceq , & !in + bdfall ,fp ,rain ,snow , & !in mb/an: v3.7 + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout + snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout + sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout + smcwtd ,deeprech,rech , & !inout + cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out + qin ,qdis ,ponding1 ,ponding2,& + qsnbot ,esnow ) !out + +! write(*,'(a20,10f15.5)') 'sflx:runoff=',runsrf*dt,runsub*dt,edir*dt + +! compute carbon budgets (carbon storages and co2 & bvoc fluxes) + + if (dveg == 2 .or. dveg == 5) then + call carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in + dzsnso ,stc ,smc ,tv ,tg ,psn , & !in + foln ,btran ,apar ,fveg ,igs , & !in + troot ,ist ,lat ,iloc ,jloc , & !in + lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout + gpp ,npp ,nee ,autors ,heters ,totsc , & !out + totlb ,lai ,sai ) !out + end if + +! water and energy balance check + + call error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & !in + fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & !in + sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & !in + etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in + nsnow ,ist ,errwat ,iloc , jloc ,fveg , & + sav ,sag ,fsrv ,fsrg ,zwt ,pah , & + pahv ,pahg ,pahb ) !in ( except errwat, which is out ) + +! urban - jref + qfx = etran + ecan + edir + if ( parameters%urban_flag ) then + qsfc = (qfx/rhoair*ch) + qair + q2b = qsfc + end if + + if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then + snowh = 0.0 + sneqv = 0.0 + end if + + if(swdown.ne.0.) then + albedo = fsr / swdown + else + albedo = -999.9 + end if + + + end subroutine noahmp_sflx + +!== begin atm ====================================================================================== + + subroutine atm (parameters,sfcprs ,sfctmp ,q2 , & + prcpconv,prcpnonc ,prcpshcv,prcpsnow,prcpgrpl,prcphail , & + soldn ,cosz ,thair ,qair , & + eair ,rhoair ,qprecc ,qprecl ,solad , solai , & + swdown ,bdfall ,rain ,snow ,fp , fpice ,prcp ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! ---------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: prcpconv ! convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpnonc ! non-convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpshcv ! shallow convective precip entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpsnow ! snow entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpgrpl ! graupel entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcphail ! hail entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + +! outputs + + real , intent(out) :: thair !potential temperature (k) + real , intent(out) :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real , intent(out) :: eair !vapor pressure air (pa) + real , intent(out) :: rhoair !density air (kg/m3) + real , intent(out) :: qprecc !convective precipitation (mm/s) + real , intent(out) :: qprecl !large-scale precipitation (mm/s) + real, dimension( 1: 2), intent(out) :: solad !incoming direct solar radiation (w/m2) + real, dimension( 1: 2), intent(out) :: solai !incoming diffuse solar radiation (w/m2) + real , intent(out) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(out) :: bdfall !!bulk density of snowfall (kg/m3) ajn + real , intent(out) :: rain !rainfall (mm/s) ajn + real , intent(out) :: snow !liquid equivalent snowfall (mm/s) ajn + real , intent(out) :: fp !fraction of area receiving precipitation ajn + real , intent(out) :: fpice !fraction of ice ajn + real , intent(out) :: prcp !total precipitation [mm/s] ! mb/an : v3.7 + +!locals + + real :: pair !atm bottom level pressure (pa) + real :: prcp_frozen !total frozen precipitation [mm/s] ! mb/an : v3.7 + real, parameter :: rho_grpl = 500.0 ! graupel bulk density [kg/m3] ! mb/an : v3.7 + real, parameter :: rho_hail = 917.0 ! hail bulk density [kg/m3] ! mb/an : v3.7 +! -------------------------------------------------------------------------------------------------- + +!jref: seems like pair should be p1000mb?? + pair = sfcprs ! atm bottom level pressure (pa) + thair = sfctmp * (sfcprs/pair)**(rair/cpair) + + qair = q2 ! in wrf, driver converts to specific humidity + + eair = qair*sfcprs / (0.622+0.378*qair) + rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + + if(cosz <= 0.) then + swdown = 0. + else + swdown = soldn + end if + + solad(1) = swdown*0.7*0.5 ! direct vis + solad(2) = swdown*0.7*0.5 ! direct nir + solai(1) = swdown*0.3*0.5 ! diffuse vis + solai(2) = swdown*0.3*0.5 ! diffuse nir + + prcp = prcpconv + prcpnonc + prcpshcv + +! if(opt_snf == 4) then + qprecc = prcpconv + prcpshcv + qprecl = prcpnonc +! else +! qprecc = 0.10 * prcp ! should be from the atmospheric model +! qprecl = 0.90 * prcp ! should be from the atmospheric model +! end if + +! fractional area that receives precipitation (see, niu et al. 2005) + + fp = 0.0 + if(qprecc + qprecl > 0.) & + fp = (qprecc + qprecl) / (10.*qprecc + qprecl) + +! partition precipitation into rain and snow. moved from canwat mb/an: v3.7 + +! jordan (1991) + + if(opt_snf == 1) then + if(sfctmp > tfrz+2.5)then + fpice = 0. + else + if(sfctmp <= tfrz+0.5)then + fpice = 1.0 + else if(sfctmp <= tfrz+2.)then + fpice = 1.-(-54.632 + 0.2*sfctmp) + else + fpice = 0.6 + endif + endif + endif + + if(opt_snf == 2) then + if(sfctmp >= tfrz+2.2) then + fpice = 0. + else + fpice = 1.0 + endif + endif + + if(opt_snf == 3) then + if(sfctmp >= tfrz) then + fpice = 0. + else + fpice = 1.0 + endif + endif + +! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625 +! fresh snow density + + bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb/an: change to min + if(opt_snf == 4) then + prcp_frozen = prcpsnow + prcpgrpl + prcphail + if(prcpnonc > 0. .and. prcp_frozen > 0.) then + fpice = min(1.0,prcp_frozen/prcp) + fpice = max(0.0,fpice) + bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + & + rho_hail*(prcphail/prcp_frozen) + else + fpice = 0.0 + endif + + endif + + rain = prcp * (1.-fpice) + snow = prcp * fpice + + + end subroutine atm + +!== begin phenology ================================================================================ + + subroutine phenology (parameters,vegtyp , snowh , tv , lat , yearlen , julian , & !in + lai , sai , troot , elai , esai , igs) + +! -------------------------------------------------------------------------------------------------- +! vegetation phenology considering vegeation canopy being buries by snow and evolution in time +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in ) :: vegtyp !vegetation type + real , intent(in ) :: snowh !snow height [m] + real , intent(in ) :: tv !vegetation temperature (k) + real , intent(in ) :: lat !latitude (radians) + integer , intent(in ) :: yearlen!number of days in the particular year + real , intent(in ) :: julian !julian day of year (fractional) ( 0 <= julian < yearlen ) + real , intent(in ) :: troot !root-zone averaged temperature (k) + real , intent(inout) :: lai !lai, unadjusted for burying by snow + real , intent(inout) :: sai !sai, unadjusted for burying by snow + +! outputs + real , intent(out ) :: elai !leaf area index, after burying by snow + real , intent(out ) :: esai !stem area index, after burying by snow + real , intent(out ) :: igs !growing season index (0=off, 1=on) + +! locals + + real :: db !thickness of canopy buried by snow (m) + real :: fb !fraction of canopy buried by snow + real :: snowhc !critical snow depth at which short vege + !is fully covered by snow + + integer :: k !index + integer :: it1,it2 !interpolation months + real :: day !current day of year ( 0 <= day < yearlen ) + real :: wt1,wt2 !interpolation weights + real :: t !current month (1.00, ..., 12.00) +! -------------------------------------------------------------------------------------------------- + + if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then + + if (lat >= 0.) then + ! northern hemisphere + day = julian + else + ! southern hemisphere. day is shifted by 1/2 year. + day = mod ( julian + ( 0.5 * yearlen ) , real(yearlen) ) + endif + + t = 12. * day / real(yearlen) + it1 = t + 0.5 + it2 = it1 + 1 + wt1 = (it1+0.5) - t + wt2 = 1.-wt1 + if (it1 .lt. 1) it1 = 12 + if (it2 .gt. 12) it2 = 1 + + lai = wt1*parameters%laim(it1) + wt2*parameters%laim(it2) + sai = wt1*parameters%saim(it1) + wt2*parameters%saim(it2) + endif + if (sai < 0.05) sai = 0.0 ! mb: sai check, change to 0.05 v3.6 + if (lai < 0.05 .or. sai == 0.0) lai = 0.0 ! mb: lai check + + if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. & + ( vegtyp == parameters%isice ) .or. ( parameters%urban_flag ) ) then + lai = 0. + sai = 0. + endif + +!buried by snow + + db = min( max(snowh - parameters%hvb,0.), parameters%hvt-parameters%hvb ) + fb = db / max(1.e-06,parameters%hvt-parameters%hvb) + + if(parameters%hvt> 0. .and. parameters%hvt <= 1.0) then !mb: change to 1.0 and 0.2 to reflect + snowhc = parameters%hvt*exp(-snowh/0.2) ! changes to hvt in mptable + fb = min(snowh,snowhc)/snowhc + endif + + elai = lai*(1.-fb) + esai = sai*(1.-fb) + if (esai < 0.05) esai = 0.0 ! mb: esai check, change to 0.05 v3.6 + if (elai < 0.05 .or. esai == 0.0) elai = 0.0 ! mb: lai check + + if (tv .gt. parameters%tmin) then + igs = 1. + else + igs = 0. + endif + + end subroutine phenology + +!== begin precip_heat ============================================================================== + + subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in + elai ,esai ,fveg ,ist , & !in + bdfall ,rain ,snow ,fp , & !in + canliq ,canice ,tv ,sfctmp ,tg , & !in + qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out + pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out + fwet ,cmc ) !out + +! ------------------------ code history ------------------------------ +! michael barlage: oct 2013 - split canwater to calculate precip movement for +! tracking of advected heat +! -------------------------------------------------------------------------------------------------- + implicit none +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation type + integer,intent(in) :: ist !surface type 1-soil; 2-lake + real, intent(in) :: dt !main time step (s) + real, intent(in) :: uu !u-direction wind speed [m/s] + real, intent(in) :: vv !v-direction wind speed [m/s] + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: fveg !greeness vegetation fraction (-) + real, intent(in) :: bdfall !bulk density of snowfall (kg/m3) + real, intent(in) :: rain !rainfall (mm/s) + real, intent(in) :: snow !snowfall (mm/s) + real, intent(in) :: fp !fraction of the gridcell that receives precipitation + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: sfctmp !model-level temperature (k) + real, intent(in) :: tg !ground temperature (k) + +! input & output + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + +! output + real, intent(out) :: qintr !interception rate for rain (mm/s) + real, intent(out) :: qdripr !drip rate for rain (mm/s) + real, intent(out) :: qthror !throughfall for rain (mm/s) + real, intent(out) :: qints !interception (loading) rate for snowfall (mm/s) + real, intent(out) :: qdrips !drip (unloading) rate for intercepted snow (mm/s) + real, intent(out) :: qthros !throughfall of snowfall (mm/s) + real, intent(out) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(out) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(out) :: pahb !precipitation advected heat - bare ground net (w/m2) + real, intent(out) :: qrain !rain at ground srf (mm/s) [+] + real, intent(out) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(out) :: snowhin !snow depth increasing rate (m/s) + real, intent(out) :: fwet !wetted or snowed fraction of the canopy (-) + real, intent(out) :: cmc !intercepted water (mm) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + real :: maxsno !canopy capacity for snow interception (mm) + real :: maxliq !canopy capacity for rain interception (mm) + real :: ft !temperature factor for unloading rate + real :: fv !wind factor for unloading rate + real :: pah_ac !precipitation advected heat - air to canopy (w/m2) + real :: pah_cg !precipitation advected heat - canopy to ground (w/m2) + real :: pah_ag !precipitation advected heat - air to ground (w/m2) + real :: icedrip !canice unloading +! -------------------------------------------------------------------- +! initialization + + qintr = 0. + qdripr = 0. + qthror = 0. + qintr = 0. + qints = 0. + qdrips = 0. + qthros = 0. + pah_ac = 0. + pah_cg = 0. + pah_ag = 0. + pahv = 0. + pahg = 0. + pahb = 0. + qrain = 0.0 + qsnow = 0.0 + snowhin = 0.0 + icedrip = 0.0 +! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt +! print*, "precip_heat snow*3600.0:",snow*3600.0 +! print*, "precip_heat rain*3600.0:",rain*3600.0 +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + maxliq = parameters%ch2op * (elai+ esai) + +! average interception and throughfall + + if((elai+ esai).gt.0.) then + qintr = fveg * rain * fp ! interception capability + qintr = min(qintr, (maxliq - canliq)/dt * (1.-exp(-rain*dt/maxliq)) ) + qintr = max(qintr, 0.) + qdripr = fveg * rain - qintr + qthror = (1.-fveg) * rain + canliq=max(0.,canliq+qintr*dt) + else + qintr = 0. + qdripr = 0. + qthror = rain + if(canliq > 0.) then ! for case of canopy getting buried + qdripr = qdripr + canliq/dt + canliq = 0.0 + end if + end if + +! heat transported by liquid water + + pah_ac = fveg * rain * (cwat/1000.0) * (sfctmp - tv) + pah_cg = qdripr * (cwat/1000.0) * (tv - tg) + pah_ag = qthror * (cwat/1000.0) * (sfctmp - tg) +! print*, "precip_heat pah_ac:",pah_ac +! print*, "precip_heat pah_cg:",pah_cg +! print*, "precip_heat pah_ag:",pah_ag + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai) + + if((elai+ esai).gt.0.) then + qints = fveg * snow * fp + qints = min(qints, (maxsno - canice)/dt * (1.-exp(-snow*dt/maxsno)) ) + qints = max(qints, 0.) + ft = max(0.0,(tv - 270.15) / 1.87e5) + fv = sqrt(uu*uu + vv*vv) / 1.56e5 + ! mb: changed below to reflect the rain assumption that all precip gets intercepted + icedrip = max(0.,canice) * (fv+ft) !mb: removed /dt + qdrips = (fveg * snow - qints) + icedrip + qthros = (1.0-fveg) * snow + canice= max(0.,canice + (qints - icedrip)*dt) + else + qints = 0. + qdrips = 0. + qthros = snow + if(canice > 0.) then ! for case of canopy getting buried + qdrips = qdrips + canice/dt + canice = 0.0 + end if + endif +! print*, "precip_heat canopy through:",3600.0*(fveg * snow - qints) +! print*, "precip_heat canopy drip:",3600.0*max(0.,canice) * (fv+ft) + +! wetted fraction of canopy + + if(canice.gt.0.) then + fwet = max(0.,canice) / max(maxsno,1.e-06) + else + fwet = max(0.,canliq) / max(maxliq,1.e-06) + endif + fwet = min(fwet, 1.) ** 0.667 + +! total canopy water + + cmc = canliq + canice + +! heat transported by snow/ice + + pah_ac = pah_ac + fveg * snow * (cice/1000.0) * (sfctmp - tv) + pah_cg = pah_cg + qdrips * (cice/1000.0) * (tv - tg) + pah_ag = pah_ag + qthros * (cice/1000.0) * (sfctmp - tg) + + pahv = pah_ac - pah_cg + pahg = pah_cg + pahb = pah_ag + + if (fveg > 0.0 .and. fveg < 1.0) then + pahg = pahg / fveg ! these will be multiplied by fraction later + pahb = pahb / (1.0-fveg) + elseif (fveg <= 0.0) then + pahb = pahg + pahb ! for case of canopy getting buried + pahg = 0.0 + pahv = 0.0 + elseif (fveg >= 1.0) then + pahb = 0.0 + end if + + pahv = max(pahv,-20.0) ! put some artificial limits here for stability + pahv = min(pahv,20.0) + pahg = max(pahg,-20.0) + pahg = min(pahg,20.0) + pahb = max(pahb,-20.0) + pahb = min(pahb,20.0) + +! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg +! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros) +! print*, "precip_heat maxsno:",maxsno +! print*, "precip_heat pah_ac:",pah_ac +! print*, "precip_heat pah_cg:",pah_cg +! print*, "precip_heat pah_ag:",pah_ag + +! print*, "precip_heat pahv:",pahv +! print*, "precip_heat pahg:",pahg +! print*, "precip_heat pahb:",pahb +! print*, "precip_heat fveg:",fveg +! print*, "precip_heat qints*3600.0:",qints*3600.0 +! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0 +! print*, "precip_heat qthros*3600.0:",qthros*3600.0 + +! rain or snow on the ground + + qrain = qdripr + qthror + qsnow = qdrips + qthros + snowhin = qsnow/bdfall + + if (ist == 2 .and. tg > tfrz) then + qsnow = 0. + snowhin = 0. + end if +! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0 +! print*, "precip_heat qrain*3600.0:",qrain*3600.0 +! print*, "precip_heat snowhin:",snowhin +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq +! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt + + + end subroutine precip_heat + +!== begin error ==================================================================================== + + subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & + fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & + sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & + etran ,edir ,runsrf ,runsub ,dt ,nsoil , & + nsnow ,ist ,errwat, iloc ,jloc ,fveg , & + sav ,sag ,fsrv ,fsrg ,zwt ,pah , & + pahv ,pahg ,pahb ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: ist !surface type 1->soil; 2->lake + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(in) :: fsa !total absorbed solar radiation (w/m2) + real , intent(in) :: fsr !total reflected solar radiation (w/m2) + real , intent(in) :: fira !total net longwave rad (w/m2) [+ to atm] + real , intent(in) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(in) :: fcev !canopy evaporation heat (w/m2) [+ to atm] + real , intent(in) :: fgev !ground evaporation heat (w/m2) [+ to atm] + real , intent(in) :: fctr !transpiration heat flux (w/m2) [+ to atm] + real , intent(in) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(in) :: fveg + real , intent(in) :: sav + real , intent(in) :: sag + real , intent(in) :: fsrv + real , intent(in) :: fsrg + real , intent(in) :: zwt + + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: ecan !evaporation of intercepted water (mm/s) + real , intent(in) :: etran !transpiration rate (mm/s) + real , intent(in) :: edir !soil surface evaporation rate[mm/s] + real , intent(in) :: runsrf !surface runoff [mm/s] + real , intent(in) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(in) :: canliq !intercepted liquid water (mm) + real , intent(in) :: canice !intercepted ice mass (mm) + real , intent(in) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real , intent(in) :: wa !water storage in aquifer [mm] + real , intent(in) :: dt !time step [sec] + real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] + real , intent(out) :: errwat !error in water balance [mm/timestep] + real, intent(in) :: pah !precipitation advected heat - total (w/m2) + real, intent(in) :: pahv !precipitation advected heat - total (w/m2) + real, intent(in) :: pahg !precipitation advected heat - total (w/m2) + real, intent(in) :: pahb !precipitation advected heat - total (w/m2) + + integer :: iz !do-loop index + real :: end_wb !water storage at end of a timestep [mm] + !kwm real :: errwat !error in water balance [mm/timestep] + real :: erreng !error in surface energy balance [w/m2] + real :: errsw !error in shortwave radiation balance [w/m2] + real :: fsrvg + character(len=256) :: message +! -------------------------------------------------------------------------------------------------- +!jref:start + errsw = swdown - (fsa + fsr) +! errsw = swdown - (sav+sag + fsrv+fsrg) +! write(*,*) "errsw =",errsw + if (abs(errsw) > 0.01) then ! w/m2 + write(*,*) "vegetation!" + write(*,*) "swdown*fveg =",swdown*fveg + write(*,*) "fveg*(sav+sag) =",fveg*sav + sag + write(*,*) "fveg*(fsrv +fsrg)=",fveg*fsrv + fsrg + write(*,*) "ground!" + write(*,*) "(1-.fveg)*swdown =",(1.-fveg)*swdown + write(*,*) "(1.-fveg)*sag =",(1.-fveg)*sag + write(*,*) "(1.-fveg)*fsrg=",(1.-fveg)*fsrg + write(*,*) "fsrv =",fsrv + write(*,*) "fsrg =",fsrg + write(*,*) "fsr =",fsr + write(*,*) "sav =",sav + write(*,*) "sag =",sag + write(*,*) "fsa =",fsa +!jref:end + write(message,*) 'errsw =',errsw + call wrf_message(trim(message)) + call wrf_error_fatal("stop in noah-mp") + end if + + erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah +! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) + if(abs(erreng) > 0.01) then + write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "net solar: ",fsa + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "net longwave: ",fira + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "total sensible: ",fsh + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "canopy evap: ",fcev + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "ground evap: ",fgev + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "transpiration: ",fctr + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "total ground: ",ssoil + call wrf_message(trim(message)) + write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "precip: ",prcp + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "veg fraction: ",fveg + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp lsm") + end if + + if (ist == 1) then !soil + end_wb = canliq + canice + sneqv + wa + do iz = 1,nsoil + end_wb = end_wb + smc(iz) * dzsnso(iz) * 1000. + end do + errwat = end_wb-beg_wb-(prcp-ecan-etran-edir-runsrf-runsub)*dt + + else !kwm + errwat = 0.0 !kwm + endif + + end subroutine error + +!== begin energy =================================================================================== + + subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in + isnow ,dt ,rhoair ,sfcprs ,qair , & !in + sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in + co2air ,o2air ,solad ,solai ,cosz ,igs , & !in + eair ,tbot ,zsnso ,zsoil , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,pahv ,pahg ,pahb , & !in + qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in + z0wrf , & + imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out + sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out + tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + trad ,psn ,apar ,ssoil ,btrani ,btran , & !out + ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out + tv ,tg ,stc ,snowh ,eah ,tah , & !inout + sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout + albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout + tauss , & !inout +!jref:start + qc ,qsfc ,psfc , & !in + t2mv ,t2mb ,fsrv , & + fsrg ,rssun ,rssha ,bgap ,wgap,tgv,tgb,& + q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah ,& + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out +!jref:end + +! -------------------------------------------------------------------------------------------------- +! we use different approaches to deal with subgrid features of radiation transfer and turbulent +! transfer. we use 'tile' approach to compute turbulent fluxes, while we use modified two- +! stream to compute radiation transfer. tile approach, assemblying vegetation canopies together, +! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. the +! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree +! crowns. +! -------------------------------------------------------------------------------------------------- +! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and +! bare fraction separately and then sum them up weighted by fraction +! -------------------------------------- +! / o o o o o o o o / / +! / | | | | | | | | / / +! / o o o o o o o o / / +! / | | |tile1| | | | / tile2 / +! / o o o o o o o o / bare / +! / | | | vegetated | | / / +! / o o o o o o o o / / +! / | | | | | | | | / / +! -------------------------------------- +! -------------------------------------------------------------------------------------------------- +! radiation transfer : modified two-stream (yang and friedl, 2003, jgr; niu ang yang, 2004, jgr) +! -------------------------------------- two-stream treats leaves as +! / o o o o o o o o / cloud over the entire grid-cell, +! / | | | | | | | | / while the modified two-stream +! / o o o o o o o o / aggregates cloudy leaves into +! / | | | | | | | | / tree crowns with gaps (as shown in +! / o o o o o o o o / the left figure). we assume these +! / | | | | | | | | / tree crowns are evenly distributed +! / o o o o o o o o / within the gridcell with 100% veg +! / | | | | | | | | / fraction, but with gaps. the 'tile' +! -------------------------------------- approach overlaps too much shadows. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc + integer , intent(in) :: jloc + integer , intent(in) :: ice !ice (ice = 1) + integer , intent(in) :: vegtyp !vegetation physiology type + integer , intent(in) :: ist !surface type: 1->soil; 2->lake + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: qsnow !snowfall on the ground (mm/s) + real , intent(in) :: rhoair !density air (kg/m3) + real , intent(in) :: eair !vapor pressure air (pa) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: qair !specific humidity (kg/kg) + real , intent(in) :: sfctmp !air temperature (k) + real , intent(in) :: thair !potential temperature (k) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: uu !wind speed in e-w dir (m/s) + real , intent(in) :: vv !wind speed in n-s dir (m/s) + real , dimension( 1: 2), intent(in) :: solad !incoming direct solar rad. (w/m2) + real , dimension( 1: 2), intent(in) :: solai !incoming diffuse solar rad. (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle (0-1) + real , intent(in) :: elai !lai adjusted for burying by snow + real , intent(in) :: esai !lai adjusted for burying by snow + real , intent(in) :: fwet !fraction of canopy that is wet [-] + real , intent(in) :: fveg !greeness vegetation fraction (-) + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: canliq !canopy-intercepted liquid water (mm) + real , intent(in) :: canice !canopy-intercepted ice mass (mm) + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: co2air !atmospheric co2 concentration (pa) + real , intent(in) :: o2air !atmospheric o2 concentration (pa) + real , intent(in) :: igs !growing season index (0=off, 1=on) + + real , intent(in) :: zref !reference height (m) + real , intent(in) :: tbot !bottom condition for soil temp. (k) + real , dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bottom depth from snow surf [m] + real , dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !depth of snow & soil layer-bottom [m] + real, intent(in) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(in) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(in) :: pahb !precipitation advected heat - bare ground net (w/m2) + +!jref:start; in + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dx !horisontal resolution + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(in) :: q2 !mixing ratio (kg/kg) +!jref:end + +! outputs + real , intent(out) :: z0wrf !combined z0 sent to coupled model + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] + real , dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume ice [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume liq. water [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real , intent(out) :: fsno !snow cover fraction (-) + real , intent(out) :: qmelt !snowmelt [mm/s] + real , intent(out) :: ponding!pounding at ground [mm] + real , intent(out) :: sav !solar rad. absorbed by veg. (w/m2) + real , intent(out) :: sag !solar rad. absorbed by ground (w/m2) + real , intent(out) :: fsa !tot. absorbed solar radiation (w/m2) + real , intent(out) :: fsr !tot. reflected solar radiation (w/m2) + real , intent(out) :: taux !wind stress: e-w (n/m2) + real , intent(out) :: tauy !wind stress: n-s (n/m2) + real , intent(out) :: fira !total net lw. rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fcev !canopy evaporation (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evaporation (w/m2) [+ to atm] + real , intent(out) :: fctr !transpiration (w/m2) [+ to atm] + real , intent(out) :: trad !radiative temperature (k) + real , intent(out) :: t2m !2 m height air temperature (k) + real , intent(out) :: psn !total photosyn. (umolco2/m2/s) [+] + real , intent(out) :: apar !total photosyn. active energy (w/m2) + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , dimension( 1:nsoil), intent(out) :: btrani !soil water transpiration factor (0-1) + real , intent(out) :: btran !soil water transpiration factor (0-1) +! real , intent(out) :: lathea !latent heat vap./sublimation (j/kg) + real , intent(out) :: latheav !latent heat vap./sublimation (j/kg) + real , intent(out) :: latheag !latent heat vap./sublimation (j/kg) + logical , intent(out) :: frozen_ground ! used to define latent heat pathway + logical , intent(out) :: frozen_canopy ! used to define latent heat pathway + +!jref:start + real , intent(out) :: fsrv !veg. reflected solar radiation (w/m2) + real , intent(out) :: fsrg !ground reflected solar radiation (w/m2) + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) +!jref:end - out for debug + +!jref:start; output + real , intent(out) :: t2mv !2-m air temperature over vegetated part [k] + real , intent(out) :: t2mb !2-m air temperature over bare ground part [k] + real , intent(out) :: bgap + real , intent(out) :: wgap +!jref:end + +! input & output + real , intent(inout) :: ts !surface temperature (k) + real , intent(inout) :: tv !vegetation temperature (k) + real , intent(inout) :: tg !ground temperature (k) + real , dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real , intent(inout) :: snowh !snow height [m] + real , intent(inout) :: sneqv !snow mass (mm) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real , dimension(-nsnow+1: 0), intent(inout) :: snice !snow ice mass (kg/m2) + real , dimension(-nsnow+1: 0), intent(inout) :: snliq !snow liq mass (kg/m2) + real , intent(inout) :: eah !canopy air vapor pressure (pa) + real , intent(inout) :: tah !canopy air temperature (k) + real , intent(inout) :: albold !snow albedo at last time step(class type) + real , intent(inout) :: tauss !non-dimensional snow age + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: q1 +! real :: q2e + real, intent(out) :: emissi + real, intent(out) :: pah !precipitation advected heat - total (w/m2) + +! local + integer :: iz !do-loop index + logical :: veg !true if vegetated surface + real :: ur !wind speed at height zlvl (m/s) + real :: zlvl !reference height (m) + real :: fsun !sunlit fraction of canopy [-] + real :: rb !leaf boundary layer resistance (s/m) + real :: rsurf !ground surface resistance (s/m) + real :: l_rsurf!dry-layer thickness for computing rsurf (sakaguchi and zeng, 2009) + real :: d_rsurf!reduced vapor diffusivity in soil for computing rsurf (sz09) + real :: bevap !soil water evaporation factor (0- 1) + real :: mol !monin-obukhov length (m) + real :: vai !sum of lai + stem area index [m2/m2] + real :: cwp !canopy wind extinction parameter + real :: zpd !zero plane displacement (m) + real :: z0m !z0 momentum (m) + real :: zpdg !zero plane displacement (m) + real :: z0mg !z0 momentum, ground (m) + real :: emv !vegetation emissivity + real :: emg !ground emissivity + real :: fire !emitted ir (w/m2) + + real :: laisun !sunlit leaf area index (m2/m2) + real :: laisha !shaded leaf area index (m2/m2) + real :: psnsun !sunlit photosynthesis (umolco2/m2/s) + real :: psnsha !shaded photosynthesis (umolco2/m2/s) +!jref:start - for debug +! real :: rssun !sunlit stomatal resistance (s/m) +! real :: rssha !shaded stomatal resistance (s/m) +!jref:end - for debug + real :: parsun !par absorbed per sunlit lai (w/m2) + real :: parsha !par absorbed per shaded lai (w/m2) + + real, dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change + real, dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k] + real :: bdsno !bulk density of snow (kg/m3) + real :: fmelt !melting factor for snow cover frac + real :: gx !temporary variable + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) +! real :: gamma !psychrometric constant (pa/k) + real :: gammav !psychrometric constant (pa/k) + real :: gammag !psychrometric constant (pa/k) + real :: psi !surface layer soil matrix potential (m) + real :: rhsur !raltive humidity in surface soil/snow air space (-) + +! temperature and fluxes over vegetated fraction + + real :: tauxv !wind stress: e-w dir [n/m2] + real :: tauyv !wind stress: n-s dir [n/m2] + real,intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm] + real,intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm] + real,intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm] + real,intent(out) :: shg !ground sen. heat [w/m2] [+ to atm] +!jref:start + real,intent(out) :: q2v + real,intent(out) :: q2b + real,intent(out) :: q2e +!jref:end + real,intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm] + real,intent(out) :: evg !ground evap. heat [w/m2] [+ to atm] + real,intent(out) :: tr !transpiration heat [w/m2] [+ to atm] + real,intent(out) :: ghv !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: tgv !ground surface temp. [k] + real :: cmv !momentum drag coefficient + real,intent(out) :: chv !sensible heat exchange coefficient + +! temperature and fluxes over bare soil fraction + + real :: tauxb !wind stress: e-w dir [n/m2] + real :: tauyb !wind stress: n-s dir [n/m2] + real,intent(out) :: irb !net longwave rad. [w/m2] [+ to atm] + real,intent(out) :: shb !sensible heat [w/m2] [+ to atm] + real,intent(out) :: evb !evaporation heat [w/m2] [+ to atm] + real,intent(out) :: ghb !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: tgb !ground surface temp. [k] + real :: cmb !momentum drag coefficient + real,intent(out) :: chb !sensible heat exchange coefficient + real,intent(out) :: chleaf !leaf exchange coefficient + real,intent(out) :: chuc !under canopy exchange coefficient +!jref:start + real,intent(out) :: chv2 !sensible heat conductance, canopy air to zlvl air (m/s) + real,intent(out) :: chb2 !sensible heat conductance, canopy air to zlvl air (m/s) + real :: noahmpres + +!jref:end + + real, parameter :: mpe = 1.e-6 + real, parameter :: psiwlt = -150. !metric potential for wilting point (m) + real, parameter :: z0 = 0.01 ! bare-soil roughness length (m) (i.e., under the canopy) + +! --------------------------------------------------------------------------------------------------- +! initialize fluxes from veg. fraction + + tauxv = 0. + tauyv = 0. + irc = 0. + shc = 0. + irg = 0. + shg = 0. + evg = 0. + evc = 0. + tr = 0. + ghv = 0. + psnsun = 0. + psnsha = 0. + t2mv = 0. + q2v = 0. + chv = 0. + chleaf = 0. + chuc = 0. + chv2 = 0. + +! wind speed at reference height: ur >= 1 + + ur = max( sqrt(uu**2.+vv**2.), 1. ) + +! vegetated or non-vegetated + + vai = elai + esai + veg = .false. + if(vai > 0.) veg = .true. + +! ground snow cover fraction [niu and yang, 2007, jgr] + + fsno = 0. + if(snowh.gt.0.) then + bdsno = sneqv / snowh + fmelt = (bdsno/100.)**parameters%mfsno + fsno = tanh( snowh /(2.5* z0 * fmelt)) + endif + +! ground roughness length + + if(ist == 2) then + if(tg .le. tfrz) then + z0mg = 0.01 * (1.0-fsno) + fsno * parameters%z0sno + else + z0mg = 0.01 + end if + else + z0mg = z0 * (1.0-fsno) + fsno * parameters%z0sno + end if + +! roughness length and displacement height + + zpdg = snowh + if(veg) then + z0m = parameters%z0mvt + zpd = 0.65 * parameters%hvt + if(snowh.gt.zpd) zpd = snowh + else + z0m = z0mg + zpd = zpdg + end if + + zlvl = max(zpd,parameters%hvt) + zref + if(zpdg >= zlvl) zlvl = zpdg + zref +! ur = ur*log(zlvl/z0m)/log(10./z0m) !input ur is at 10m + +! canopy wind absorption coeffcient + + cwp = parameters%cwpvt + +! thermal properties of soil, snow, lake, and frozen soil + + call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + smc ,sh2o ,tg ,stc ,ur , & !in + lat ,z0m ,zlvl ,vegtyp , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out + +! solar radiation: absorbed & reflected by the ground and canopy + + call radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in + sneqvo ,sneqv ,dt ,cosz ,snowh , & !in + tg ,tv ,fsno ,qsnow ,fwet , & !in + elai ,esai ,smc ,solad ,solai , & !in + fveg ,iloc ,jloc , & !in + albold ,tauss , & !inout + fsun ,laisun ,laisha ,parsun ,parsha , & !out + sav ,sag ,fsr ,fsa ,fsrv , & + fsrg ,bgap ,wgap ) !out + +! vegetation and ground emissivity + + emv = 1. - exp(-(elai+esai)/1.0) + if (ice == 1) then + emg = 0.98*(1.-fsno) + 1.0*fsno + else + emg = parameters%eg(ist)*(1.-fsno) + 1.0*fsno + end if + +! soil moisture factor controlling stomatal resistance + + btran = 0. + + if(ist ==1 ) then + do iz = 1, parameters%nroot + if(opt_btr == 1) then ! noah + gx = (sh2o(iz)-parameters%smcwlt) / (parameters%smcref-parameters%smcwlt) + end if + if(opt_btr == 2) then ! clm + psi = max(psiwlt,-parameters%psisat*(max(0.01,sh2o(iz))/parameters%smcmax)**(-parameters%bexp) ) + gx = (1.-psi/psiwlt)/(1.+parameters%psisat/psiwlt) + end if + if(opt_btr == 3) then ! ssib + psi = max(psiwlt,-parameters%psisat*(max(0.01,sh2o(iz))/parameters%smcmax)**(-parameters%bexp) ) + gx = 1.-exp(-5.8*(log(psiwlt/psi))) + end if + + gx = min(1.,max(0.,gx)) + btrani(iz) = max(mpe,dzsnso(iz) / (-zsoil(parameters%nroot)) * gx) + btran = btran + btrani(iz) + end do + btran = max(mpe,btran) + + btrani(1:parameters%nroot) = btrani(1:parameters%nroot)/btran + end if + +! soil surface resistance for ground evap. + + bevap = max(0.0,sh2o(1)/parameters%smcmax) + if(ist == 2) then + rsurf = 1. ! avoid being divided by 0 + rhsur = 1.0 + else + + ! rsurf based on sakaguchi and zeng, 2009 + ! taking the "residual water content" to be the wilting point, + ! and correcting the exponent on the d term (typo in sz09 ?) + l_rsurf = (-zsoil(1)) * ( exp ( (1.0 - min(1.0,sh2o(1)/parameters%smcmax)) ** 5 ) - 1.0 ) / ( 2.71828 - 1.0 ) + d_rsurf = 2.2e-5 * parameters%smcmax * parameters%smcmax * ( 1.0 - parameters%smcwlt / parameters%smcmax ) ** (2.0+3.0/parameters%bexp) + rsurf = l_rsurf / d_rsurf + + ! older rsurf computations: + ! rsurf = fsno * 1. + (1.-fsno)* exp(8.25-4.225*bevap) !sellers (1992) + ! rsurf = fsno * 1. + (1.-fsno)* exp(8.25-6.0 *bevap) !adjusted to decrease rsurf for wet soil + + if(sh2o(1) < 0.01 .and. snowh == 0.) rsurf = 1.e6 + psi = -parameters%psisat*(max(0.01,sh2o(1))/parameters%smcmax)**(-parameters%bexp) + rhsur = fsno + (1.-fsno) * exp(psi*grav/(rw*tg)) + end if + +! urban - jref + if (parameters%urban_flag .and. snowh == 0. ) then + rsurf = 1.e6 + endif + +! set psychrometric constant + + if (tv .gt. tfrz) then ! barlage: add distinction between ground and + latheav = hvap ! vegetation in v3.6 + frozen_canopy = .false. + else + latheav = hsub + frozen_canopy = .true. + end if + gammav = cpair*sfcprs/(0.622*latheav) + + if (tg .gt. tfrz) then + latheag = hvap + frozen_ground = .false. + else + latheag = hsub + frozen_ground = .true. + end if + gammag = cpair*sfcprs/(0.622*latheag) + +! if (sfctmp .gt. tfrz) then +! lathea = hvap +! else +! lathea = hsub +! end if +! gamma = cpair*sfcprs/(0.622*lathea) + +! surface temperatures of the ground and canopy and energy fluxes + + if (veg .and. fveg > 0) then + tgv = tg + cmv = cm + chv = ch +! YRQ +! write(*,*) 'cm,ch,tv,tgv, YRQ', cm,ch,tv,tgv + call vege_flux (parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in + dt ,sav ,sag ,lwdn ,ur , & !in + uu ,vv ,sfctmp ,thair ,qair , & !in + eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + zlvl ,zpd ,z0m ,fveg , & !in + z0mg ,emv ,emg ,canliq ,fsno, & !in + canice ,stc ,df ,rssun ,rssha , & !in + rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in + foln ,co2air ,o2air ,btran ,sfcprs , & !in + rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in + eah ,tah ,tv ,tgv ,cmv , & !inout + chv ,dx ,dz8w , & !inout + tauxv ,tauyv ,irg ,irc ,shg , & !out + shc ,evg ,evc ,tr ,ghv , & !out + t2mv ,psnsun ,psnsha , & !out +!jref:start + qc ,qsfc ,psfc , & !in + q2v ,chv2, chleaf, chuc) !inout +!jref:end + end if + + tgb = tg + cmb = cm + chb = ch + call bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in + lwdn ,ur ,uu ,vv ,sfctmp , & !in + thair ,qair ,eair ,rhoair ,snowh , & !in + dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in + emg ,stc ,df ,rsurf ,latheag , & !in + gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in + tgb ,cmb ,chb , & !inout + tauxb ,tauyb ,irb ,shb ,evb , & !out + ghb ,t2mb ,dx ,dz8w ,vegtyp , & !out +!jref:start + qc ,qsfc ,psfc , & !in + sfcprs ,q2b, chb2) !in +!jref:end + +!energy balance at vege canopy: sav =(irc+shc+evc+tr) *fveg at fveg +!energy balance at vege ground: sag* fveg =(irg+shg+evg+ghv) *fveg at fveg +!energy balance at bare ground: sag*(1.-fveg)=(irb+shb+evb+ghb)*(1.-fveg) at 1-fveg + + if (veg .and. fveg > 0) then + taux = fveg * tauxv + (1.0 - fveg) * tauxb + tauy = fveg * tauyv + (1.0 - fveg) * tauyb + fira = fveg * irg + (1.0 - fveg) * irb + irc + fsh = fveg * shg + (1.0 - fveg) * shb + shc + fgev = fveg * evg + (1.0 - fveg) * evb + ssoil = fveg * ghv + (1.0 - fveg) * ghb + fcev = evc + fctr = tr + pah = fveg * pahg + (1.0 - fveg) * pahb + pahv + tg = fveg * tgv + (1.0 - fveg) * tgb + t2m = fveg * t2mv + (1.0 - fveg) * t2mb + ts = fveg * tv + (1.0 - fveg) * tgb + cm = fveg * cmv + (1.0 - fveg) * cmb ! better way to average? + ch = fveg * chv + (1.0 - fveg) * chb + q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc + q2e = fveg * q2v + (1.0 - fveg) * q2b + z0wrf = z0m + else + taux = tauxb + tauy = tauyb + fira = irb + fsh = shb + fgev = evb + ssoil = ghb + tg = tgb + t2m = t2mb + fcev = 0. + fctr = 0. + pah = pahb + ts = tg + cm = cmb + ch = chb + q1 = qsfc + q2e = q2b + rssun = 0.0 + rssha = 0.0 + tgv = tgb + chv = chb + z0wrf = z0mg + end if + + fire = lwdn + fira + + if(fire <=0.) then + write(6,*) 'emitted longwave <0; skin t may be wrong due to inconsistent' + write(6,*) 'input of shdfac with lai' + write(6,*) iloc, jloc, 'shdfac=',fveg,'vai=',vai,'tv=',tv,'tg=',tg + write(6,*) 'lwdn=',lwdn,'fira=',fira,'snowh=',snowh + call wrf_error_fatal("stop in noah-mp") + end if + + ! compute a net emissivity + emissi = fveg * ( emg*(1-emv) + emv + emv*(1-emv)*(1-emg) ) + & + (1-fveg) * emg + + ! when we're computing a trad, subtract from the emitted ir the + ! reflected portion of the incoming lwdn, so we're just + ! considering the ir originating in the canopy/ground system. + + trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25 + + ! old trad calculation not taking into account emissivity: + ! trad = (fire/sb)**0.25 + + apar = parsun*laisun + parsha*laisha + psn = psnsun*laisun + psnsha*laisha + +! 3l snow & 4l soil temperatures + + call tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in + tbot ,zsnso ,ssoil ,df ,hcpct , & !in + sag ,dt ,snowh ,dzsnso , & !in + tg ,iloc ,jloc , & !in + stc ) !inout + +! adjusting snow surface temperature + if(opt_stc == 2) then + if (snowh > 0.05 .and. tg > tfrz) then + tgv = tfrz + tgb = tfrz + if (veg .and. fveg > 0) then + tg = fveg * tgv + (1.0 - fveg) * tgb + ts = fveg * tv + (1.0 - fveg) * tgb + else + tg = tgb + ts = tgb + end if + end if + end if + +! energy released or consumed by snow & frozen soil + + call phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso ,hcpct ,ist ,iloc ,jloc , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out + + + end subroutine energy + +!== begin thermoprop =============================================================================== + + subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + smc ,sh2o ,tg ,stc ,ur , & !in + lat ,z0m ,zlvl ,vegtyp , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out +! ------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: isnow !actual no. of snow layers + integer , intent(in) :: ist !surface type + real , intent(in) :: dt !time step [s] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers [m] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension( 1:nsoil), intent(in) :: sh2o !liquid soil moisture [m3/m3] + real , intent(in) :: snowh !snow height [m] + real, intent(in) :: tg !surface temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil/lake temp. (k) + real, intent(in) :: ur !wind speed at zlvl (m/s) + real, intent(in) :: lat !latitude (radians) + real, intent(in) :: z0m !roughness length (m) + real, intent(in) :: zlvl !reference height (m) + integer , intent(in) :: vegtyp !vegtyp type + +! outputs + real, dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(out) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(out) :: fact !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) + real, dimension( 1:nsoil) :: sice !soil ice content +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + call csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out + + do iz = isnow+1, 0 + df (iz) = tksno(iz) + hcpct(iz) = cvsno(iz) + end do + +! compute soil thermal properties + + do iz = 1, nsoil + sice(iz) = smc(iz) - sh2o(iz) + hcpct(iz) = sh2o(iz)*cwat + (1.0-parameters%smcmax)*parameters%csoil & + + (parameters%smcmax-smc(iz))*cpair + sice(iz)*cice + call tdfcnd (parameters,df(iz), smc(iz), sh2o(iz)) + end do + + if ( parameters%urban_flag ) then + do iz = 1,nsoil + df(iz) = 3.24 + end do + endif + +! heat flux reduction effect from the overlying green canopy, adapted from +! section 2.1.2 of peters-lidard et al. (1997, jgr, vol 102(d4)). +! not in use because of the separation of the canopy layer from the ground. +! but this may represent the effects of leaf litter (niu comments) +! df1 = df1 * exp (sbeta * shdfac) + +! compute lake thermal properties +! (no consideration of turbulent mixing for this version) + + if(ist == 2) then + do iz = 1, nsoil + if(stc(iz) > tfrz) then + hcpct(iz) = cwat + df(iz) = tkwat !+ keddy * cwat + else + hcpct(iz) = cice + df(iz) = tkice + end if + end do + end if + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + do iz = isnow+1,nsoil + fact(iz) = dt/(hcpct(iz)*dzsnso(iz)) + end do + +! snow/soil interface + + if(isnow == 0) then + df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1)) + else + df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1)) + end if + + + end subroutine thermoprop + +!== begin csnow ==================================================================================== + + subroutine csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out +! -------------------------------------------------------------------------------------------------- +! snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + implicit none +!--------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: isnow !number of snow layers (-) + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! outputs + + real, dimension(-nsnow+1: 0), intent(out) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0), intent(out) :: tksno !thermal conductivity (w/m/k) + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + do iz = isnow+1, 0 + snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) ) + epore(iz) = 1. - snicev(iz) + snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o)) + enddo + + do iz = isnow+1, 0 + bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz) + cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz) +! cvsno(iz) = 0.525e06 ! constant + enddo + +! thermal conductivity of snow + + do iz = isnow+1, 0 + tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 +! tksno(iz) = 0.35 ! constant +! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) +! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) + enddo + + end subroutine csnow + +!== begin tdfcnd =================================================================================== + + subroutine tdfcnd (parameters, df, smc, sh2o) +! -------------------------------------------------------------------------------------------------- +! calculate thermal diffusivity and conductivity of the soil. +! peters-lidard approach (peters-lidard et al., 1998) +! -------------------------------------------------------------------------------------------------- +! code history: +! june 2001 changes: frozen soil condition. +! -------------------------------------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: smc ! total soil water + real, intent(in) :: sh2o ! liq. soil water + real, intent(out) :: df ! thermal diffusivity + +! local variables + real :: ake + real :: gammd + real :: thkdry + real :: thko ! thermal conductivity for other soil components + real :: thkqtz ! thermal conductivity for quartz + real :: thksat ! + real :: thks ! thermal conductivity for the solids + real :: thkw ! water thermal conductivity + real :: satratio + real :: xu + real :: xunfroz +! -------------------------------------------------------------------------------------------------- +! we now get quartz as an input argument (set in routine redprm): +! data quartz /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! -------------------------------------------------------------------------------------------------- +! if the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils +! -------------------------------------------------------------------------------------------------- +! quartz ....quartz content (soil type dependent) +! -------------------------------------------------------------------------------------------------- +! use as in peters-lidard, 1998 (modif. from johansen, 1975). + +! pablo grunmann, 08/17/98 +! refs.: +! farouki, o.t.,1986: thermal properties of soils. series on rock +! and soil mechanics, vol. 11, trans tech, 136 pp. +! johansen, o., 1975: thermal conductivity of soils. ph.d. thesis, +! university of trondheim, +! peters-lidard, c. d., et al., 1998: the effect of soil thermal +! conductivity parameterization on surface energy fluxes +! and temperatures. journal of the atmospheric sciences, +! vol. 55, pp. 1209-1224. +! -------------------------------------------------------------------------------------------------- +! needs parameters +! porosity(soil type): +! poros = smcmax +! saturation ratio: +! parameters w/(m.k) + satratio = smc / parameters%smcmax + thkw = 0.57 +! if (quartz .le. 0.2) thko = 3.0 + thko = 2.0 +! solids' conductivity +! quartz' conductivity + thkqtz = 7.7 + +! unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen)) + thks = (thkqtz ** parameters%quartz)* (thko ** (1. - parameters%quartz)) + +! unfrozen volume for saturation (porosity*xunfroz) + xunfroz = sh2o / smc +! saturated thermal conductivity + xu = xunfroz * parameters%smcmax + +! dry density in kg/m3 + thksat = thks ** (1. - parameters%smcmax)* tkice ** (parameters%smcmax - xu)* thkw ** & + (xu) + +! dry thermal conductivity in w.m-1.k-1 + gammd = (1. - parameters%smcmax)*2700. + + thkdry = (0.135* gammd+ 64.7)/ (2700. - 0.947* gammd) +! frozen + if ( (sh2o + 0.0005) < smc ) then + ake = satratio +! unfrozen +! range of validity for the kersten number (ake) + else + +! kersten number (using "fine" formula, valid for soils containing at +! least 5% of particles with diameter less than 2.e-6 meters.) +! (for "coarse" formula, see peters-lidard et al., 1998). + + if ( satratio > 0.1 ) then + + ake = log10 (satratio) + 1.0 + +! use k = kdry + else + + ake = 0.0 + end if +! thermal conductivity + + end if + + df = ake * (thksat - thkdry) + thkdry + + + end subroutine tdfcnd + +!== begin radiation ================================================================================ + + subroutine radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in + sneqvo ,sneqv ,dt ,cosz ,snowh , & !in + tg ,tv ,fsno ,qsnow ,fwet , & !in + elai ,esai ,smc ,solad ,solai , & !in + fveg ,iloc ,jloc , & !in + albold ,tauss , & !inout + fsun ,laisun ,laisha ,parsun ,parsha , & !out + sav ,sag ,fsr ,fsa ,fsrv , & + fsrg ,bgap ,wgap) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: ist !surface type + integer, intent(in) :: ice !ice (ice = 1) + integer, intent(in) :: nsoil !number of soil layers + + real, intent(in) :: dt !time step [s] + real, intent(in) :: qsnow !snowfall (mm/s) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: snowh !snow height (mm) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: elai !lai, one-sided, adjusted for burying by snow + real, intent(in) :: esai !sai, one-sided, adjusted for burying by snow + real, intent(in) :: fwet !fraction of canopy that is wet + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water [m3/m3] + real, dimension(1:2) , intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2) , intent(in) :: solai !incoming diffuse solar radiation (w/m2) + real, intent(in) :: fsno !snow cover fraction (-) + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age. + +! output + real, intent(out) :: fsun !sunlit fraction of canopy (-) + real, intent(out) :: laisun !sunlit leaf area (-) + real, intent(out) :: laisha !shaded leaf area (-) + real, intent(out) :: parsun !average absorbed par for sunlit leaves (w/m2) + real, intent(out) :: parsha !average absorbed par for shaded leaves (w/m2) + real, intent(out) :: sav !solar radiation absorbed by vegetation (w/m2) + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + +!jref:start + real, intent(out) :: fsrv !veg. reflected solar radiation (w/m2) + real, intent(out) :: fsrg !ground reflected solar radiation (w/m2) + real, intent(out) :: bgap + real, intent(out) :: wgap +!jref:end + +! local + real :: fage !snow age function (0 - new snow) + real, dimension(1:2) :: albgrd !ground albedo (direct) + real, dimension(1:2) :: albgri !ground albedo (diffuse) + real, dimension(1:2) :: albd !surface albedo (direct) + real, dimension(1:2) :: albi !surface albedo (diffuse) + real, dimension(1:2) :: fabd !flux abs by veg (per unit direct flux) + real, dimension(1:2) :: fabi !flux abs by veg (per unit diffuse flux) + real, dimension(1:2) :: ftdd !down direct flux below veg (per unit dir flux) + real, dimension(1:2) :: ftid !down diffuse flux below veg (per unit dir flux) + real, dimension(1:2) :: ftii !down diffuse flux below veg (per unit dif flux) +!jref:start + real, dimension(1:2) :: frevi + real, dimension(1:2) :: frevd + real, dimension(1:2) :: fregi + real, dimension(1:2) :: fregd +!jref:end + + real :: fsha !shaded fraction of canopy + real :: vai !total lai + stem area index, one sided + + real,parameter :: mpe = 1.e-6 + logical veg !true: vegetated for surface temperature calculation + +! -------------------------------------------------------------------------------------------------- + +! surface abeldo + + call albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in + dt ,cosz ,fage ,elai ,esai , & !in + tg ,tv ,snowh ,fsno ,fwet , & !in + smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in + iloc ,jloc , & !in + albold ,tauss , & !inout + albgrd ,albgri ,albd ,albi ,fabd , & !out + fabi ,ftdd ,ftid ,ftii ,fsun , & !) !out + frevi ,frevd ,fregd ,fregi ,bgap , & !inout + wgap) + +! surface radiation + + fsha = 1.-fsun + laisun = elai*fsun + laisha = elai*fsha + vai = elai+ esai + if (vai .gt. 0.) then + veg = .true. + else + veg = .false. + end if + + call surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in + laisun ,laisha ,solad ,solai ,fabd , & !in + fabi ,ftdd ,ftid ,ftii ,albgrd , & !in + albgri ,albd ,albi ,iloc ,jloc , & !in + parsun ,parsha ,sav ,sag ,fsa , & !out + fsr , & !out + frevi ,frevd ,fregd ,fregi ,fsrv , & !inout + fsrg) + + end subroutine radiation + +!== begin albedo =================================================================================== + + subroutine albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in + dt ,cosz ,fage ,elai ,esai , & !in + tg ,tv ,snowh ,fsno ,fwet , & !in + smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in + iloc ,jloc , & !in + albold ,tauss , & !inout + albgrd ,albgri ,albd ,albi ,fabd , & !out + fabi ,ftdd ,ftid ,ftii ,fsun , & !out + frevi ,frevd ,fregd ,fregi ,bgap , & !out + wgap) + +! -------------------------------------------------------------------------------------------------- +! surface albedos. also fluxes (per unit incoming direct and diffuse +! radiation) reflected, transmitted, and absorbed by vegetation. +! also sunlit fraction of the canopy. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: ist !surface type + integer, intent(in) :: ice !ice (ice = 1) + + real, intent(in) :: dt !time step [sec] + real, intent(in) :: qsnow !snowfall + real, intent(in) :: cosz !cosine solar zenith angle for next time step + real, intent(in) :: snowh !snow height (mm) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: elai !lai, one-sided, adjusted for burying by snow + real, intent(in) :: esai !sai, one-sided, adjusted for burying by snow + real, intent(in) :: fsno !fraction of grid covered by snow + real, intent(in) :: fwet !fraction of canopy that is wet + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water (m3/m3) + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age + +! output + real, dimension(1: 2), intent(out) :: albgrd !ground albedo (direct) + real, dimension(1: 2), intent(out) :: albgri !ground albedo (diffuse) + real, dimension(1: 2), intent(out) :: albd !surface albedo (direct) + real, dimension(1: 2), intent(out) :: albi !surface albedo (diffuse) + real, dimension(1: 2), intent(out) :: fabd !flux abs by veg (per unit direct flux) + real, dimension(1: 2), intent(out) :: fabi !flux abs by veg (per unit diffuse flux) + real, dimension(1: 2), intent(out) :: ftdd !down direct flux below veg (per unit dir flux) + real, dimension(1: 2), intent(out) :: ftid !down diffuse flux below veg (per unit dir flux) + real, dimension(1: 2), intent(out) :: ftii !down diffuse flux below veg (per unit dif flux) + real, intent(out) :: fsun !sunlit fraction of canopy (-) +!jref:start + real, dimension(1: 2), intent(out) :: frevd + real, dimension(1: 2), intent(out) :: frevi + real, dimension(1: 2), intent(out) :: fregd + real, dimension(1: 2), intent(out) :: fregi + real, intent(out) :: bgap + real, intent(out) :: wgap +!jref:end + +! ------------------------------------------------------------------------ +! ------------------------ local variables ------------------------------- +! local + real :: fage !snow age function + real :: alb + integer :: ib !indices + integer :: nband !number of solar radiation wave bands + integer :: ic !direct beam: ic=0; diffuse: ic=1 + + real :: wl !fraction of lai+sai that is lai + real :: ws !fraction of lai+sai that is sai + real :: mpe !prevents overflow for division by zero + + real, dimension(1:2) :: rho !leaf/stem reflectance weighted by fraction lai and sai + real, dimension(1:2) :: tau !leaf/stem transmittance weighted by fraction lai and sai + real, dimension(1:2) :: ftdi !down direct flux below veg per unit dif flux = 0 + real, dimension(1:2) :: albsnd !snow albedo (direct) + real, dimension(1:2) :: albsni !snow albedo (diffuse) + + real :: vai !elai+esai + real :: gdir !average projected leaf/stem area in solar direction + real :: ext !optical depth direct beam per unit leaf + stem area + +! -------------------------------------------------------------------------------------------------- + + nband = 2 + mpe = 1.e-06 + bgap = 0. + wgap = 0. + +! initialize output because solar radiation only done if cosz > 0 + + do ib = 1, nband + albd(ib) = 0. + albi(ib) = 0. + albgrd(ib) = 0. + albgri(ib) = 0. + fabd(ib) = 0. + fabi(ib) = 0. + ftdd(ib) = 0. + ftid(ib) = 0. + ftii(ib) = 0. + if (ib.eq.1) fsun = 0. + end do + + if(cosz <= 0) goto 100 + +! weight reflectance/transmittance by lai and sai + + do ib = 1, nband + vai = elai + esai + wl = elai / max(vai,mpe) + ws = esai / max(vai,mpe) + rho(ib) = max(parameters%rhol(ib)*wl+parameters%rhos(ib)*ws, mpe) + tau(ib) = max(parameters%taul(ib)*wl+parameters%taus(ib)*ws, mpe) + end do + +! snow age + + call snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage) + +! snow albedos: only if cosz > 0 and fsno > 0 + + if(opt_alb == 1) & + call snowalb_bats (parameters,nband, fsno,cosz,fage,albsnd,albsni) + if(opt_alb == 2) then + call snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc) + albold = alb + end if + +! ground surface albedo + + call groundalb (parameters,nsoil ,nband ,ice ,ist , & !in + fsno ,smc ,albsnd ,albsni ,cosz , & !in + tg ,iloc ,jloc , & !in + albgrd ,albgri ) !out + +! loop over nband wavebands to calculate surface albedos and solar +! fluxes for unit incoming direct (ic=0) and diffuse flux (ic=1) + + do ib = 1, nband + ic = 0 ! direct + call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,tv ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fabd ,albd ,ftdd ,ftid ,gdir , &!) !out + frevd ,fregd ,bgap ,wgap) + + ic = 1 ! diffuse + call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,tv ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fabi ,albi ,ftdi ,ftii ,gdir , & !) !out + frevi ,fregi ,bgap ,wgap) + + end do + +! sunlit fraction of canopy. set fsun = 0 if fsun < 0.01. + + ext = gdir/cosz * sqrt(1.-rho(1)-tau(1)) + fsun = (1.-exp(-ext*vai)) / max(ext*vai,mpe) + ext = fsun + + if (ext .lt. 0.01) then + wl = 0. + else + wl = ext + end if + fsun = wl + +100 continue + + end subroutine albedo + +!== begin surrad =================================================================================== + + subroutine surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in + laisun ,laisha ,solad ,solai ,fabd , & !in + fabi ,ftdd ,ftid ,ftii ,albgrd , & !in + albgri ,albd ,albi ,iloc ,jloc , & !in + parsun ,parsha ,sav ,sag ,fsa , & !out + fsr , & !) !out + frevi ,frevd ,fregd ,fregi ,fsrv , & + fsrg) !inout + +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + real, intent(in) :: mpe !prevents underflow errors if division by zero + + real, intent(in) :: fsun !sunlit fraction of canopy + real, intent(in) :: fsha !shaded fraction of canopy + real, intent(in) :: elai !leaf area, one-sided + real, intent(in) :: vai !leaf + stem area, one-sided + real, intent(in) :: laisun !sunlit leaf area index, one-sided + real, intent(in) :: laisha !shaded leaf area index, one-sided + + real, dimension(1:2), intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2), intent(in) :: solai !incoming diffuse solar radiation (w/m2) + real, dimension(1:2), intent(in) :: fabd !flux abs by veg (per unit incoming direct flux) + real, dimension(1:2), intent(in) :: fabi !flux abs by veg (per unit incoming diffuse flux) + real, dimension(1:2), intent(in) :: ftdd !down dir flux below veg (per incoming dir flux) + real, dimension(1:2), intent(in) :: ftid !down dif flux below veg (per incoming dir flux) + real, dimension(1:2), intent(in) :: ftii !down dif flux below veg (per incoming dif flux) + real, dimension(1:2), intent(in) :: albgrd !ground albedo (direct) + real, dimension(1:2), intent(in) :: albgri !ground albedo (diffuse) + real, dimension(1:2), intent(in) :: albd !overall surface albedo (direct) + real, dimension(1:2), intent(in) :: albi !overall surface albedo (diffuse) + + real, dimension(1:2), intent(in) :: frevd !overall surface albedo veg (direct) + real, dimension(1:2), intent(in) :: frevi !overall surface albedo veg (diffuse) + real, dimension(1:2), intent(in) :: fregd !overall surface albedo grd (direct) + real, dimension(1:2), intent(in) :: fregi !overall surface albedo grd (diffuse) + +! output + + real, intent(out) :: parsun !average absorbed par for sunlit leaves (w/m2) + real, intent(out) :: parsha !average absorbed par for shaded leaves (w/m2) + real, intent(out) :: sav !solar radiation absorbed by vegetation (w/m2) + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + real, intent(out) :: fsrv !reflected solar radiation by vegetation + real, intent(out) :: fsrg !reflected solar radiation by ground + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband number (1=vis, 2=nir) + integer :: nband !number of solar radiation waveband classes + + real :: abs !absorbed solar radiation (w/m2) + real :: rnir !reflected solar radiation [nir] (w/m2) + real :: rvis !reflected solar radiation [vis] (w/m2) + real :: laifra !leaf area fraction of canopy + real :: trd !transmitted solar radiation: direct (w/m2) + real :: tri !transmitted solar radiation: diffuse (w/m2) + real, dimension(1:2) :: cad !direct beam absorbed by canopy (w/m2) + real, dimension(1:2) :: cai !diffuse radiation absorbed by canopy (w/m2) +! --------------------------------------------------------------------------------------------- + nband = 2 + +! zero summed solar fluxes + + sag = 0. + sav = 0. + fsa = 0. + +! loop over nband wavebands + + do ib = 1, nband + +! absorbed by canopy + + cad(ib) = solad(ib)*fabd(ib) + cai(ib) = solai(ib)*fabi(ib) + sav = sav + cad(ib) + cai(ib) + fsa = fsa + cad(ib) + cai(ib) + +! transmitted solar fluxes incident on ground + + trd = solad(ib)*ftdd(ib) + tri = solad(ib)*ftid(ib) + solai(ib)*ftii(ib) + +! solar radiation absorbed by ground surface + + abs = trd*(1.-albgrd(ib)) + tri*(1.-albgri(ib)) + sag = sag + abs + fsa = fsa + abs + end do + +! partition visible canopy absorption to sunlit and shaded fractions +! to get average absorbed par for sunlit and shaded leaves + + laifra = elai / max(vai,mpe) + if (fsun .gt. 0.) then + parsun = (cad(1)+fsun*cai(1)) * laifra / max(laisun,mpe) + parsha = (fsha*cai(1))*laifra / max(laisha,mpe) + else + parsun = 0. + parsha = (cad(1)+cai(1))*laifra /max(laisha,mpe) + endif + +! reflected solar radiation + + rvis = albd(1)*solad(1) + albi(1)*solai(1) + rnir = albd(2)*solad(2) + albi(2)*solai(2) + fsr = rvis + rnir + +! reflected solar radiation of veg. and ground (combined ground) + fsrv = frevd(1)*solad(1)+frevi(1)*solai(1)+frevd(2)*solad(2)+frevi(2)*solai(2) + fsrg = fregd(1)*solad(1)+fregi(1)*solai(1)+fregd(2)*solad(2)+fregi(2)*solai(2) + + + end subroutine surrad + +!== begin snow_age ================================================================================= + + subroutine snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage) +! ---------------------------------------------------------------------- + implicit none +! ------------------------ code history ------------------------------------------------------------ +! from bats +! ------------------------ input/output variables -------------------------------------------------- +!input + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: dt !main time step (s) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow water per unit ground area (mm) + +!output + real, intent(out) :: fage !snow age + +!input/output + real, intent(inout) :: tauss !non-dimensional snow age +!local + real :: tage !total aging effects + real :: age1 !effects of grain growth due to vapor diffusion + real :: age2 !effects of grain growth at freezing of melt water + real :: age3 !effects of soot + real :: dela !temporary variable + real :: sge !temporary variable + real :: dels !temporary variable + real :: dela0 !temporary variable + real :: arg !temporary variable +! see yang et al. (1997) j.of climate for detail. +!--------------------------------------------------------------------------------------------------- + + if(sneqv.le.0.0) then + tauss = 0. + else if (sneqv.gt.800.) then + tauss = 0. + else + dela0 = 1.e-6*dt + arg = 5.e3*(1./tfrz-1./tg) + age1 = exp(arg) + age2 = exp(amin1(0.,10.*arg)) + age3 = 0.3 + tage = age1+age2+age3 + dela = dela0*tage + dels = amax1(0.0,sneqv-sneqvo) / parameters%swemx + sge = (tauss+dela)*(1.0-dels) + tauss = amax1(0.,sge) + endif + + fage= tauss/(tauss+1.) + + end subroutine snow_age + +!== begin snowalb_bats ============================================================================= + + subroutine snowalb_bats (parameters,nband,fsno,cosz,fage,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: cosz !cosine solar zenith angle + real,intent(in) :: fsno !snow cover fraction (-) + real,intent(in) :: fage !snow age correction + +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband class + + real :: fzen !zenith angle correction + real :: cf1 !temperary variable + real :: sl2 !2.*sl + real :: sl1 !1/sl + real :: sl !adjustable parameter + real, parameter :: c1 = 0.2 !default in bats + real, parameter :: c2 = 0.5 !default in bats +! real, parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's +! real, parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + sl=2.0 + sl1=1./sl + sl2=2.*sl + cf1=((1.+sl1)/(1.+sl2*cosz)-sl1) + fzen=amax1(cf1,0.) + + albsni(1)=0.95*(1.-c1*fage) + albsni(2)=0.65*(1.-c2*fage) + + albsnd(1)=albsni(1)+0.4*fzen*(1.-albsni(1)) ! vis direct + albsnd(2)=albsni(2)+0.4*fzen*(1.-albsni(2)) ! nir direct + + end subroutine snowalb_bats + +!== begin snowalb_class ============================================================================ + + subroutine snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc) +! ---------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: qsnow !snowfall (mm/s) + real,intent(in) :: dt !time step (sec) + real,intent(in) :: albold !snow albedo at last time step + +! in & out + + real, intent(inout) :: alb ! +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband class + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.) + +! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + if (qsnow > 0.) then + alb = alb + min(qsnow,parameters%swemx/dt) * (0.84-alb)/(parameters%swemx/dt) + endif + + albsni(1)= alb ! vis diffuse + albsni(2)= alb ! nir diffuse + albsnd(1)= alb ! vis direct + albsnd(2)= alb ! nir direct + + end subroutine snowalb_class + +!== begin groundalb ================================================================================ + + subroutine groundalb (parameters,nsoil ,nband ,ice ,ist , & !in + fsno ,smc ,albsnd ,albsni ,cosz , & !in + tg ,iloc ,jloc , & !in + albgrd ,albgri ) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: nband !number of solar radiation waveband classes + integer, intent(in) :: ice !value of ist for land ice + integer, intent(in) :: ist !surface type + real, intent(in) :: fsno !fraction of surface covered with snow (-) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water content (m3/m3) + real, dimension(1: 2), intent(in) :: albsnd !direct beam snow albedo (vis, nir) + real, dimension(1: 2), intent(in) :: albsni !diffuse snow albedo (vis, nir) + +!output + + real, dimension(1: 2), intent(out) :: albgrd !ground albedo (direct beam: vis, nir) + real, dimension(1: 2), intent(out) :: albgri !ground albedo (diffuse: vis, nir) + +!local + + integer :: ib !waveband number (1=vis, 2=nir) + real :: inc !soil water correction factor for soil albedo + real :: albsod !soil albedo (direct) + real :: albsoi !soil albedo (diffuse) +! -------------------------------------------------------------------------------------------------- + + do ib = 1, nband + inc = max(0.11-0.40*smc(1), 0.) + if (ist .eq. 1) then !soil + albsod = min(parameters%albsat(ib)+inc,parameters%albdry(ib)) + albsoi = albsod + else if (tg .gt. tfrz) then !unfrozen lake, wetland + albsod = 0.06/(max(0.01,cosz)**1.7 + 0.15) + albsoi = 0.06 + else !frozen lake, wetland + albsod = parameters%alblak(ib) + albsoi = albsod + end if + +! increase desert and semi-desert albedos + +! if (ist .eq. 1 .and. isc .eq. 9) then +! albsod = albsod + 0.10 +! albsoi = albsoi + 0.10 +! end if + + albgrd(ib) = albsod*(1.-fsno) + albsnd(ib)*fsno + albgri(ib) = albsoi*(1.-fsno) + albsni(ib)*fsno + end do + + end subroutine groundalb + +!== begin twostream ================================================================================ + + subroutine twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,t ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fab ,fre ,ftd ,fti ,gdir , & !) !out + frev ,freg ,bgap ,wgap) + +! -------------------------------------------------------------------------------------------------- +! use two-stream approximation of dickinson (1983) adv geophysics +! 25:305-353 and sellers (1985) int j remote sensing 6:1335-1372 +! to calculate fluxes absorbed by vegetation, reflected by vegetation, +! and transmitted through vegetation for unit incoming direct or diffuse +! flux given an underlying surface with known albedo. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: ist !surface type + integer, intent(in) :: ib !waveband number + integer, intent(in) :: ic !0=unit incoming direct; 1=unit incoming diffuse + integer, intent(in) :: vegtyp !vegetation type + + real, intent(in) :: cosz !cosine of direct zenith angle (0-1) + real, intent(in) :: vai !one-sided leaf+stem area index (m2/m2) + real, intent(in) :: fwet !fraction of lai, sai that is wetted (-) + real, intent(in) :: t !surface temperature (k) + + real, dimension(1:2), intent(in) :: albgrd !direct albedo of underlying surface (-) + real, dimension(1:2), intent(in) :: albgri !diffuse albedo of underlying surface (-) + real, dimension(1:2), intent(in) :: rho !leaf+stem reflectance + real, dimension(1:2), intent(in) :: tau !leaf+stem transmittance + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + +! output + + real, dimension(1:2), intent(out) :: fab !flux abs by veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: fre !flux refl above veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: ftd !down dir flux below veg layer (per unit in flux) + real, dimension(1:2), intent(out) :: fti !down dif flux below veg layer (per unit in flux) + real, intent(out) :: gdir !projected leaf+stem area in solar direction + real, dimension(1:2), intent(out) :: frev !flux reflected by veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: freg !flux reflected by ground (per unit incoming flux) + +! local + real :: omega !fraction of intercepted radiation that is scattered + real :: omegal !omega for leaves + real :: betai !upscatter parameter for diffuse radiation + real :: betail !betai for leaves + real :: betad !upscatter parameter for direct beam radiation + real :: betadl !betad for leaves + real :: ext !optical depth of direct beam per unit leaf area + real :: avmu !average diffuse optical depth + + real :: coszi !0.001 <= cosz <= 1.000 + real :: asu !single scattering albedo + real :: chil ! -0.4 <= xl <= 0.6 + + real :: tmp0,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9 + real :: p1,p2,p3,p4,s1,s2,u1,u2,u3 + real :: b,c,d,d1,d2,f,h,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10 + real :: phi1,phi2,sigma + real :: ftds,ftis,fres + real :: denfveg + real :: vai_spread +!jref:start + real :: freveg,frebar,ftdveg,ftiveg,ftdbar,ftibar + real :: thetaz +!jref:end + +! variables for the modified two-stream scheme +! niu and yang (2004), jgr + + real, parameter :: pai = 3.14159265 + real :: hd !crown depth (m) + real :: bb !vertical crown radius (m) + real :: thetap !angle conversion from sza + real :: fa !foliage volume density (m-1) + real :: newvai !effective lsai (-) + + real,intent(inout) :: bgap !between canopy gap fraction for beam (-) + real,intent(inout) :: wgap !within canopy gap fraction for beam (-) + + real :: kopen !gap fraction for diffue light (-) + real :: gap !total gap fraction for beam ( <=1-shafac ) + +! ----------------------------------------------------------------- +! compute within and between gaps + vai_spread = vai + if(vai == 0.0) then + gap = 1.0 + kopen = 1.0 + else + if(opt_rad == 1) then + denfveg = -log(max(1.0-fveg,0.01))/(pai*parameters%rc**2) + hd = parameters%hvt - parameters%hvb + bb = 0.5 * hd + thetap = atan(bb/parameters%rc * tan(acos(max(0.01,cosz))) ) + ! bgap = exp(-parameters%den * pai * parameters%rc**2/cos(thetap) ) + bgap = exp(-denfveg * pai * parameters%rc**2/cos(thetap) ) + fa = vai/(1.33 * pai * parameters%rc**3.0 *(bb/parameters%rc)*denfveg) + newvai = hd*fa + wgap = (1.0-bgap) * exp(-0.5*newvai/cosz) + gap = min(1.0-fveg, bgap+wgap) + + kopen = 0.05 + end if + + if(opt_rad == 2) then + gap = 0.0 + kopen = 0.0 + end if + + if(opt_rad == 3) then + gap = 1.0-fveg + kopen = 1.0-fveg + end if + end if + +! calculate two-stream parameters omega, betad, betai, avmu, gdir, ext. +! omega, betad, betai are adjusted for snow. values for omega*betad +! and omega*betai are calculated and then divided by the new omega +! because the product omega*betai, omega*betad is used in solution. +! also, the transmittances and reflectances (tau, rho) are linear +! weights of leaf and stem values. + + coszi = max(0.001, cosz) + chil = min( max(parameters%xl, -0.4), 0.6) + if (abs(chil) .le. 0.01) chil = 0.01 + phi1 = 0.5 - 0.633*chil - 0.330*chil*chil + phi2 = 0.877 * (1.-2.*phi1) + gdir = phi1 + phi2*coszi + ext = gdir/coszi + avmu = ( 1. - phi1/phi2 * log((phi1+phi2)/phi1) ) / phi2 + omegal = rho(ib) + tau(ib) + tmp0 = gdir + phi2*coszi + tmp1 = phi1*coszi + asu = 0.5*omegal*gdir/tmp0 * ( 1.-tmp1/tmp0*log((tmp1+tmp0)/tmp1) ) + betadl = (1.+avmu*ext)/(omegal*avmu*ext)*asu + betail = 0.5 * ( rho(ib)+tau(ib) + (rho(ib)-tau(ib)) & + * ((1.+chil)/2.)**2 ) / omegal + +! adjust omega, betad, and betai for intercepted snow + + if (t .gt. tfrz) then !no snow + tmp0 = omegal + tmp1 = betadl + tmp2 = betail + else + tmp0 = (1.-fwet)*omegal + fwet*parameters%omegas(ib) + tmp1 = ( (1.-fwet)*omegal*betadl + fwet*parameters%omegas(ib)*parameters%betads ) / tmp0 + tmp2 = ( (1.-fwet)*omegal*betail + fwet*parameters%omegas(ib)*parameters%betais ) / tmp0 + end if + + omega = tmp0 + betad = tmp1 + betai = tmp2 + +! absorbed, reflected, transmitted fluxes per unit incoming radiation + + b = 1. - omega + omega*betai + c = omega*betai + tmp0 = avmu*ext + d = tmp0 * omega*betad + f = tmp0 * omega*(1.-betad) + tmp1 = b*b - c*c + h = sqrt(tmp1) / avmu + sigma = tmp0*tmp0 - tmp1 + if ( abs (sigma) < 1.e-6 ) sigma = sign(1.e-6,sigma) + p1 = b + avmu*h + p2 = b - avmu*h + p3 = b + tmp0 + p4 = b - tmp0 + s1 = exp(-h*vai) + s2 = exp(-ext*vai) + if (ic .eq. 0) then + u1 = b - c/albgrd(ib) + u2 = b - c*albgrd(ib) + u3 = f + c*albgrd(ib) + else + u1 = b - c/albgri(ib) + u2 = b - c*albgri(ib) + u3 = f + c*albgri(ib) + end if + tmp2 = u1 - avmu*h + tmp3 = u1 + avmu*h + d1 = p1*tmp2/s1 - p2*tmp3*s1 + tmp4 = u2 + avmu*h + tmp5 = u2 - avmu*h + d2 = tmp4/s1 - tmp5*s1 + h1 = -d*p4 - c*f + tmp6 = d - h1*p3/sigma + tmp7 = ( d - c - h1/sigma*(u1+tmp0) ) * s2 + h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1 + h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1 + h4 = -f*p3 - c*d + tmp8 = h4/sigma + tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2 + h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2 + h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2 + h7 = (c*tmp2) / (d1*s1) + h8 = (-c*tmp3*s1) / d1 + h9 = tmp4 / (d2*s1) + h10 = (-tmp5*s1) / d2 + +! downward direct and diffuse fluxes below vegetation +! niu and yang (2004), jgr. + + if (ic .eq. 0) then + ftds = s2 *(1.0-gap) + gap + ftis = (h4*s2/sigma + h5*s1 + h6/s1)*(1.0-gap) + else + ftds = 0. + ftis = (h9*s1 + h10/s1)*(1.0-kopen) + kopen + end if + ftd(ib) = ftds + fti(ib) = ftis + +! flux reflected by the surface (veg. and ground) + + if (ic .eq. 0) then + fres = (h1/sigma + h2 + h3)*(1.0-gap ) + albgrd(ib)*gap + freveg = (h1/sigma + h2 + h3)*(1.0-gap ) + frebar = albgrd(ib)*gap !jref - separate veg. and ground reflection + else + fres = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen + freveg = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen + frebar = 0 !jref - separate veg. and ground reflection + end if + fre(ib) = fres + + frev(ib) = freveg + freg(ib) = frebar + +! flux absorbed by vegetation + + fab(ib) = 1. - fre(ib) - (1.-albgrd(ib))*ftd(ib) & + - (1.-albgri(ib))*fti(ib) + +!if(iloc == 1.and.jloc == 2) then +! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," gap: ",gap," ftd: ",ftd(ib)," fti: ",fti(ib)," fre: ", & +! fre(ib)," fab: ",fab(ib)," albgrd: ",albgrd(ib)," albgri: ",albgri(ib) +!end if + + end subroutine twostream + +!== begin vege_flux ================================================================================ + + subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in + dt ,sav ,sag ,lwdn ,ur , & !in + uu ,vv ,sfctmp ,thair ,qair , & !in + eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + zlvl ,zpd ,z0m ,fveg , & !in + z0mg ,emv ,emg ,canliq ,fsno, & !in + canice ,stc ,df ,rssun ,rssha , & !in + rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in + foln ,co2air ,o2air ,btran ,sfcprs , & !in + rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in + eah ,tah ,tv ,tg ,cm , & !inout + ch ,dx ,dz8w , & ! + tauxv ,tauyv ,irg ,irc ,shg , & !out + shc ,evg ,evc ,tr ,gh , & !out + t2mv ,psnsun ,psnsha , & !out + qc ,qsfc ,psfc , & !in + q2v ,cah2 ,chleaf ,chuc ) !inout + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve for vegetation (tv) and +! ground (tg) temperatures that balance the surface energy budgets + +! vegetated: +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] = 0 +! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + logical, intent(in) :: veg !true if vegetated surface + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: isnow !actual no. of snow layers + integer, intent(in) :: vegtyp !vegetation physiology type + real, intent(in) :: fveg !greeness vegetation fraction (-) + real, intent(in) :: sav !solar rad absorbed by veg (w/m2) + real, intent(in) :: sag !solar rad absorbed by ground (w/m2) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: uu !wind speed in eastward dir (m/s) + real, intent(in) :: vv !wind speed in northward dir (m/s) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: thair !potential temp at reference height (k) + real, intent(in) :: eair !vapor pressure air at zlvl (pa) + real, intent(in) :: qair !specific humidity at zlvl (kg/kg) + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: dt !time step (s) + real, intent(in) :: fsno !snow fraction + + real, intent(in) :: snowh !actual snow depth [m] + real, intent(in) :: fwet !wetted fraction of canopy + real, intent(in) :: cwp !canopy wind parameter + + real, intent(in) :: vai !total leaf area index + stem area index + real, intent(in) :: laisun !sunlit leaf area index, one-sided (m2/m2) + real, intent(in) :: laisha !shaded leaf area index, one-sided (m2/m2) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0m !roughness length, momentum (m) + real, intent(in) :: z0mg !roughness length, momentum, ground (m) + real, intent(in) :: emv !vegetation emissivity + real, intent(in) :: emg !ground emissivity + + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thinkness of snow/soil layers (m) + real, intent(in) :: canliq !intercepted liquid water (mm) + real, intent(in) :: canice !intercepted ice mass (mm) + real, intent(in) :: rsurf !ground surface resistance (s/m) +! real, intent(in) :: gamma !psychrometric constant (pa/k) +! real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gammav !psychrometric constant (pa/k) + real, intent(in) :: latheav !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gammag !psychrometric constant (pa/k) + real, intent(in) :: latheag !latent heat of vaporization/subli (j/kg) + real, intent(in) :: parsun !par absorbed per unit sunlit lai (w/m2) + real, intent(in) :: parsha !par absorbed per unit shaded lai (w/m2) + real, intent(in) :: foln !foliage nitrogen (%) + real, intent(in) :: co2air !atmospheric co2 concentration (pa) + real, intent(in) :: o2air !atmospheric o2 concentration (pa) + real, intent(in) :: igs !growing season index (0=off, 1=on) + real, intent(in) :: sfcprs !pressure (pa) + real, intent(in) :: btran !soil water transpiration factor (0 to 1) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + + real , intent(in) :: qc !cloud water mixing ratio + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dx !grid spacing + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real, intent(in) :: pahv !precipitation advected heat - canopy net in (w/m2) + real, intent(in) :: pahg !precipitation advected heat - ground net in (w/m2) + +! input/output + real, intent(inout) :: eah !canopy air vapor pressure (pa) + real, intent(inout) :: tah !canopy air temperature (k) + real, intent(inout) :: tv !vegetation temperature (k) + real, intent(inout) :: tg !ground temperature (k) + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + +! output +! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 + real, intent(out) :: tauxv !wind stress: e-w (n/m2) + real, intent(out) :: tauyv !wind stress: n-s (n/m2) + real, intent(out) :: irc !net longwave radiation (w/m2) [+= to atm] + real, intent(out) :: shc !sensible heat flux (w/m2) [+= to atm] + real, intent(out) :: evc !evaporation heat flux (w/m2) [+= to atm] + real, intent(out) :: irg !net longwave radiation (w/m2) [+= to atm] + real, intent(out) :: shg !sensible heat flux (w/m2) [+= to atm] + real, intent(out) :: evg !evaporation heat flux (w/m2) [+= to atm] + real, intent(out) :: tr !transpiration heat flux (w/m2)[+= to atm] + real, intent(out) :: gh !ground heat (w/m2) [+ = to soil] + real, intent(out) :: t2mv !2 m height air temperature (k) + real, intent(out) :: psnsun !sunlit leaf photosynthesis (umolco2/m2/s) + real, intent(out) :: psnsha !shaded leaf photosynthesis (umolco2/m2/s) + real, intent(out) :: chleaf !leaf exchange coefficient + real, intent(out) :: chuc !under canopy exchange coefficient + + real, intent(out) :: q2v + real :: cah !sensible heat conductance, canopy air to zlvl air (m/s) + real :: u10v !10 m wind speed in eastward dir (m/s) + real :: v10v !10 m wind speed in eastward dir (m/s) + real :: wspd + +! ------------------------ local variables ---------------------------------------------------- + real :: cw !water vapor exchange coefficient + real :: fv !friction velocity (m/s) + real :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) + real :: z0h !roughness length, sensible heat (m) + real :: z0hg !roughness length, sensible heat (m) + real :: rb !bulk leaf boundary layer resistance (s/m) + real :: ramc !aerodynamic resistance for momentum (s/m) + real :: rahc !aerodynamic resistance for sensible heat (s/m) + real :: rawc !aerodynamic resistance for water vapor (s/m) + real :: ramg !aerodynamic resistance for momentum (s/m) + real :: rahg !aerodynamic resistance for sensible heat (s/m) + real :: rawg !aerodynamic resistance for water vapor (s/m) + + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) + + real :: mol !monin-obukhov length (m) + real :: dtv !change in tv, last iteration (k) + real :: dtg !change in tg, last iteration (k) + + real :: air,cir !coefficients for ir as function of ts**4 + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cgh !coefficients for st as function of ts + real :: atr,ctr !coefficients for tr as function of esat[ts] + real :: ata,bta !coefficients for tah as function of ts + real :: aea,bea !coefficients for eah as function of esat[ts] + + real :: estv !saturation vapor pressure at tv (pa) + real :: estg !saturation vapor pressure at tg (pa) + real :: destv !d(es)/dt at ts (pa/k) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + real :: fhg !sen heat stability correction, ground + real :: hcan !canopy height (m) [note: hcan >= z0mg] + + real :: a !temporary calculation + real :: b !temporary calculation + real :: cvh !sensible heat conductance, leaf surface to canopy air (m/s) + real :: caw !latent heat conductance, canopy air zlvl air (m/s) + real :: ctw !transpiration conductance, leaf to canopy air (m/s) + real :: cew !evaporation conductance, leaf to canopy air (m/s) + real :: cgw !latent heat conductance, ground to canopy air (m/s) + real :: cond !sum of conductances (s/m) + real :: uc !wind speed at top of canopy (m/s) + real :: kh !turbulent transfer coefficient, sensible heat, (m2/s) + real :: h !temporary sensible heat flux (w/m2) + real :: hg !temporary sensible heat flux (w/m2) + real :: moz !monin-obukhov stability parameter + real :: mozg !monin-obukhov stability parameter + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + real :: thstar !surface exchange at 2m + + real :: thvair + real :: thah + real :: rahc2 !aerodynamic resistance for sensible heat (s/m) + real :: rawc2 !aerodynamic resistance for water vapor (s/m) + real, intent(out):: cah2 !sensible heat conductance for diagnostics + real :: ch2v !exchange coefficient for 2m over vegetation. + real :: cq2v !exchange coefficient for 2m over vegetation. + real :: eah2 !2m vapor pressure over canopy + real :: qfx !moisture flux + real :: e1 + + + real :: vaie !total leaf area index + stem area index,effective + real :: laisune !sunlit leaf area index, one-sided (m2/m2),effective + real :: laishae !shaded leaf area index, one-sided (m2/m2),effective + + integer :: k !index + integer :: iter !iteration index + +!jref - niterc test from 5 to 20 + integer, parameter :: niterc = 20 !number of iterations for surface temperature +!jref - niterg test from 3-5 + integer, parameter :: niterg = 5 !number of iterations for ground temperature + integer :: mozsgn !number of times moz changes sign + real :: mpe !prevents overflow error if division by zero + + integer :: liter !last iteration + + + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + + character(len=80) :: message + + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) +! --------------------------------------------------------------------------------------------- + + mpe = 1e-6 + liter = 0 + fv = 0.1 + +! --------------------------------------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! --------------------------------------------------------------------------------------------- + dtv = 0. + dtg = 0. + moz = 0. + mozsgn = 0 + mozold = 0. + hg = 0. + h = 0. + qfx = 0. + +! YRQ +! write(*,*) 'tv,tg,stc in input:YRQ', tv,tg,stc + +! convert grid-cell lai to the fractional vegetated area (fveg) + + vaie = min(6.,vai / fveg) + laisune = min(6.,laisun / fveg) + laishae = min(6.,laisha / fveg) + +! saturation vapor pressure at ground temperature + + t = tdc(tg) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + +!jref - consistent surface specific humidity for sfcdif3 and sfcdif4 + + qsfc = 0.622*eair/(psfc-0.378*eair) + +! canopy height + + hcan = parameters%hvt + uc = ur*log(hcan/z0m)/log(zlvl/z0m) + uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 + if((hcan-zpd) <= 0.) then + write(message,*) "critical problem: hcan <= zpd" + call wrf_message ( message ) + write(message,*) 'i,j point=',iloc, jloc + call wrf_message ( message ) + write(message,*) 'hcan =',hcan + call wrf_message ( message ) + write(message,*) 'zpd =',zpd + call wrf_message ( message ) + write (message, *) 'snowh =',snowh + call wrf_message ( message ) + call wrf_error_fatal ( "critical problem in module_sf_noahmplsm:vegeflux" ) + end if + +! prepare for longwave rad. + + air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 + cir = (2.-emv*(1.-emg))*emv*sb +! --------------------------------------------------------------------------------------------- + loop1: do iter = 1, niterc ! begin stability iteration + + if(iter == 1) then + z0h = z0m + z0hg = z0mg + else + z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m)) + z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg)) + end if + +! aerodyn resistances between heights zlvl and d+z0v + + if(opt_sfc == 1) then + call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + zlvl ,zpd ,z0m ,z0h ,ur , & !in + mpe ,iloc ,jloc , & !in + moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + cm ,ch ,fv ,ch2 ) !out + endif + + if(opt_sfc == 2) then + call sfcdif2(parameters,iter ,z0m ,tah ,thair ,ur , & !in + zlvl ,iloc ,jloc , & !in + cm ,ch ,moz ,wstar , & !in + fv ) !out + ! undo the multiplication by windspeed that sfcdif2 + ! applies to exchange coefficients ch and cm: + ch = ch / ur + cm = cm / ur + endif + + ramc = max(1.,1./(cm*ur)) + rahc = max(1.,1./(ch*ur)) + rawc = rahc + +! aerodyn resistance between heights z0g and d+z0v, rag, and leaf +! boundary layer resistance, rb + + call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in + zpd ,z0mg ,z0hg ,hcan ,uc , & !in + z0h ,fv ,cwp ,vegtyp ,mpe , & !in + tv ,mozg ,fhg ,iloc ,jloc , & !inout + ramg ,rahg ,rawg ,rb ) !out + +! es and d(es)/dt evaluated at tv + + t = tdc(tv) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estv = esatw + destv = dsatw + else + estv = esati + destv = dsati + end if + +! stomatal resistance + + if(iter == 1) then + if (opt_crs == 1) then ! ball-berry + call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in + tv ,estv ,eah ,sfctmp,sfcprs, & !in + o2air ,co2air,igs ,btran ,rb , & !in + rssun ,psnsun) !out + + call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in + tv ,estv ,eah ,sfctmp,sfcprs, & !in + o2air ,co2air,igs ,btran ,rb , & !in + rssha ,psnsha) !out + end if + + if (opt_crs == 2) then ! jarvis + call canres (parameters,parsun,tv ,btran ,eah ,sfcprs, & !in + rssun ,psnsun,iloc ,jloc ) !out + + call canres (parameters,parsha,tv ,btran ,eah ,sfcprs, & !in + rssha ,psnsha,iloc ,jloc ) !out + end if + end if + +! prepare for sensible heat flux above veg. + + cah = 1./rahc + cvh = 2.*vaie/rb + cgh = 1./rahg + cond = cah + cvh + cgh + ata = (sfctmp*cah + tg*cgh) / cond + bta = cvh/cond + csh = (1.-bta)*rhoair*cpair*cvh + +! prepare for latent heat flux above veg. + + caw = 1./rawc + cew = fwet*vaie/rb + ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) + cgw = 1./(rawg+rsurf) + cond = caw + cew + ctw + cgw + aea = (eair*caw + estg*cgw) / cond + bea = (cew+ctw)/cond + cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 + ctr = (1.-bea)*ctw*rhoair*cpair/gammav + +! evaluate surface fluxes with current temperature and solve for dts + + tah = ata + bta*tv ! canopy air t. + eah = aea + bea*estv ! canopy air e + + irc = fveg*(air + cir*tv**4) + shc = fveg*rhoair*cpair*cvh * ( tv-tah) + evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 + tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav + if (tv > tfrz) then + evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 + else + evc = min(canice*latheav/dt,evc) + end if + + b = sav-irc-shc-evc-tr+pahv !additional w/m2 + a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity + dtv = b/a + + irc = irc + fveg*4.*cir*tv**3*dtv + shc = shc + fveg*csh*dtv + evc = evc + fveg*cev*destv*dtv + tr = tr + fveg*ctr*destv*dtv + +! update vegetation surface temperature + tv = tv + dtv +! tah = ata + bta*tv ! canopy air t; update here for consistency + +! for computing m-o length in the next iteration + h = rhoair*cpair*(tah - sfctmp) /rahc + hg = rhoair*cpair*(tg - tah) /rahg + +! consistent specific humidity from canopy air vapor pressure + qsfc = (0.622*eah)/(sfcprs-0.378*eah) + + if (liter == 1) then + exit loop1 + endif + if (iter >= 5 .and. abs(dtv) <= 0.01 .and. liter == 0) then + liter = 1 + endif + + end do loop1 ! end stability iteration + +! under-canopy fluxes and tg + + air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 + cir = emg*sb + csh = rhoair*cpair/rahg + cev = rhoair*cpair / (gammag*(rawg+rsurf)) ! barlage: change to ground v3.6 + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) +! write(*,*)'inside tg=',tg,'stc(1)=',stc(1) + + loop2: do iter = 1, niterg + + t = tdc(tg) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + irg = cir*tg**4 + air + shg = csh * (tg - tah ) + evg = cev * (estg*rhsur - eah ) + gh = cgh * (tg - stc(isnow+1)) + + b = sag-irg-shg-evg-gh+pahg + a = 4.*cir*tg**3+csh+cev*destg+cgh + dtg = b/a + + irg = irg + 4.*cir*tg**3*dtg + shg = shg + csh*dtg + evg = evg + cev*destg*dtg + gh = gh + cgh*dtg + tg = tg + dtg + + end do loop2 + +! tah = (cah*sfctmp + cvh*tv + cgh*tg)/(cah + cvh + cgh) + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + if(opt_stc == 1 .or. opt_stc == 3) then + if (snowh > 0.05 .and. tg > tfrz) then + tg = tfrz + if(opt_stc == 3) tg = (1.-fsno)*tg + fsno*tfrz ! mb: allow tg>0c during melt v3.7 + irg = cir*tg**4 - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 + shg = csh * (tg - tah) + evg = cev * (estg*rhsur - eah) + gh = sag+pahg - (irg+shg+evg) + end if + end if + +! wind stresses + + tauxv = -rhoair*cm*ur*uu + tauyv = -rhoair*cm*ur*vv + +! consistent vegetation air temperature and vapor pressure since tg is not consistent with the tah/eah +! calculation. +! tah = sfctmp + (shg+shc)/(rhoair*cpair*cah) +! tah = sfctmp + (shg*fveg+shc)/(rhoair*cpair*cah) ! ground flux need fveg +! eah = eair + (evc+fveg*(tr+evg))/(rhoair*caw*cpair/gammag ) +! qfx = (qsfc-qair)*rhoair*caw !*cpair/gammag + +! 2m temperature over vegetation ( corrected for low cq2v values ) + if (opt_sfc == 1 .or. opt_sfc == 2) then +! cah2 = fv*1./vkc*log((2.+z0h)/z0h) + cah2 = fv*vkc/log((2.+z0h)/z0h) + cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2v = cah2 + if (cah2 .lt. 1.e-5 ) then + t2mv = tah +! q2v = (eah*0.622/(sfcprs - 0.378*eah)) + q2v = qsfc + else + t2mv = tah - (shg+shc/fveg)/(rhoair*cpair) * 1./cah2 +! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) + q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v + endif + endif + +! update ch for output + ch = cah + chleaf = cvh + chuc = 1./rahg + + end subroutine vege_flux + +!== begin bare_flux ================================================================================ + + subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in + lwdn ,ur ,uu ,vv ,sfctmp , & !in + thair ,qair ,eair ,rhoair ,snowh , & !in + dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in + emg ,stc ,df ,rsurf ,lathea , & !in + gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in + tgb ,cm ,ch , & !inout + tauxb ,tauyb ,irb ,shb ,evb , & !out + ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out + qc ,qsfc ,psfc , & !in + sfcprs ,q2b ,ehb2 ) !in + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for bare soil fraction. + +! bare soil: +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: isnow !actual no. of snow layers + real, intent(in) :: dt !time step (s) + real, intent(in) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: uu !wind speed in eastward dir (m/s) + real, intent(in) :: vv !wind speed in northward dir (m/s) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: thair !potential temperature at height zlvl (k) + real, intent(in) :: qair !specific humidity at height zlvl (kg/kg) + real, intent(in) :: eair !vapor pressure air at height (pa) + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: snowh !actual snow depth [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers (m) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: emg !ground emissivity + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, intent(in) :: rsurf !ground surface resistance (s/m) + real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gamma !psychrometric constant (pa/k) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + real, intent(in) :: fsno !snow fraction + +!jref:start; in + integer , intent(in) :: ivgtyp + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: sfcprs !pressure at lowest model layer + real , intent(in) :: dx !horisontal grid spacing + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: dz8w !thickness of lowest layer +!jref:end + real, intent(in) :: pahb !precipitation advected heat - ground net in (w/m2) + +! input/output + real, intent(inout) :: tgb !ground temperature (k) + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + +! output +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 + + real, intent(out) :: tauxb !wind stress: e-w (n/m2) + real, intent(out) :: tauyb !wind stress: n-s (n/m2) + real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] + real, intent(out) :: shb !sensible heat flux (w/m2) [+ to atm] + real, intent(out) :: evb !latent heat flux (w/m2) [+ to atm] + real, intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] + real, intent(out) :: t2mb !2 m height air temperature (k) +!jref:start + real, intent(out) :: q2b !bare ground heat conductance + real :: ehb !bare ground heat conductance + real :: u10b !10 m wind speed in eastward dir (m/s) + real :: v10b !10 m wind speed in eastward dir (m/s) + real :: wspd +!jref:end + +! local variables + + real :: taux !wind stress: e-w (n/m2) + real :: tauy !wind stress: n-s (n/m2) + real :: fira !total net longwave rad (w/m2) [+ to atm] + real :: fsh !total sensible heat flux (w/m2) [+ to atm] + real :: fgev !ground evaporation heat flux (w/m2)[+ to atm] + real :: ssoil !soil heat flux (w/m2) [+ to soil] + real :: fire !emitted ir (w/m2) + real :: trad !radiative temperature (k) + real :: tah !"surface" temperature at height z0h+zpd (k) + + real :: cw !water vapor exchange coefficient + real :: fv !friction velocity (m/s) + real :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) + real :: z0h !roughness length, sensible heat, ground (m) + real :: rb !bulk leaf boundary layer resistance (s/m) + real :: ramb !aerodynamic resistance for momentum (s/m) + real :: rahb !aerodynamic resistance for sensible heat (s/m) + real :: rawb !aerodynamic resistance for water vapor (s/m) + real :: mol !monin-obukhov length (m) + real :: dtg !change in tg, last iteration (k) + + real :: cir !coefficients for ir as function of ts**4 + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cgh !coefficients for st as function of ts + +!jref:start + real :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) + real :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) + real,intent(out) :: ehb2 !sensible heat conductance for diagnostics + real :: ch2b !exchange coefficient for 2m temp. + real :: cq2b !exchange coefficient for 2m temp. + real :: thvair !virtual potential air temp + real :: thgh !potential ground temp + real :: emb !momentum conductance + real :: qfx !moisture flux + real :: estg2 !saturation vapor pressure at 2m (pa) + integer :: vegtyp !vegetation type set to isbarren + real :: e1 +!jref:end + + real :: estg !saturation vapor pressure at tg (pa) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + + real :: a !temporary calculation + real :: b !temporary calculation + real :: h !temporary sensible heat flux (w/m2) + real :: moz !monin-obukhov stability parameter + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + integer :: mozsgn !number of times moz changes sign + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + + integer :: iter !iteration index + integer :: niterb !number of iterations for surface temperature + real :: mpe !prevents overflow error if division by zero +!jref:start +! data niterb /3/ + data niterb /5/ + save niterb + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + mpe = 1e-6 + dtg = 0. + moz = 0. + mozsgn = 0 + mozold = 0. + h = 0. + qfx = 0. + fv = 0.1 + + cir = emg*sb + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + +! ----------------------------------------------------------------- + loop3: do iter = 1, niterb ! begin stability iteration + + if(iter == 1) then + z0h = z0m + else + z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m)) + end if + + if(opt_sfc == 1) then + call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + zlvl ,zpd ,z0m ,z0h ,ur , & !in + mpe ,iloc ,jloc , & !in + moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + cm ,ch ,fv ,ch2 ) !out + endif + + if(opt_sfc == 2) then + call sfcdif2(parameters,iter ,z0m ,tgb ,thair ,ur , & !in + zlvl ,iloc ,jloc , & !in + cm ,ch ,moz ,wstar , & !in + fv ) !out + ! undo the multiplication by windspeed that sfcdif2 + ! applies to exchange coefficients ch and cm: + ch = ch / ur + cm = cm / ur + if(snowh > 0.) then + cm = min(0.01,cm) ! cm & ch are too large, causing + ch = min(0.01,ch) ! computational instability + end if + + endif + + ramb = max(1.,1./(cm*ur)) + rahb = max(1.,1./(ch*ur)) + rawb = rahb + +!jref - variables for diagnostics + emb = 1./ramb + ehb = 1./rahb + +! es and d(es)/dt evaluated at tg + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + csh = rhoair*cpair/rahb + cev = rhoair*cpair/gamma/(rsurf+rawb) + +! surface fluxes and dtg + + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp ) + evb = cev * (estg*rhsur - eair ) + ghb = cgh * (tgb - stc(isnow+1)) + + b = sag-irb-shb-evb-ghb+pahb + a = 4.*cir*tgb**3 + csh + cev*destg + cgh + dtg = b/a + + irb = irb + 4.*cir*tgb**3*dtg + shb = shb + csh*dtg + evb = evb + cev*destg*dtg + ghb = ghb + cgh*dtg + +! update ground surface temperature + tgb = tgb + dtg + +! for m-o length + h = csh * (tgb - sfctmp) + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + qsfc = 0.622*(estg*rhsur)/(psfc-0.378*(estg*rhsur)) + + qfx = (qsfc-qair)*cev*gamma/cpair + + end do loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + if(opt_stc == 1 .or. opt_stc == 3) then + if (snowh > 0.05 .and. tgb > tfrz) then + tgb = tfrz + if(opt_stc == 3) tgb = (1.-fsno)*tgb + fsno*tfrz ! mb: allow tg>0c during melt v3.7 + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp) + evb = cev * (estg*rhsur - eair ) !estg reevaluate ? + ghb = sag+pahb - (irb+shb+evb) + end if + end if + +! wind stresses + + tauxb = -rhoair*cm*ur*uu + tauyb = -rhoair*cm*ur*vv + +!jref:start; errors in original equation corrected. +! 2m air temperature + if(opt_sfc == 1 .or. opt_sfc ==2) then + ehb2 = fv*vkc/log((2.+z0h)/z0h) + ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2b = ehb2 + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + endif + if (parameters%urban_flag) q2b = qsfc + end if + +! update ch + ch = ehb + + end subroutine bare_flux + +!== begin ragrb ==================================================================================== + + subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in + zpd ,z0mg ,z0hg ,hcan ,uc , & !in + z0h ,fv ,cwp ,vegtyp ,mpe , & !in + tv ,mozg ,fhg ,iloc ,jloc , & !inout + ramg ,rahg ,rawg ,rb ) !out +! -------------------------------------------------------------------------------------------------- +! compute under-canopy aerodynamic resistance rag and leaf boundary layer +! resistance rb +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: iter !iteration index + integer, intent(in) :: vegtyp !vegetation physiology type + real, intent(in) :: vai !total lai + stem area index, one sided + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: hg !ground sensible heat flux (w/m2) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: tah !air temperature at height z0h+zpd (k) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0mg !roughness length, momentum, ground (m) + real, intent(in) :: hcan !canopy height (m) [note: hcan >= z0mg] + real, intent(in) :: uc !wind speed at top of canopy (m/s) + real, intent(in) :: z0h !roughness length, sensible heat (m) + real, intent(in) :: z0hg !roughness length, sensible heat, ground (m) + real, intent(in) :: fv !friction velocity (m/s) + real, intent(in) :: cwp !canopy wind parameter + real, intent(in) :: mpe !prevents overflow error if division by zero + +! in & out + + real, intent(inout) :: mozg !monin-obukhov stability parameter + real, intent(inout) :: fhg !stability correction + +! outputs + real :: ramg !aerodynamic resistance for momentum (s/m) + real :: rahg !aerodynamic resistance for sensible heat (s/m) + real :: rawg !aerodynamic resistance for water vapor (s/m) + real :: rb !bulk leaf boundary layer resistance (s/m) + + + real :: kh !turbulent transfer coefficient, sensible heat, (m2/s) + real :: tmp1 !temporary calculation + real :: tmp2 !temporary calculation + real :: tmprah2 !temporary calculation for aerodynamic resistances + real :: tmprb !temporary calculation for rb + real :: molg,fhgnew,cwpc +! -------------------------------------------------------------------------------------------------- +! stability correction to below canopy resistance + + mozg = 0. + molg = 0. + + if(iter > 1) then + tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + molg = -1. * fv**3 / tmp1 + mozg = min( (zpd-z0mg)/molg, 1.) + end if + + if (mozg < 0.) then + fhgnew = (1. - 15.*mozg)**(-0.25) + else + fhgnew = 1.+ 4.7*mozg + endif + + if (iter == 1) then + fhg = fhgnew + else + fhg = 0.5 * (fhg+fhgnew) + endif + + cwpc = (cwp * vai * hcan * fhg)**0.5 +! cwpc = (cwp*fhg)**0.5 + + tmp1 = exp( -cwpc*z0hg/hcan ) + tmp2 = exp( -cwpc*(z0h+zpd)/hcan ) + tmprah2 = hcan*exp(cwpc) / cwpc * (tmp1-tmp2) + +! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. + + kh = max ( vkc*fv*(hcan-zpd), mpe ) + ramg = 0. + rahg = tmprah2 / kh + rawg = rahg + +! leaf boundary layer resistance + + tmprb = cwpc*50. / (1. - exp(-cwpc/2.)) + rb = tmprb * sqrt(parameters%dleaf/uc) +! rb = 200 + + end subroutine ragrb + +!== begin sfcdif1 ================================================================================== + + subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + & zlvl ,zpd ,z0m ,z0h ,ur , & !in + & mpe ,iloc ,jloc , & !in + & moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + & cm ,ch ,fv ,ch2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: iter !iteration index + real, intent(in) :: sfctmp !temperature at reference height (k) + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: h !sensible heat flux (w/m2) [+ to atm] + real, intent(in) :: qair !specific humidity at reference height (kg/kg) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0h !roughness length, sensible heat, ground (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: ur !wind speed (m/s) + real, intent(in) :: mpe !prevents overflow error if division by zero +! in & out + + integer, intent(inout) :: mozsgn !number of times moz changes sign + real, intent(inout) :: moz !monin-obukhov stability (z/l) + real, intent(inout) :: fm !momentum stability correction, weighted by prior iters + real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters + +! outputs + + real, intent(out) :: cm !drag coefficient for momentum + real, intent(out) :: ch !drag coefficient for heat + real, intent(out) :: fv !friction velocity (m/s) + real, intent(out) :: ch2 !drag coefficient for heat + +! locals + real :: mol !monin-obukhov length (m) + real :: tmpcm !temporary calculation for cm + real :: tmpch !temporary calculation for ch + real :: fmnew !stability correction factor, momentum, for current moz + real :: fhnew !stability correction factor, sen heat, for current moz + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: tmp1,tmp2,tmp3,tmp4,tmp5 !temporary calculation + real :: tvir !temporary virtual temperature (k) + real :: moz2 !2/l + real :: tmpcm2 !temporary calculation for cm2 + real :: tmpch2 !temporary calculation for ch2 + real :: fm2new !stability correction factor, momentum, for current moz + real :: fh2new !stability correction factor, sen heat, for current moz + real :: tmp12,tmp22,tmp32 !temporary calculation + + real :: cmfm, chfh, cm2fm2, ch2fh2 +! ------------------------------------------------------------------------------------------------- +! monin-obukhov stability parameter moz for next iteration + + mozold = moz + + if(zlvl <= zpd) then + write(*,*) 'critical problem: zlvl <= zpd; model stops' + call wrf_error_fatal("stop in noah-mp") + endif + + tmpcm = log((zlvl-zpd) / z0m) + tmpch = log((zlvl-zpd) / z0h) + tmpcm2 = log((2.0 + z0m) / z0m) + tmpch2 = log((2.0 + z0h) / z0h) + + if(iter == 1) then + fv = 0.0 + moz = 0.0 + mol = 0.0 + moz2 = 0.0 + else + tvir = (1. + 0.61*qair) * sfctmp + tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + mol = -1. * fv**3 / tmp1 + moz = min( (zlvl-zpd)/mol, 1.) + moz2 = min( (2.0 + z0h)/mol, 1.) + endif + +! accumulate number of times moz changes sign. + + if (mozold*moz .lt. 0.) mozsgn = mozsgn+1 + if (mozsgn .ge. 2) then + moz = 0. + fm = 0. + fh = 0. + moz2 = 0. + fm2 = 0. + fh2 = 0. + endif + +! evaluate stability-dependent variables using moz from prior iteration + if (moz .lt. 0.) then + tmp1 = (1. - 16.*moz)**0.25 + tmp2 = log((1.+tmp1*tmp1)/2.) + tmp3 = log((1.+tmp1)/2.) + fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963 + fhnew = 2*tmp2 + +! 2-meter + tmp12 = (1. - 16.*moz2)**0.25 + tmp22 = log((1.+tmp12*tmp12)/2.) + tmp32 = log((1.+tmp12)/2.) + fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963 + fh2new = 2*tmp22 + else + fmnew = -5.*moz + fhnew = fmnew + fm2new = -5.*moz2 + fh2new = fm2new + endif + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + if (iter == 1) then + fm = fmnew + fh = fhnew + fm2 = fm2new + fh2 = fh2new + else + fm = 0.5 * (fm+fmnew) + fh = 0.5 * (fh+fhnew) + fm2 = 0.5 * (fm2+fm2new) + fh2 = 0.5 * (fh2+fh2new) + endif + +! exchange coefficients + + fh = min(fh,0.9*tmpch) + fm = min(fm,0.9*tmpcm) + fh2 = min(fh2,0.9*tmpch2) + fm2 = min(fm2,0.9*tmpcm2) + + cmfm = tmpcm-fm + chfh = tmpch-fh + cm2fm2 = tmpcm2-fm2 + ch2fh2 = tmpch2-fh2 + if(abs(cmfm) <= mpe) cmfm = mpe + if(abs(chfh) <= mpe) chfh = mpe + if(abs(cm2fm2) <= mpe) cm2fm2 = mpe + if(abs(ch2fh2) <= mpe) ch2fh2 = mpe + cm = vkc*vkc/(cmfm*cmfm) + ch = vkc*vkc/(cmfm*chfh) + ch2 = vkc*vkc/(cm2fm2*ch2fh2) + +! friction velocity + + fv = ur * sqrt(cm) + ch2 = vkc*fv/ch2fh2 + + end subroutine sfcdif1 + +!== begin sfcdif2 ================================================================================== + + subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in + zlm ,iloc ,jloc , & !in + akms ,akhs ,rlmo ,wstar2 , & !in + ustar ) !out + +! ------------------------------------------------------------------------------------------------- +! subroutine sfcdif (renamed sfcdif_off to avoid clash with eta pbl) +! ------------------------------------------------------------------------------------------------- +! calculate surface layer exchange coefficients via iterative process. +! see chen et al (1997, blm) +! ------------------------------------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: iter + real, intent(in) :: zlm, z0, thz0, thlm, sfcspd + real, intent(inout) :: akms + real, intent(inout) :: akhs + real, intent(inout) :: rlmo + real, intent(inout) :: wstar2 + real, intent(out) :: ustar + + real zz, pslmu, pslms, pslhu, pslhs + real xx, pspmu, yy, pspms, psphu, psphs + real zilfc, zu, zt, rdz, cxch + real dthv, du2, btgh, zslu, zslt, rlogu, rlogt + real zetalt, zetalu, zetau, zetat, xlu4, xlt4, xu4, xt4 + + real xlu, xlt, xu, xt, psmz, simm, pshz, simh, ustark, rlmn, & + & rlma + + integer ilech, itr + + integer, parameter :: itrmx = 5 + real, parameter :: wwst = 1.2 + real, parameter :: wwst2 = wwst * wwst + real, parameter :: vkrm = 0.40 + real, parameter :: excm = 0.001 + real, parameter :: beta = 1.0 / 270.0 + real, parameter :: btg = beta * grav + real, parameter :: elfc = vkrm * btg + real, parameter :: wold = 0.15 + real, parameter :: wnew = 1.0 - wold + real, parameter :: pihf = 3.14159265 / 2. + real, parameter :: epsu2 = 1.e-4 + real, parameter :: epsust = 0.07 + real, parameter :: epsit = 1.e-4 + real, parameter :: epsa = 1.e-8 + real, parameter :: ztmin = -5.0 + real, parameter :: ztmax = 1.0 + real, parameter :: hpbl = 1000.0 + real, parameter :: sqvisc = 258.2 + real, parameter :: ric = 0.183 + real, parameter :: rric = 1.0 / ric + real, parameter :: fhneu = 0.8 + real, parameter :: rfc = 0.191 + real, parameter :: rfac = ric / ( fhneu * rfc * rfc ) + +! ---------------------------------------------------------------------- +! note: the two code blocks below define functions +! ---------------------------------------------------------------------- +! lech's surface functions + pslmu (zz)= -0.96* log (1.0-4.5* zz) + pslms (zz)= zz * rric -2.076* (1. -1./ (zz +1.)) + pslhu (zz)= -0.96* log (1.0-4.5* zz) + pslhs (zz)= zz * rfac -2.076* (1. -1./ (zz +1.)) +! paulson's surface functions + pspmu (xx)= -2.* log ( (xx +1.)*0.5) - log ( (xx * xx +1.)*0.5) & + & +2.* atan (xx) & + &- pihf + pspms (yy)= 5.* yy + psphu (xx)= -2.* log ( (xx * xx +1.)*0.5) + psphs (yy)= 5.* yy + +! this routine sfcdif can handle both over open water (sea, ocean) and +! over solid surface (land, sea-ice). +! ---------------------------------------------------------------------- +! ztfc: ratio of zoh/zom less or equal than 1 +! c......ztfc=0.1 +! czil: constant c in zilitinkevich, s. s.1995,:note about zt +! ---------------------------------------------------------------------- + ilech = 0 + +! ---------------------------------------------------------------------- + zilfc = - parameters%czil * vkrm * sqvisc + zu = z0 + rdz = 1./ zlm + cxch = excm * rdz + dthv = thlm - thz0 + +! beljars correction of ustar + du2 = max (sfcspd * sfcspd,epsu2) + btgh = btg * hpbl + + if(iter == 1) then + if (btgh * akhs * dthv .ne. 0.0) then + wstar2 = wwst2* abs (btgh * akhs * dthv)** (2./3.) + else + wstar2 = 0.0 + end if + ustar = max (sqrt (akms * sqrt (du2+ wstar2)),epsust) + rlmo = elfc * akhs * dthv / ustar **3 + end if + +! zilitinkevitch approach for zt + zt = max(1.e-6,exp (zilfc * sqrt (ustar * z0))* z0) + zslu = zlm + zu + zslt = zlm + zt + rlogu = log (zslu / zu) + rlogt = log (zslt / zt) + +! ---------------------------------------------------------------------- +! 1./monin-obukkhov length-scale +! ---------------------------------------------------------------------- + zetalt = max (zslt * rlmo,ztmin) + rlmo = zetalt / zslt + zetalu = zslu * rlmo + zetau = zu * rlmo + zetat = zt * rlmo + + if (ilech .eq. 0) then + if (rlmo .lt. 0.)then + xlu4 = 1. -16.* zetalu + xlt4 = 1. -16.* zetalt + xu4 = 1. -16.* zetau + xt4 = 1. -16.* zetat + xlu = sqrt (sqrt (xlu4)) + xlt = sqrt (sqrt (xlt4)) + xu = sqrt (sqrt (xu4)) + + xt = sqrt (sqrt (xt4)) + psmz = pspmu (xu) + simm = pspmu (xlu) - psmz + rlogu + pshz = psphu (xt) + simh = psphu (xlt) - pshz + rlogt + else + zetalu = min (zetalu,ztmax) + zetalt = min (zetalt,ztmax) + psmz = pspms (zetau) + simm = pspms (zetalu) - psmz + rlogu + pshz = psphs (zetat) + simh = psphs (zetalt) - pshz + rlogt + end if +! ---------------------------------------------------------------------- +! lech's functions +! ---------------------------------------------------------------------- + else + if (rlmo .lt. 0.)then + psmz = pslmu (zetau) + simm = pslmu (zetalu) - psmz + rlogu + pshz = pslhu (zetat) + simh = pslhu (zetalt) - pshz + rlogt + else + zetalu = min (zetalu,ztmax) + zetalt = min (zetalt,ztmax) + psmz = pslms (zetau) + simm = pslms (zetalu) - psmz + rlogu + pshz = pslhs (zetat) + simh = pslhs (zetalt) - pshz + rlogt + end if +! ---------------------------------------------------------------------- + end if + +! ---------------------------------------------------------------------- +! beljaars correction for ustar +! ---------------------------------------------------------------------- + ustar = max (sqrt (akms * sqrt (du2+ wstar2)),epsust) + +! zilitinkevitch fix for zt + zt = max(1.e-6,exp (zilfc * sqrt (ustar * z0))* z0) + zslt = zlm + zt +!----------------------------------------------------------------------- + rlogt = log (zslt / zt) + ustark = ustar * vkrm + akms = max (ustark / simm,cxch) +!----------------------------------------------------------------------- +! if statements to avoid tangent linear problems near zero +!----------------------------------------------------------------------- + akhs = max (ustark / simh,cxch) + + if (btgh * akhs * dthv .ne. 0.0) then + wstar2 = wwst2* abs (btgh * akhs * dthv)** (2./3.) + else + wstar2 = 0.0 + end if +!----------------------------------------------------------------------- + rlmn = elfc * akhs * dthv / ustar **3 +!----------------------------------------------------------------------- +! if(abs((rlmn-rlmo)/rlma).lt.epsit) go to 110 +!----------------------------------------------------------------------- + rlma = rlmo * wold+ rlmn * wnew +!----------------------------------------------------------------------- + rlmo = rlma + +! write(*,'(a20,10f15.6)')'sfcdif: rlmo=',rlmo,rlmn,elfc , akhs , dthv , ustar +! end do +! ---------------------------------------------------------------------- + end subroutine sfcdif2 + +!== begin esat ===================================================================================== + + subroutine esat(t, esw, esi, desw, desi) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + implicit none +!--------------------------------------------------------------------------------------------------- +! in + + real, intent(in) :: t !temperature + +!out + + real, intent(out) :: esw !saturation vapor pressure over water (pa) + real, intent(out) :: esi !saturation vapor pressure over ice (pa) + real, intent(out) :: desw !d(esat)/dt over water (pa/k) + real, intent(out) :: desi !d(esat)/dt over ice (pa/k) + +! local + + real :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water + real :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice + real :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water + real :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice + + parameter (a0=6.107799961 , a1=4.436518521e-01, & + a2=1.428945805e-02, a3=2.650648471e-04, & + a4=3.031240396e-06, a5=2.034080948e-08, & + a6=6.136820929e-11) + + parameter (b0=6.109177956 , b1=5.034698970e-01, & + b2=1.886013408e-02, b3=4.176223716e-04, & + b4=5.824720280e-06, b5=4.838803174e-08, & + b6=1.838826904e-10) + + parameter (c0= 4.438099984e-01, c1=2.857002636e-02, & + c2= 7.938054040e-04, c3=1.215215065e-05, & + c4= 1.036561403e-07, c5=3.532421810e-10, & + c6=-7.090244804e-13) + + parameter (d0=5.030305237e-01, d1=3.773255020e-02, & + d2=1.267995369e-03, d3=2.477563108e-05, & + d4=3.005693132e-07, d5=2.158542548e-09, & + d6=7.131097725e-12) + + esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6)))))) + esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) + desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6)))))) + desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6)))))) + + end subroutine esat + +!== begin stomata ================================================================================== + + subroutine stomata (parameters,vegtyp ,mpe ,apar ,foln ,iloc , jloc, & !in + tv ,ei ,ea ,sfctmp ,sfcprs , & !in + o2 ,co2 ,igs ,btran ,rb , & !in + rs ,psn ) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation physiology type + + real, intent(in) :: igs !growing season index (0=off, 1=on) + real, intent(in) :: mpe !prevents division by zero errors + + real, intent(in) :: tv !foliage temperature (k) + real, intent(in) :: ei !vapor pressure inside leaf (sat vapor press at tv) (pa) + real, intent(in) :: ea !vapor pressure of canopy air (pa) + real, intent(in) :: apar !par absorbed per unit lai (w/m2) + real, intent(in) :: o2 !atmospheric o2 concentration (pa) + real, intent(in) :: co2 !atmospheric co2 concentration (pa) + real, intent(in) :: sfcprs !air pressure at reference height (pa) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: btran !soil water transpiration factor (0 to 1) + real, intent(in) :: foln !foliage nitrogen concentration (%) + real, intent(in) :: rb !boundary layer resistance (s/m) + +! output + real, intent(out) :: rs !leaf stomatal resistance (s/m) + real, intent(out) :: psn !foliage photosynthesis (umol co2 /m2/ s) [always +] + +! in&out + real :: rlb !boundary layer resistance (s m2 / umol) +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: iter !iteration index + integer :: niter !number of iterations + + data niter /3/ + save niter + + real :: ab !used in statement functions + real :: bc !used in statement functions + real :: f1 !generic temperature response (statement function) + real :: f2 !generic temperature inhibition (statement function) + real :: tc !foliage temperature (degree celsius) + real :: cs !co2 concentration at leaf surface (pa) + real :: kc !co2 michaelis-menten constant (pa) + real :: ko !o2 michaelis-menten constant (pa) + real :: a,b,c,q !intermediate calculations for rs + real :: r1,r2 !roots for rs + real :: fnf !foliage nitrogen adjustment factor (0 to 1) + real :: ppf !absorb photosynthetic photon flux (umol photons/m2/s) + real :: wc !rubisco limited photosynthesis (umol co2/m2/s) + real :: wj !light limited photosynthesis (umol co2/m2/s) + real :: we !export limited photosynthesis (umol co2/m2/s) + real :: cp !co2 compensation point (pa) + real :: ci !internal co2 (pa) + real :: awc !intermediate calculation for wc + real :: vcmx !maximum rate of carbonylation (umol co2/m2/s) + real :: j !electron transport (umol co2/m2/s) + real :: cea !constrain ea or else model blows up + real :: cf !s m2/umol -> s/m + + f1(ab,bc) = ab**((bc-25.)/10.) + f2(ab) = 1. + exp((-2.2e05+710.*(ab+273.16))/(8.314*(ab+273.16))) + real :: t +! --------------------------------------------------------------------------------------------- + +! initialize rs=rsmax and psn=0 because will only do calculations +! for apar > 0, in which case rs <= rsmax and psn >= 0 + + cf = sfcprs/(8.314*sfctmp)*1.e06 + rs = 1./parameters%bp * cf + psn = 0. + + if (apar .le. 0.) return + + fnf = min( foln/max(mpe,parameters%folnmx), 1.0 ) + tc = tv-tfrz + ppf = 4.6*apar + j = ppf*parameters%qe25 + kc = parameters%kc25 * f1(parameters%akc,tc) + ko = parameters%ko25 * f1(parameters%ako,tc) + awc = kc * (1.+o2/ko) + cp = 0.5*kc/ko*o2*0.21 + vcmx = parameters%vcmx25 / f2(tc) * fnf * btran * f1(parameters%avcmx,tc) + +! first guess ci + + ci = 0.7*co2*parameters%c3psn + 0.4*co2*(1.-parameters%c3psn) + +! rb: s/m -> s m**2 / umol + + rlb = rb/cf + +! constrain ea + + cea = max(0.25*ei*parameters%c3psn+0.40*ei*(1.-parameters%c3psn), min(ea,ei) ) + +! ci iteration +!jref: c3psn is equal to 1 for all veg types. + do iter = 1, niter + wj = max(ci-cp,0.)*j/(ci+2.*cp)*parameters%c3psn + j*(1.-parameters%c3psn) + wc = max(ci-cp,0.)*vcmx/(ci+awc)*parameters%c3psn + vcmx*(1.-parameters%c3psn) + we = 0.5*vcmx*parameters%c3psn + 4000.*vcmx*ci/sfcprs*(1.-parameters%c3psn) + psn = min(wj,wc,we) * igs + + cs = max( co2-1.37*rlb*sfcprs*psn, mpe ) + a = parameters%mp*psn*sfcprs*cea / (cs*ei) + parameters%bp + b = ( parameters%mp*psn*sfcprs/cs + parameters%bp ) * rlb - 1. + c = -rlb + if (b .ge. 0.) then + q = -0.5*( b + sqrt(b*b-4.*a*c) ) + else + q = -0.5*( b - sqrt(b*b-4.*a*c) ) + end if + r1 = q/a + r2 = c/q + rs = max(r1,r2) + ci = max( cs-psn*sfcprs*1.65*rs, 0. ) + end do + +! rs, rb: s m**2 / umol -> s/m + + rs = rs*cf + + end subroutine stomata + +!== begin canres =================================================================================== + + subroutine canres (parameters,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in + rc ,psn ,iloc ,jloc ) !out + +! -------------------------------------------------------------------------------------------------- +! calculate canopy resistance which depends on incoming solar radiation, +! air temperature, atmospheric water vapor pressure deficit at the +! lowest model level, and soil moisture (preferably unfrozen soil +! moisture rather than total) +! -------------------------------------------------------------------------------------------------- +! source: jarvis (1976), noilhan and planton (1989, mwr), jacquemin and +! noilhan (1990, blm). chen et al (1996, jgr, vol 101(d3), 7251-7268), +! eqns 12-14 and table 2 of sec. 3.1.2 +! -------------------------------------------------------------------------------------------------- +!niu use module_noahlsm_utility +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + real, intent(in) :: par !par absorbed per unit sunlit lai (w/m2) + real, intent(in) :: sfctmp !canopy air temperature + real, intent(in) :: sfcprs !surface pressure (pa) + real, intent(in) :: eah !water vapor pressure (pa) + real, intent(in) :: rcsoil !soil moisture stress factor + +!outputs + + real, intent(out) :: rc !canopy resistance per unit lai + real, intent(out) :: psn !foliage photosynthesis (umolco2/m2/s) + +!local + + real :: rcq + real :: rcs + real :: rct + real :: ff + real :: q2 !water vapor mixing ratio (kg/kg) + real :: q2sat !saturation q2 + real :: dqsdt2 !d(q2sat)/d(t) + +! rsmin, rsmax, topt, rgl, hs are canopy stress parameters set in redprm +! ---------------------------------------------------------------------- +! initialize canopy resistance multiplier terms. +! ---------------------------------------------------------------------- + rc = 0.0 + rcs = 0.0 + rct = 0.0 + rcq = 0.0 + +! compute q2 and q2sat + + q2 = 0.622 * eah / (sfcprs - 0.378 * eah) !specific humidity [kg/kg] + q2 = q2 / (1.0 + q2) !mixing ratio [kg/kg] + + call calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) + +! contribution due to incoming solar radiation + + ff = 2.0 * par / parameters%rgl + rcs = (ff + parameters%rsmin / parameters%rsmax) / (1.0+ ff) + rcs = max (rcs,0.0001) + +! contribution due to air temperature + + rct = 1.0- 0.0016* ( (parameters%topt - sfctmp)**2.0) + rct = max (rct,0.0001) + +! contribution due to vapor pressure deficit + + rcq = 1.0/ (1.0+ parameters%hs * max(0.,q2sat-q2)) + rcq = max (rcq,0.01) + +! determine canopy resistance due to all factors + + rc = parameters%rsmin / (rcs * rct * rcq * rcsoil) + psn = -999.99 ! psn not applied for dynamic carbon + + end subroutine canres + +!== begin calhum =================================================================================== + + subroutine calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) + + implicit none + + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: sfctmp, sfcprs + real, intent(out) :: q2sat, dqsdt2 + real, parameter :: a2=17.67,a3=273.15,a4=29.65, elwv=2.501e6, & + a23m4=a2*(a3-a4), e0=0.611, rv=461.0, & + epsilon=0.622 + real :: es, sfcprsx + +! q2sat: saturated mixing ratio + es = e0 * exp ( elwv/rv*(1./a3 - 1./sfctmp) ) +! convert sfcprs from pa to kpa + sfcprsx = sfcprs*1.e-3 + q2sat = epsilon * es / (sfcprsx-es) +! convert from g/g to g/kg + q2sat = q2sat * 1.e3 +! q2sat is currently a 'mixing ratio' + +! dqsdt2 is calculated assuming q2sat is a specific humidity + dqsdt2=(q2sat/(1+q2sat))*a23m4/(sfctmp-a4)**2 + +! dg q2sat needs to be in g/g when returned for sflx + q2sat = q2sat / 1.e3 + + end subroutine calhum + +!== begin tsnosoi ================================================================================== + + subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in + tbot ,zsnso ,ssoil ,df ,hcpct , & !in + sag ,dt ,snowh ,dzsnso , & !in + tg ,iloc ,jloc , & !in + stc ) !inout +! -------------------------------------------------------------------------------------------------- +! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures +! during melting season may exceed melting point (tfrz) but later in phasechange +! subroutine the snow temperatures are reset to tfrz for melting snow. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: ice ! + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + integer, intent(in) :: ist !surface type + + real, intent(in) :: dt !time step (s) + real, intent(in) :: tbot ! + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, intent(in) :: sag !solar rad. absorbed by ground (w/m2) + real, intent(in) :: snowh !snow depth (m) + real, intent(in) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bot. depth from snow surf.(m) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +!input and output + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +!local + + integer :: iz + real :: zbotsno !zbot from snow surface + real, dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts + real :: eflxb !energy influx from soil bottom (w/m2) + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) + + real, dimension(-nsnow+1:nsoil) :: tbeg + real :: err_est !heat storage error (w/m2) + real :: ssoil2 !ground heat flux (w/m2) (for energy check) + real :: eflxb2 !heat flux from the bottom (w/m2) (for energy check) + character(len=256) :: message +! ---------------------------------------------------------------------- +! compute solar penetration through water, needs more work + + phi(isnow+1:nsoil) = 0. + +! adjust zbot from soil surface to zbotsno from snow surface + + zbotsno = parameters%zbot - snowh !from snow surface + +! snow/soil heat storage for energy balance check + + do iz = isnow+1, nsoil + tbeg(iz) = stc(iz) + enddo + +! compute soil temperatures + + call hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbotsno ,dt , & + df ,hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + eflxb ) + + call hstep (parameters,nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) + +! update ground heat flux just for energy check, but not for final output +! otherwise, it would break the surface energy balance + + if(opt_tbot == 1) then + eflxb2 = 0. + else if(opt_tbot == 2) then + eflxb2 = df(nsoil)*(tbot-stc(nsoil)) / & + (0.5*(zsnso(nsoil-1)+zsnso(nsoil)) - zbotsno) + end if + + ! skip the energy balance check for now, until we can make it work + ! right for small time steps. + return + +! energy balance check + + err_est = 0.0 + do iz = isnow+1, nsoil + err_est = err_est + (stc(iz)-tbeg(iz)) * dzsnso(iz) * hcpct(iz) / dt + enddo + + if (opt_stc == 1) then ! semi-implicit + err_est = err_est - (ssoil +eflxb) + else ! full-implicit + ssoil2 = df(isnow+1)*(tg-stc(isnow+1))/(0.5*dzsnso(isnow+1)) !m. barlage + err_est = err_est - (ssoil2+eflxb2) + endif + + if (abs(err_est) > 1.) then ! w/m2 + write(message,*) 'tsnosoi is losing(-)/gaining(+) false energy',err_est,' w/m2' + call wrf_message(trim(message)) + write(message,'(i6,1x,i6,1x,i3,f18.13,5f20.12)') & + iloc, jloc, ist,err_est,ssoil,snowh,tg,stc(isnow+1),eflxb + call wrf_message(trim(message)) + !niu stop + end if + + end subroutine tsnosoi + +!== begin hrt ====================================================================================== + + subroutine hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbot ,dt , & + df ,hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + botflx ) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + real, intent(in) :: tbot !bottom soil temp. at zbot (k) + real, intent(in) :: zbot !depth of lower boundary condition (m) + !from soil surface not snow surface + real, intent(in) :: dt !time step (s) + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !depth of layer-bottom of snow/soil (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: phi !light through water (w/m2) + +! output + + real, dimension(-nsnow+1:nsoil), intent(out) :: rhsts !right-hand side of the matrix + real, dimension(-nsnow+1:nsoil), intent(out) :: ai !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: bi !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: ci !left-hand side coefficient + real, intent(out) :: botflx !energy influx from soil bottom (w/m2) + +! local + + integer :: k + real, dimension(-nsnow+1:nsoil) :: ddz + real, dimension(-nsnow+1:nsoil) :: dz + real, dimension(-nsnow+1:nsoil) :: denom + real, dimension(-nsnow+1:nsoil) :: dtsdz + real, dimension(-nsnow+1:nsoil) :: eflux + real :: temp1 +! ---------------------------------------------------------------------- + + do k = isnow+1, nsoil + if (k == isnow+1) then + denom(k) = - zsnso(k) * hcpct(k) + temp1 = - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k) + else if (k < nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k) + else if (k == nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k) + if(opt_tbot == 1) then + botflx = 0. + end if + if(opt_tbot == 2) then + dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot) + botflx = -df(k) * dtsdz(k) + end if + eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k) + end if + end do + + do k = isnow+1, nsoil + if (k == isnow+1) then + ai(k) = 0.0 + ci(k) = - df(k) * ddz(k) / denom(k) + if (opt_stc == 1) then + bi(k) = - ci(k) + end if + if (opt_stc == 2) then + bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k)) + end if + else if (k < nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = - df(k ) * ddz(k ) / denom(k) + bi(k) = - (ai(k) + ci (k)) + else if (k == nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - (ai(k) + ci(k)) + end if + rhsts(k) = eflux(k)/ (-denom(k)) + end do + + end subroutine hrt + +!== begin hstep ==================================================================================== + + subroutine hstep (parameters,nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) +! ---------------------------------------------------------------------- +! calculate/update the soil temperature field. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil + integer, intent(in) :: nsnow + integer, intent(in) :: isnow + real, intent(in) :: dt + +! output & input + real, dimension(-nsnow+1:nsoil), intent(inout) :: rhsts + real, dimension(-nsnow+1:nsoil), intent(inout) :: ai + real, dimension(-nsnow+1:nsoil), intent(inout) :: bi + real, dimension(-nsnow+1:nsoil), intent(inout) :: ci + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +! local + integer :: k + real, dimension(-nsnow+1:nsoil) :: rhstsin + real, dimension(-nsnow+1:nsoil) :: ciin +! ---------------------------------------------------------------------- + + do k = isnow+1,nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + end do + + +! copy values for input variables before call to rosr12 + + do k = isnow+1,nsoil + rhstsin(k) = rhsts(k) + ciin(k) = ci(k) + end do + +! solve the tri-diagonal matrix equation + + + call rosr12 (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow) + +! update snow & soil temperature + + do k = isnow+1,nsoil + stc (k) = stc (k) + ci (k) + end do + + end subroutine hstep + +!== begin rosr12 =================================================================================== + + subroutine rosr12 (p,a,b,c,d,delta,ntop,nsoil,nsnow) +! ---------------------------------------------------------------------- +! subroutine rosr12 +! ---------------------------------------------------------------------- +! invert (solve) the tri-diagonal matrix problem shown below: +! ### ### ### ### ### ### +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) # +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) # +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)# +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)# +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + implicit none + + integer, intent(in) :: ntop + integer, intent(in) :: nsoil,nsnow + integer :: k, kk + + real, dimension(-nsnow+1:nsoil),intent(in):: a, b, d + real, dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta + +! ---------------------------------------------------------------------- +! initialize eqn coef c for the lowest soil layer +! ---------------------------------------------------------------------- + c (nsoil) = 0.0 + p (ntop) = - c (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for the 1st soil layer +! ---------------------------------------------------------------------- + delta (ntop) = d (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + p (k) = - c (k) * ( 1.0 / (b (k) + a (k) * p (k -1)) ) + delta (k) = (d (k) - a (k)* delta (k -1))* (1.0/ (b (k) + a (k)& + * p (k -1))) + end do +! ---------------------------------------------------------------------- +! set p to delta for lowest soil layer +! ---------------------------------------------------------------------- + p (nsoil) = delta (nsoil) +! ---------------------------------------------------------------------- +! adjust p for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + kk = nsoil - k + (ntop-1) + 1 + p (kk) = p (kk) * p (kk +1) + delta (kk) + end do +! ---------------------------------------------------------------------- + end subroutine rosr12 + +!== begin phasechange ============================================================================== + + subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso ,hcpct ,ist ,iloc ,jloc , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers [=3] + integer, intent(in) :: nsoil !no. of soil layers [=4] + integer, intent(in) :: isnow !actual no. of snow layers [<=3] + integer, intent(in) :: ist !surface type: 1->soil; 2->lake + real, intent(in) :: dt !land model time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: fact !temporary + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +! outputs + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index + real, intent(out) :: qmelt !snowmelt rate [mm/s] + real, intent(out) :: ponding!snowmelt when snow has no layer [mm] + +! inputs and outputs + + real, intent(inout) :: sneqv + real, intent(inout) :: snowh + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] + real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: j !do loop index + real, dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2] + real, dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2] + real, dimension(-nsnow+1:nsoil) :: wmass0 + real, dimension(-nsnow+1:nsoil) :: wice0 + real, dimension(-nsnow+1:nsoil) :: wliq0 + real, dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm] + real, dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm] + real, dimension(-nsnow+1:nsoil) :: supercool !supercooled water in soil (kg/m2) + real :: heatr !energy residual or loss after melting/freezing + real :: temp1 !temporary variables [kg/m2] + real :: propor + real :: smp !frozen water potential (mm) + real :: xmf !total latent heat of phase change + +! ---------------------------------------------------------------------- +! initialization + + qmelt = 0. + ponding = 0. + xmf = 0. + + do j = -nsnow+1, nsoil + supercool(j) = 0.0 + end do + + do j = isnow+1,0 ! all layers + mice(j) = snice(j) + mliq(j) = snliq(j) + end do + + do j = 1, nsoil ! soil + mliq(j) = sh2o(j) * dzsnso(j) * 1000. + mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000. + end do + + do j = isnow+1,nsoil ! all layers + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = mice(j) + wliq0(j) = mliq(j) + wmass0(j) = mice(j) + mliq(j) + enddo + + if(ist == 1) then + do j = 1,nsoil + if (opt_frz == 1) then + if(stc(j) < tfrz) then + smp = hfus*(tfrz-stc(j))/(grav*stc(j)) !(m) + supercool(j) = parameters%smcmax*(smp/parameters%psisat)**(-1./parameters%bexp) + supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) + end if + end if + if (opt_frz == 2) then + call frh2o (parameters,supercool(j),stc(j),smc(j),sh2o(j)) + supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) + end if + enddo + end if + + do j = isnow+1,nsoil + if (mice(j) > 0. .and. stc(j) >= tfrz) then !melting + imelt(j) = 1 + endif + if (mliq(j) > supercool(j) .and. stc(j) < tfrz) then + imelt(j) = 2 + endif + + ! if snow exists, but its thickness is not enough to create a layer + if (isnow == 0 .and. sneqv > 0. .and. j == 1) then + if (stc(j) >= tfrz) then + imelt(j) = 1 + endif + endif + enddo + +! calculate the energy surplus and loss for melting and freezing + + do j = isnow+1,nsoil + if (imelt(j) > 0) then + hm(j) = (stc(j)-tfrz)/fact(j) + stc(j) = tfrz + endif + + if (imelt(j) == 1 .and. hm(j) < 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + if (imelt(j) == 2 .and. hm(j) > 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + xm(j) = hm(j)*dt/hfus + enddo + +! the rate of melting and freezing for snow without a layer, needs more work. + + if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then + temp1 = sneqv + sneqv = max(0.,temp1-xm(1)) + propor = sneqv/temp1 + snowh = max(0.,propor * snowh) + heatr = hm(1) - hfus*(temp1-sneqv)/dt + if (heatr > 0.) then + xm(1) = heatr*dt/hfus + hm(1) = heatr + else + xm(1) = 0. + hm(1) = 0. + endif + qmelt = max(0.,(temp1-sneqv))/dt + xmf = hfus*qmelt + ponding = temp1-sneqv + endif + +! the rate of melting and freezing for snow and soil + + do j = isnow+1,nsoil + if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then + + heatr = 0. + if (xm(j) > 0.) then + mice(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt + else if (xm(j) < 0.) then + if (j <= 0) then ! snow + mice(j) = min(wmass0(j), wice0(j)-xm(j)) + else ! soil + if (wmass0(j) < supercool(j)) then + mice(j) = 0. + else + mice(j) = min(wmass0(j) - supercool(j),wice0(j)-xm(j)) + mice(j) = max(mice(j),0.0) + endif + endif + heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt + endif + + mliq(j) = max(0.,wmass0(j)-mice(j)) + + if (abs(heatr) > 0.) then + stc(j) = stc(j) + fact(j)*heatr + if (j <= 0) then ! snow + if (mliq(j)*mice(j)>0.) stc(j) = tfrz + end if + endif + + xmf = xmf + hfus * (wice0(j)-mice(j))/dt + + if (j < 1) then + qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt + endif + endif + enddo + + do j = isnow+1,0 ! snow + snliq(j) = mliq(j) + snice(j) = mice(j) + end do + + do j = 1, nsoil ! soil + sh2o(j) = mliq(j) / (1000. * dzsnso(j)) + smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j)) + end do + + end subroutine phasechange + +!== begin frh2o ==================================================================================== + + subroutine frh2o (parameters,free,tkelv,smc,sh2o) + +! ---------------------------------------------------------------------- +! subroutine frh2o +! ---------------------------------------------------------------------- +! calculate amount of supercooled liquid soil water content if +! temperature is below 273.15k (tfrz). requires newton-type iteration +! to solve the nonlinear implicit equation given in eqn 17 of koren et al +! (1999, jgr, vol 104(d16), 19569-19585). +! ---------------------------------------------------------------------- +! new version (june 2001): much faster and more accurate newton +! iteration achieved by first taking log of eqn cited above -- less than +! 4 (typically 1 or 2) iterations achieves convergence. also, explicit +! 1-step solution option for special case of parameter ck=0, which +! reduces the original implicit equation to a simpler explicit form, +! known as the "flerchinger eqn". improved handling of solution in the +! limit of freezing point temperature tfrz. +! ---------------------------------------------------------------------- +! input: + +! tkelv.........temperature (kelvin) +! smc...........total soil moisture content (volumetric) +! sh2o..........liquid soil moisture content (volumetric) +! b.............soil type "b" parameter (from redprm) +! psisat........saturated soil matric potential (from redprm) + +! output: +! free..........supercooled liquid water content [m3/m3] +! ---------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: sh2o,smc,tkelv + real, intent(out) :: free + real :: bx,denom,df,dswl,fk,swl,swlk + integer :: nlog,kcount +! parameter(ck = 0.0) + real, parameter :: ck = 8.0, blim = 5.5, error = 0.005, & + dice = 920.0 + character(len=80) :: message + +! ---------------------------------------------------------------------- +! limits on parameter b: b < 5.5 (use parameter blim) +! simulations showed if b > 5.5 unfrozen water content is +! non-realistically high at very low temperatures. +! ---------------------------------------------------------------------- + bx = parameters%bexp +! ---------------------------------------------------------------------- +! initializing iterations counter and iterative solution flag. +! ---------------------------------------------------------------------- + + if (parameters%bexp > blim) bx = blim + nlog = 0 + +! ---------------------------------------------------------------------- +! if temperature not significantly below freezing (tfrz), sh2o = smc +! ---------------------------------------------------------------------- + kcount = 0 + if (tkelv > (tfrz- 1.e-3)) then + free = smc + else + +! ---------------------------------------------------------------------- +! option 1: iterated solution in koren et al, jgr, 1999, eqn 17 +! ---------------------------------------------------------------------- +! initial guess for swl (frozen content) +! ---------------------------------------------------------------------- + if (ck /= 0.0) then + swl = smc - sh2o +! ---------------------------------------------------------------------- +! keep within bounds. +! ---------------------------------------------------------------------- + if (swl > (smc -0.02)) swl = smc -0.02 +! ---------------------------------------------------------------------- +! start of iterations +! ---------------------------------------------------------------------- + if (swl < 0.) swl = 0. +1001 continue + if (.not.( (nlog < 10) .and. (kcount == 0))) goto 1002 + nlog = nlog +1 + df = alog ( ( parameters%psisat * grav / hfus ) * ( ( 1. + ck * swl )**2.) * & + ( parameters%smcmax / (smc - swl) )** bx) - alog ( - ( & + tkelv - tfrz)/ tkelv) + denom = 2. * ck / ( 1. + ck * swl ) + bx / ( smc - swl ) + swlk = swl - df / denom +! ---------------------------------------------------------------------- +! bounds useful for mathematical solution. +! ---------------------------------------------------------------------- + if (swlk > (smc -0.02)) swlk = smc - 0.02 + if (swlk < 0.) swlk = 0. + +! ---------------------------------------------------------------------- +! mathematical solution bounds applied. +! ---------------------------------------------------------------------- + dswl = abs (swlk - swl) +! if more than 10 iterations, use explicit method (ck=0 approx.) +! when dswl less or eq. error, no more iterations required. +! ---------------------------------------------------------------------- + swl = swlk + if ( dswl <= error ) then + kcount = kcount +1 + end if +! ---------------------------------------------------------------------- +! end of iterations +! ---------------------------------------------------------------------- +! bounds applied within do-block are valid for physical solution. +! ---------------------------------------------------------------------- + goto 1001 +1002 continue + free = smc - swl + end if +! ---------------------------------------------------------------------- +! end option 1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! option 2: explicit solution for flerchinger eq. i.e. ck=0 +! in koren et al., jgr, 1999, eqn 17 +! apply physical bounds to flerchinger solution +! ---------------------------------------------------------------------- + if (kcount == 0) then + write(message, '("flerchinger used in new version. iterations=", i6)') nlog + call wrf_message(trim(message)) + fk = ( ( (hfus / (grav * ( - parameters%psisat)))* & + ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax + if (fk < 0.02) fk = 0.02 + free = min (fk, smc) +! ---------------------------------------------------------------------- +! end option 2 +! ---------------------------------------------------------------------- + end if + end if +! ---------------------------------------------------------------------- + end subroutine frh2o +! ---------------------------------------------------------------------- +! ================================================================================================== +! **********************end of energy subroutines*********************** +! ================================================================================================== + +!== begin water ==================================================================================== + + subroutine water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in + vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in + esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in + ficeold,ponding,tg ,ist ,fveg ,iloc ,jloc ,smceq , & !in + bdfall ,fp ,rain ,snow, & !in mb/an: v3.7 + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout + snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout + sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout + smcwtd ,deeprech,rech , & !inout + cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out + qin ,qdis ,ponding1 ,ponding2, & + qsnbot ,esnow) +! ---------------------------------------------------------------------- +! code history: +! initial code: guo-yue niu, oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: ist !surface type 1-soil; 2-lake + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [1-melt; 2-freeze] + real, intent(in) :: dt !main time step (s) + real, intent(in) :: uu !u-direction wind speed [m/s] + real, intent(in) :: vv !v-direction wind speed [m/s] + real, intent(in) :: fcev !canopy evaporation (w/m2) [+ to atm ] + real, intent(in) :: fctr !transpiration (w/m2) [+ to atm] + real, intent(in) :: qprecc !convective precipitation (mm/s) + real, intent(in) :: qprecl !large-scale precipitation (mm/s) + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: qvap !soil surface evaporation rate[mm/s] + real, intent(in) :: qdew !soil surface dew rate[mm/s] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, dimension( 1:nsoil), intent(in) :: btrani !soil water stress factor (0 to 1) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold !ice fraction at last timestep +! real , intent(in) :: ponding ![mm] + real , intent(in) :: tg !ground temperature (k) + real , intent(in) :: fveg !greeness vegetation fraction (-) + real , intent(in) :: bdfall !bulk density of snowfall (kg/m3) ! mb/an: v3.7 + real , intent(in) :: fp !fraction of the gridcell that receives precipitation ! mb/an: v3.7 + real , intent(in) :: rain !rainfall (mm/s) ! mb/an: v3.7 + real , intent(in) :: snow !snowfall (mm/s) ! mb/an: v3.7 + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics) + real , intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real , intent(in) :: qrain !rain at ground srf (mm) [+] + real , intent(in) :: snowhin !snow depth increasing rate (m/s) + +! input/output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + real, intent(inout) :: tv !vegetation temperature (k) + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !depth of snow/soil layer-bottom + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: zwt !the depth to water table [m] + real, intent(inout) :: wa !water storage in aquifer [mm] + real, intent(inout) :: wt !water storage in aquifer + !+ stuarated soil [mm] + real, intent(inout) :: wslake !water storage in lake (can be -) (mm) + real , intent(inout) :: ponding ![mm] + real, intent(inout) :: smcwtd !soil water content between bottom of the soil and water table [m3/m3] + real, intent(inout) :: deeprech !recharge to or from the water table when deep [m] + real, intent(inout) :: rech !recharge to or from the water table when shallow [m] (diagnostic) + +! output + real, intent(out) :: cmc !intercepted water per ground area (mm) + real, intent(out) :: ecan !evap of intercepted water (mm/s) [+] + real, intent(out) :: etran !transpiration rate (mm/s) [+] + real, intent(out) :: fwet !wetted/snowed fraction of canopy (-) + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !baseflow (sturation excess) [mm/s] + real, intent(out) :: qin !groundwater recharge [mm/s] + real, intent(out) :: qdis !groundwater discharge [mm/s] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + real, intent(out) :: esnow + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real , intent(in) :: latheav !latent heat vap./sublimation (j/kg) + real , intent(in) :: latheag !latent heat vap./sublimation (j/kg) + logical , intent(in) :: frozen_ground ! used to define latent heat pathway + logical , intent(in) :: frozen_canopy ! used to define latent heat pathway + + +! local + integer :: iz + real :: qinsur !water input on soil surface [m/s] + real :: qseva !soil surface evap rate [mm/s] + real :: qsdew !soil surface dew rate [mm/s] + real :: qsnfro !snow surface frost rate[mm/s] + real :: qsnsub !snow surface sublimation rate [mm/s] + real, dimension( 1:nsoil) :: etrani !transpiration rate (mm/s) [+] + real, dimension( 1:nsoil) :: wcnd !hydraulic conductivity (m/s) + real :: qdrain !soil-bottom free drainage [mm/s] + real :: snoflow !glacier flow [mm/s] + real :: fcrmax !maximum of fcr (-) + + real, parameter :: wslmax = 5000. !maximum lake water storage (mm) + + +! ---------------------------------------------------------------------- +! initialize + + etrani(1:nsoil) = 0. + snoflow = 0. + runsub = 0. + qinsur = 0. + +! canopy-intercepted snowfall/rainfall, drips, and throughfall + + call canwater (parameters,vegtyp ,dt , & !in + fcev ,fctr ,elai , & !in + esai ,tg ,fveg ,iloc , jloc, & !in + bdfall ,frozen_canopy , & !in + canliq ,canice ,tv , & !inout + cmc ,ecan ,etran , & !out + fwet ) !out + +! sublimation, frost, evaporation, and dew + + qsnsub = 0. + if (sneqv > 0.) then + qsnsub = min(qvap, sneqv/dt) + endif + qseva = qvap-qsnsub + esnow = qsnsub*2.83e+6 + + qsnfro = 0. + if (sneqv > 0.) then + qsnfro = qdew + endif + qsdew = qdew - qsnfro + + call snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in + & sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in + & qrain ,ficeold,iloc ,jloc , & !in + & isnow ,snowh ,sneqv ,snice ,snliq , & !inout + & sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout + & qsnbot ,snoflow,ponding1 ,ponding2) !out + + if(frozen_ground) then + sice(1) = sice(1) + (qsdew-qseva)*dt/(dzsnso(1)*1000.) + qsdew = 0.0 + qseva = 0.0 + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + +! convert units (mm/s -> m/s) + + !ponding: melting water from snow when there is no layer + qinsur = (ponding+ponding1+ponding2)/dt * 0.001 +! qinsur = ponding/dt * 0.001 + + if(isnow == 0) then + qinsur = qinsur+(qsnbot + qsdew + qrain) * 0.001 + else + qinsur = qinsur+(qsnbot + qsdew) * 0.001 + endif + + qseva = qseva * 0.001 + + do iz = 1, parameters%nroot + etrani(iz) = etran * btrani(iz) * 0.001 + enddo + + +! lake/soil water balances + + if (ist == 2) then ! lake + runsrf = 0. + if(wslake >= wslmax) runsrf = qinsur*1000. !mm/s + wslake = wslake + (qinsur-qseva)*1000.*dt -runsrf*dt !mm + else ! soil + call soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + qinsur ,qseva ,etrani ,sice ,iloc , jloc , & !in + sh2o ,smc ,zwt ,vegtyp , & !inout + smcwtd, deeprech , & !inout + runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out + + if(opt_run == 1) then + call groundwater (parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in + stc ,wcnd ,fcrmax ,iloc ,jloc , & !in + sh2o ,zwt ,wa ,wt , & !inout + qin ,qdis ) !out + runsub = qdis !mm/s + end if + + if(opt_run == 3 .or. opt_run == 4) then + runsub = runsub + qdrain !mm/s + end if + + do iz = 1,nsoil + smc(iz) = sh2o(iz) + sice(iz) + enddo + + if(opt_run == 5) then + call shallowwatertable (parameters,nsnow ,nsoil, zsoil, dt , & !in + dzsnso ,smceq ,iloc , jloc , & !in + smc ,zwt ,smcwtd ,rech, qdrain ) !inout + + sh2o(nsoil) = smc(nsoil) - sice(nsoil) + runsub = runsub + qdrain !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here + wa = 0. + endif + + endif + + runsub = runsub + snoflow !mm/s + + end subroutine water + +!== begin canwater ================================================================================= + + subroutine canwater (parameters,vegtyp ,dt , & !in + fcev ,fctr ,elai , & !in + esai ,tg ,fveg ,iloc , jloc , & !in + bdfall ,frozen_canopy , & !in + canliq ,canice ,tv , & !inout + cmc ,ecan ,etran , & !out + fwet ) !out + +! ------------------------ code history ------------------------------ +! canopy hydrology +! -------------------------------------------------------------------- + implicit none +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation type + real, intent(in) :: dt !main time step (s) + real, intent(in) :: fcev !canopy evaporation (w/m2) [+ = to atm] + real, intent(in) :: fctr !transpiration (w/m2) [+ = to atm] + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: fveg !greeness vegetation fraction (-) + logical , intent(in) :: frozen_canopy ! used to define latent heat pathway + real , intent(in) :: bdfall !bulk density of snowfall (kg/m3) ! mb/an: v3.7 + +! input & output + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + real, intent(inout) :: tv !vegetation temperature (k) + +! output + real, intent(out) :: cmc !intercepted water (mm) + real, intent(out) :: ecan !evaporation of intercepted water (mm/s) [+] + real, intent(out) :: etran !transpiration rate (mm/s) [+] + real, intent(out) :: fwet !wetted or snowed fraction of the canopy (-) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + real :: maxsno !canopy capacity for snow interception (mm) + real :: maxliq !canopy capacity for rain interception (mm) + real :: qevac !evaporation rate (mm/s) + real :: qdewc !dew rate (mm/s) + real :: qfroc !frost rate (mm/s) + real :: qsubc !sublimation rate (mm/s) + real :: qmeltc !melting rate of canopy snow (mm/s) + real :: qfrzc !refreezing rate of canopy liquid water (mm/s) + real :: canmas !total canopy mass (kg/m2) +! -------------------------------------------------------------------- +! initialization + + ecan = 0.0 + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + maxliq = parameters%ch2op * (elai+ esai) + +! evaporation, transpiration, and dew + + if (.not.frozen_canopy) then ! barlage: change to frozen_canopy + etran = max( fctr/hvap, 0. ) + qevac = max( fcev/hvap, 0. ) + qdewc = abs( min( fcev/hvap, 0. ) ) + qsubc = 0. + qfroc = 0. + else + etran = max( fctr/hsub, 0. ) + qevac = 0. + qdewc = 0. + qsubc = max( fcev/hsub, 0. ) + qfroc = abs( min( fcev/hsub, 0. ) ) + endif + +! canopy water balance. for convenience allow dew to bring canliq above +! maxh2o or else would have to re-adjust drip + + qevac = min(canliq/dt,qevac) + canliq=max(0.,canliq+(qdewc-qevac)*dt) + if(canliq <= 1.e-06) canliq = 0.0 + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai) + + qsubc = min(canice/dt,qsubc) + canice= max(0.,canice + (qfroc-qsubc)*dt) + if(canice.le.1.e-6) canice = 0. + +! wetted fraction of canopy + + if(canice.gt.0.) then + fwet = max(0.,canice) / max(maxsno,1.e-06) + else + fwet = max(0.,canliq) / max(maxliq,1.e-06) + endif + fwet = min(fwet, 1.) ** 0.667 + +! phase change + + qmeltc = 0. + qfrzc = 0. + + if(canice.gt.1.e-6.and.tv.gt.tfrz) then + qmeltc = min(canice/dt,(tv-tfrz)*cice*canice/denice/(dt*hfus)) + canice = max(0.,canice - qmeltc*dt) + canliq = max(0.,canliq + qmeltc*dt) + tv = fwet*tfrz + (1.-fwet)*tv + endif + + if(canliq.gt.1.e-6.and.tv.lt.tfrz) then + qfrzc = min(canliq/dt,(tfrz-tv)*cwat*canliq/denh2o/(dt*hfus)) + canliq = max(0.,canliq - qfrzc*dt) + canice = max(0.,canice + qfrzc*dt) + tv = fwet*tfrz + (1.-fwet)*tv + endif + +! total canopy water + + cmc = canliq + canice + +! total canopy evaporation + + ecan = qevac + qsubc - qdewc - qfroc + + end subroutine canwater + +!== begin snowwater ================================================================================ + + subroutine snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in + sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in + qrain ,ficeold,iloc ,jloc , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (s) + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + real, dimension(-nsnow+1:0) , intent(in) :: ficeold!ice fraction at last timestep + +! input & output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !depth of snow/soil layer-bottom + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + +! output + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: snoflow!glacier flow [mm] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local + integer :: iz,i + real :: bdsnow !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + snoflow = 0.0 + ponding1 = 0.0 + ponding2 = 0.0 + + call snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in + sfctmp ,iloc ,jloc , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout + +! mb: do each if block separately + + if(isnow < 0) & ! when multi-layer + call compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,zsoil ,imelt ,ficeold,iloc , jloc ,& !in + isnow ,dzsnso ,zsnso ) !inout + + if(isnow < 0) & !when multi-layer + call combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out + + if(isnow < 0) & !when multi-layer + call divide (parameters,nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout + + call snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain ,iloc ,jloc , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + qsnbot ,ponding1 ,ponding2) !out + +!set empty snow layers to zero + + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo + +!to obtain equilibrium state of snow in glacier region + + if(sneqv > 2000.) then ! 2000 mm -> maximum water depth + bdsnow = snice(0) / dzsnso(0) + snoflow = (sneqv - 2000.) + snice(0) = snice(0) - snoflow + dzsnso(0) = dzsnso(0) - snoflow/bdsnow + snoflow = snoflow / dt + end if + +! sum up snow mass for layered snow + + if(isnow < 0) then ! mb: only do for multi-layer + sneqv = 0. + do iz = isnow+1,0 + sneqv = sneqv + snice(iz) + snliq(iz) + enddo + end if + +! reset zsnso and layer thinkness dzsnso + + do iz = isnow+1, 0 + dzsnso(iz) = -dzsnso(iz) + end do + + dzsnso(1) = zsoil(1) + do iz = 2,nsoil + dzsnso(iz) = (zsoil(iz) - zsoil(iz-1)) + end do + + zsnso(isnow+1) = dzsnso(isnow+1) + do iz = isnow+2 ,nsoil + zsnso(iz) = zsnso(iz-1) + dzsnso(iz) + enddo + + do iz = isnow+1 ,nsoil + dzsnso(iz) = -dzsnso(iz) + end do + + end subroutine snowwater + +!== begin snowfall ================================================================================= + + subroutine snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in + sfctmp ,iloc ,jloc , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !main time step (s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: sfctmp !surface air temperature [k] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: sneqv !swow water equivalent [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !thickness of snow/soil layers (m) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: newnode ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + newnode = 0 + +! shallow snow / no layer + + if(isnow == 0 .and. qsnow > 0.) then + snowh = snowh + snowhin * dt + sneqv = sneqv + qsnow * dt + end if + +! creating a new layer + + if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.025) then !mb: change limit +! if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then + isnow = -1 + newnode = 1 + dzsnso(0)= snowh + snowh = 0. + stc(0) = min(273.16, sfctmp) ! temporary setup + snice(0) = sneqv + snliq(0) = 0. + end if + +! snow with layers + + if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then + snice(isnow+1) = snice(isnow+1) + qsnow * dt + dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt + endif + +! ---------------------------------------------------------------------- + end subroutine snowfall + +!== begin combine ================================================================================== + + subroutine combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + real, intent(inout) :: sneqv !snow water equivalent [m] + real, intent(inout) :: snowh !snow depth [m] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local variables: + + integer :: i,j,k,l ! node indices + integer :: isnow_old ! number of top snow layer + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + real :: zwice ! total ice mass in snow + real :: zwliq ! total liquid water in snow + + real :: dzmin(3) ! minimum of top snow layer +! data dzmin /0.045, 0.05, 0.2/ + data dzmin /0.025, 0.025, 0.1/ ! mb: change limit +!----------------------------------------------------------------------- + + isnow_old = isnow + + do j = isnow_old+1,0 + if (snice(j) <= .1) then + if(j /= 0) then + snliq(j+1) = snliq(j+1) + snliq(j) + snice(j+1) = snice(j+1) + snice(j) + else + if (isnow_old < -1) then ! mb/km: change to isnow + snliq(j-1) = snliq(j-1) + snliq(j) + snice(j-1) = snice(j-1) + snice(j) + else + if(snice(j) >= 0.) then + ponding1 = snliq(j) ! isnow will get set to zero below; ponding1 will get + sneqv = snice(j) ! added to ponding from phasechange ponding should be + snowh = dzsnso(j) ! zero here because it was calculated for thin snow + else ! snice over-sublimated earlier + ponding1 = snliq(j) + snice(j) + if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil + sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.)) + ponding1 = 0.0 + end if + sneqv = 0.0 + snowh = 0.0 + end if + snliq(j) = 0.0 + snice(j) = 0.0 + dzsnso(j) = 0.0 + endif +! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.) +! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.) + endif + + ! shift all elements above this down by one. + if (j > isnow+1 .and. isnow < -1) then + do i = j, isnow+2, -1 + stc(i) = stc(i-1) + snliq(i) = snliq(i-1) + snice(i) = snice(i-1) + dzsnso(i)= dzsnso(i-1) + end do + end if + isnow = isnow + 1 + end if + end do + +! to conserve water in case of too large surface sublimation + + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + + if(isnow ==0) return ! mb: get out if no longer multi-layer + + sneqv = 0. + snowh = 0. + zwice = 0. + zwliq = 0. + + do j = isnow+1,0 + sneqv = sneqv + snice(j) + snliq(j) + snowh = snowh + dzsnso(j) + zwice = zwice + snice(j) + zwliq = zwliq + snliq(j) + end do + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + + if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit +! if (snowh < 0.05 .and. isnow < 0 ) then + isnow = 0 + sneqv = zwice + ponding2 = zwliq ! limit of isnow < 0 means input ponding + if(sneqv <= 0.) snowh = 0. ! should be zero; see above + end if + +! if (snowh < 0.05 ) then +! isnow = 0 +! sneqv = zwice +! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.) +! if(sneqv <= 0.) snowh = 0. +! end if + +! check the snow depth - snow layers combined + + if (isnow < -1) then + + isnow_old = isnow + mssi = 1 + + do i = isnow_old+1,0 + if (dzsnso(i) < dzmin(mssi)) then + + if (i == isnow+1) then + neibor = i + 1 + else if (i == 0) then + neibor = i - 1 + else + neibor = i + 1 + if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1 + end if + + ! node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call combo (parameters,dzsnso(j), snliq(j), snice(j), & + stc(j), dzsnso(l), snliq(l), snice(l), stc(l) ) + + ! now shift all elements above this down one. + if (j-1 > isnow+1) then + do k = j-1, isnow+2, -1 + stc(k) = stc(k-1) + snice(k) = snice(k-1) + snliq(k) = snliq(k-1) + dzsnso(k) = dzsnso(k-1) + end do + end if + + ! decrease the number of snow layers + isnow = isnow + 1 + if (isnow >= -1) exit + else + + ! the layer thickness is greater than the prescribed minimum value + mssi = mssi + 1 + + end if + end do + + end if + + end subroutine combine + +!== begin divide =================================================================================== + + subroutine divide (parameters,nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, intent(in) :: nsoil !no. of soil layers [ =4] + +! input and output + + integer , intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + +! local variables: + + integer :: j !indices + integer :: msno !number of layer (top) to msno (bot) + real :: drr !thickness of the combined [m] + real, dimension( 1:nsnow) :: dz !snow layer thickness [m] + real, dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3] + real, dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3] + real, dimension( 1:nsnow) :: tsno !node temperature [k] + real :: zwice !temporary + real :: zwliq !temporary + real :: propor!temporary + real :: dtdz !temporary +! ---------------------------------------------------------------------- + + do j = 1,nsnow + if (j <= abs(isnow)) then + dz(j) = dzsnso(j+isnow) + swice(j) = snice(j+isnow) + swliq(j) = snliq(j+isnow) + tsno(j) = stc(j+isnow) + end if + end do + + msno = abs(isnow) + + if (msno == 1) then + ! specify a new snow layer + if (dz(1) > 0.05) then + msno = 2 + dz(1) = dz(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + dz(2) = dz(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) + end if + end if + + if (msno > 1) then + if (dz(1) > 0.05) then + drr = dz(1) - 0.05 + propor = drr/dz(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + propor = 0.05/dz(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dz(1) = 0.05 + + call combo (parameters,dz(2), swliq(2), swice(2), tsno(2), drr, & + zwliq, zwice, tsno(1)) + + ! subdivide a new layer + if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit +! if (msno <= 2 .and. dz(2) > 0.10) then + msno = 3 + dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.) + dz(2) = dz(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + dz(3) = dz(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) - dtdz*dz(2)/2. + if (tsno(3) >= tfrz) then + tsno(3) = tsno(2) + else + tsno(2) = tsno(2) + dtdz*dz(2)/2. + endif + + end if + end if + end if + + if (msno > 2) then + if (dz(2) > 0.2) then + drr = dz(2) - 0.2 + propor = drr/dz(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + propor = 0.2/dz(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dz(2) = 0.2 + call combo (parameters,dz(3), swliq(3), swice(3), tsno(3), drr, & + zwliq, zwice, tsno(2)) + end if + end if + + isnow = -msno + + do j = isnow+1,0 + dzsnso(j) = dz(j-isnow) + snice(j) = swice(j-isnow) + snliq(j) = swliq(j-isnow) + stc(j) = tsno(j-isnow) + end do + + +! do j = isnow+1,nsoil +! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j) +! end do + + end subroutine divide + +!== begin combo ==================================================================================== + + subroutine combo(parameters,dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: dz2 !nodal thickness of 2 elements being combined [m] + real, intent(in) :: wliq2 !liquid water of element 2 [kg/m2] + real, intent(in) :: wice2 !ice of element 2 [kg/m2] + real, intent(in) :: t2 !nodal temperature of element 2 [k] + real, intent(inout) :: dz !nodal thickness of 1 elements being combined [m] + real, intent(inout) :: wliq !liquid water of element 1 + real, intent(inout) :: wice !ice of element 1 [kg/m2] + real, intent(inout) :: t !node temperature of element 1 [k] + +! local + + real :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2). + real :: wliqc !combined liquid water [kg/m2] + real :: wicec !combined ice [kg/m2] + real :: tc !combined node temperature [k] + real :: h !enthalpy of element 1 [j/m2] + real :: h2 !enthalpy of element 2 [j/m2] + real :: hc !temporary + +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq + h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cice*wicec + cwat*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine combo + +!== begin compact ================================================================================== + + subroutine compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,zsoil ,imelt ,ficeold,iloc , jloc , & !in + isnow ,dzsnso ,zsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers [ =4] + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil srf + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + +! input and output + integer, intent(inout) :: isnow ! actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso ! depth of snow/soil layer-bottom + +! local + real, parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3 + real, parameter :: c3 = 2.5e-6 ![1/s] + real, parameter :: c4 = 0.04 ![1/k] + real, parameter :: c5 = 2.0 ! + real, parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] + real, parameter :: eta0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to anderson, it is between 0.52e6~1.38e6 + real :: burden !pressure of overlying snow [kg/m2] + real :: ddz1 !rate of settling of snow pack due to destructive metamorphism. + real :: ddz2 !rate of compaction of snow pack due to overburden. + real :: ddz3 !rate of compaction of snow pack due to melt [1/s] + real :: dexpf !expf=exp(-c4*(273.15-stc)). + real :: td !stc - tfrz [k] + real :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s] + real :: void !void (1 - snice - snliq) + real :: wx !water mass (ice + liquid) [kg/m2] + real :: bi !partial density of ice [kg/m3] + real, dimension(-nsnow+1:0) :: fice !fraction of ice at current time step + + integer :: j + +! ---------------------------------------------------------------------- + burden = 0.0 + + do j = isnow+1, 0 + + wx = snice(j) + snliq(j) + fice(j) = snice(j) / wx + void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j) + + ! allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. snice(j) > 0.1) then + bi = snice(j) / dzsnso(j) + td = max(0.,tfrz-stc(j)) + dexpf = exp(-c4*td) + + ! settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! liquid water term + + if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5 + + ! compaction due to overburden + + ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden + + ! compaction occurring during melt + + if (imelt(j) == 1) then + ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j))) + ddz3 = - ddz3/dt ! sometimes too large + else + ddz3 = 0. + end if + + ! time rate of fractional change in dz (units of s-1) + + pdzdtc = (ddz1 + ddz2 + ddz3)*dt + pdzdtc = max(-0.5,pdzdtc) + + ! the change in dz due to compaction + + dzsnso(j) = dzsnso(j)*(1.+pdzdtc) + end if + + ! pressure of overlying snow + + burden = burden + wx + + end do + + end subroutine compact + +!== begin snowh2o ================================================================================== + + subroutine snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain ,iloc ,jloc , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + qsnbot ,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- +! renew the mass of ice lens (snice) and liquid (snliq) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers[=3] + integer, intent(in) :: nsoil !no. of soil layers[=4] + real, intent(in) :: dt !time step + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + +! output + + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer depth [m] + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + +! local variables: + + integer :: j !do loop/array indices + real :: qin !water flow into the element (mm/s) + real :: qout !water flow out of the element (mm/s) + real :: wgdif !ice mass after minus sublimation + real, dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer + real, dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer + real, dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice + real :: propor, temp + real :: ponding1, ponding2 +! ---------------------------------------------------------------------- + +!for the case when sneqv becomes '0' after 'combine' + + if(sneqv == 0.) then + sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) ! barlage: sh2o->sice v3.6 + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. to conserve water, +! excessive sublimation is used to reduce soil water. smaller time steps would tend +! to aviod this problem. + + if(isnow == 0 .and. sneqv > 0.) then + temp = sneqv + sneqv = sneqv - qsnsub*dt + qsnfro*dt + propor = sneqv/temp + snowh = max(0.,propor * snowh) + + if(sneqv < 0.) then + sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.) + sneqv = 0. + snowh = 0. + end if + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + + if(snowh <= 1.e-8 .or. sneqv <= 1.e-6) then + snowh = 0.0 + sneqv = 0.0 + end if + +! for deep snow + + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + + wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt + snice(isnow+1) = wgdif + if (wgdif < 1.e-6 .and. isnow <0) then + call combine (parameters,nsnow ,nsoil ,iloc, jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1, ponding2 ) !out + endif + !kwm: subroutine combine can change isnow to make it 0 again? + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + snliq(isnow+1) = snliq(isnow+1) + qrain * dt + snliq(isnow+1) = max(0., snliq(isnow+1)) + endif + + endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)? + +! porosity and partial volume + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice)) + epore(j) = 1. - vol_ice(j) + vol_liq(j) = min(epore(j),snliq(j)/(dzsnso(j)*denh2o)) + end if + end do + + qin = 0. + qout = 0. + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + snliq(j) = snliq(j) + qin + if (j <= -1) then + if (epore(j) < 0.05 .or. epore(j+1) < 0.05) then + qout = 0. + else + qout = max(0.,(vol_liq(j)-parameters%ssi*epore(j))*dzsnso(j)) + qout = min(qout,(1.-vol_ice(j+1)-vol_liq(j+1))*dzsnso(j+1)) + end if + else + qout = max(0.,(vol_liq(j) - parameters%ssi*epore(j))*dzsnso(j)) + end if + qout = qout*1000. + snliq(j) = snliq(j) - qout + qin = qout + end if + end do + +! liquid water from snow bottom to soil + + qsnbot = qout / dt ! mm/s + + end subroutine snowh2o + +!== begin soilwater ================================================================================ + + subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + qinsur ,qseva ,etrani ,sice ,iloc , jloc, & !in + sh2o ,smc ,zwt ,vegtyp ,& !inout + smcwtd, deeprech ,& !inout + runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out + +! ---------------------------------------------------------------------- +! calculate surface runoff and soil moisture. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !time step (sec) + real, intent(in) :: qinsur !water input on soil surface [mm/s] + real, intent(in) :: qseva !evap from soil surface [mm/s] + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(1:nsoil), intent(in) :: etrani !evapotranspiration from soil layers [mm/s] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer depth [m] + real, dimension(1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + + integer, intent(in) :: vegtyp + +! input & output + real, dimension(1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension(1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: zwt !water table depth [m] + real, intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3] + real , intent(inout) :: deeprech + +! output + real, intent(out) :: qdrain !soil-bottom free drainage [mm/s] + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !subsurface runoff [mm/s] + real, intent(out) :: fcrmax !maximum of fcr (-) + real, dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s) + +! local + integer :: k,iz !do-loop index + integer :: iter !iteration index + real :: dtfine !fine time step (s) + real, dimension(1:nsoil) :: rhstt !right-hand side term of the matrix + real, dimension(1:nsoil) :: ai !left-hand side term + real, dimension(1:nsoil) :: bi !left-hand side term + real, dimension(1:nsoil) :: ci !left-hand side term + + real :: fff !runoff decay factor (m-1) + real :: rsbmx !baseflow coefficient [mm/s] + real :: pddum !infiltration rate at surface (m/s) + real :: fice !ice fraction in frozen soil + real :: wplus !saturation excess of the total soil [m] + real :: rsat !accumulation of wplus (saturation excess) [m] + real :: sicemax!maximum soil ice content (m3/m3) + real :: sh2omin!minimum soil liquid water content (m3/m3) + real :: wtsub !sum of wcnd(k)*dzsnso(k) + real :: mh2o !water mass removal (mm) + real :: fsat !fractional saturated area (-) + real, dimension(1:nsoil) :: mliq ! + real :: xs ! + real :: watmin ! + real :: qdrain_save ! + real :: epore !effective porosity [m3/m3] + real, dimension(1:nsoil) :: fcr !impermeable fraction due to frozen soil + integer :: niter !iteration times soil moisture (-) + real :: smctot !2-m averaged soil moisture (m3/m3) + real :: dztot !2-m soil depth (m) + real, parameter :: a = 4.0 +! ---------------------------------------------------------------------- + runsrf = 0.0 + pddum = 0.0 + rsat = 0.0 + +! for the case when snowmelt water is too large + + do k = 1,nsoil + epore = max ( 1.e-4 , ( parameters%smcmax - sice(k) ) ) + rsat = rsat + max(0.,sh2o(k)-epore)*dzsnso(k) + sh2o(k) = min(epore,sh2o(k)) + end do + +!impermeable fraction due to frozen soil + + do k = 1,nsoil + fice = min(1.0,sice(k)/parameters%smcmax) + fcr(k) = max(0.0,exp(-a*(1.-fice))- exp(-a)) / & + (1.0 - exp(-a)) + end do + +! maximum soil ice content and minimum liquid water of all layers + + sicemax = 0.0 + fcrmax = 0.0 + sh2omin = parameters%smcmax + do k = 1,nsoil + if (sice(k) > sicemax) sicemax = sice(k) + if (fcr(k) > fcrmax) fcrmax = fcr(k) + if (sh2o(k) < sh2omin) sh2omin = sh2o(k) + end do + +!subsurface runoff for runoff scheme option 2 + + if(opt_run == 2) then + fff = 2.0 + rsbmx = 4.0 + call zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt) + runsub = (1.0-fcrmax) * rsbmx * exp(-parameters%timean) * exp(-fff*zwt) ! mm/s + end if + +!surface runoff and infiltration rate using different schemes + +!jref impermable surface at urban + if ( parameters%urban_flag ) fcr(1)= 0.95 + + if(opt_run == 1) then + fff = 6.0 + fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 5) then + fff = 6.0 + fsat = parameters%fsatmx*exp(-0.5*fff*max(-2.0-zwt,0.)) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 2) then + fff = 2.0 + fsat = parameters%fsatmx*exp(-0.5*fff*zwt) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 3) then + call infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in + sicemax,qinsur , & !in + pddum ,runsrf ) !out + end if + + if(opt_run == 4) then + smctot = 0. + dztot = 0. + do k = 1,nsoil + dztot = dztot + dzsnso(k) + smctot = smctot + smc(k)*dzsnso(k) + if(dztot >= 2.0) exit + end do + smctot = smctot/dztot + fsat = max(0.01,smctot/parameters%smcmax) ** 4. !bats + + if(qinsur > 0.) then + runsrf = qinsur * ((1.0-fcr(1))*fsat+fcr(1)) + pddum = qinsur - runsrf ! m/s + end if + end if + +! determine iteration times and finer time step + + niter = 1 + + if(opt_inf == 1) then !opt_inf =2 may cause water imbalance + niter = 3 + if (pddum*dt>dzsnso(1)*parameters%smcmax ) then + niter = niter*2 + end if + end if + + dtfine = dt / niter + +! solve soil moisture + + qdrain_save = 0.0 + do iter = 1, niter + call srt (parameters,nsoil ,zsoil ,dtfine ,pddum ,etrani , & !in + qseva ,sh2o ,smc ,zwt ,fcr , & !in + sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in + rhstt ,ai ,bi ,ci ,qdrain , & !out + wcnd ) !out + + call sstep (parameters,nsoil ,nsnow ,dtfine ,zsoil ,dzsnso , & !in + sice ,iloc ,jloc ,zwt , & !in + sh2o ,smc ,ai ,bi ,ci , & !inout + rhstt ,smcwtd ,qdrain ,deeprech, & !inout + wplus) !out + rsat = rsat + wplus + qdrain_save = qdrain_save + qdrain + end do + + qdrain = qdrain_save/niter + + runsrf = runsrf * 1000. + rsat * 1000./dt ! m/s -> mm/s + qdrain = qdrain * 1000. + +!wrf_hydro_djg... +!yw infxsrt = runsrf * dt !mm/s -> mm + +! removal of soil water due to groundwater flow (option 2) + + if(opt_run == 2) then + wtsub = 0. + do k = 1, nsoil + wtsub = wtsub + wcnd(k)*dzsnso(k) + end do + + do k = 1, nsoil + mh2o = runsub*dt*(wcnd(k)*dzsnso(k))/wtsub ! mm + sh2o(k) = sh2o(k) - mh2o/(dzsnso(k)*1000.) + end do + end if + +! limit mliq to be greater than or equal to watmin. +! get water needed to bring mliq equal watmin from lower layer. + + if(opt_run /= 1) then + do iz = 1, nsoil + mliq(iz) = sh2o(iz)*dzsnso(iz)*1000. + end do + + watmin = 0.01 ! mm + do iz = 1, nsoil-1 + if (mliq(iz) .lt. 0.) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz ) = mliq(iz ) + xs + mliq(iz+1) = mliq(iz+1) - xs + end do + + iz = nsoil + if (mliq(iz) .lt. watmin) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz) = mliq(iz) + xs + runsub = runsub - xs/dt + if(opt_run == 5)deeprech = deeprech - xs*1.e-3 + + do iz = 1, nsoil + sh2o(iz) = mliq(iz) / (dzsnso(iz)*1000.) + end do + end if + + end subroutine soilwater + +!== begin zwteq ==================================================================================== + + subroutine zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt) +! ---------------------------------------------------------------------- +! calculate equilibrium water table depth (niu et al., 2005) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer depth [m] + real, dimension(1:nsoil), intent(in) :: sh2o !soil liquid water content [m3/m3] + +! output + + real, intent(out) :: zwt !water table depth [m] + +! locals + + integer :: k !do-loop index + integer, parameter :: nfine = 100 !no. of fine soil layers of 6m soil + real :: wd1 !water deficit from coarse (4-l) soil moisture profile + real :: wd2 !water deficit from fine (100-l) soil moisture profile + real :: dzfine !layer thickness of the 100-l soil layers to 6.0 m + real :: temp !temporary variable + real, dimension(1:nfine) :: zfine !layer-bottom depth of the 100-l soil layers to 6.0 m +! ---------------------------------------------------------------------- + + wd1 = 0. + do k = 1,nsoil + wd1 = wd1 + (parameters%smcmax-sh2o(k)) * dzsnso(k) ! [m] + enddo + + dzfine = 3.0 * (-zsoil(nsoil)) / nfine + do k =1,nfine + zfine(k) = float(k) * dzfine + enddo + + zwt = -3.*zsoil(nsoil) - 0.001 ! initial value [m] + + wd2 = 0. + do k = 1,nfine + temp = 1. + (zwt-zfine(k))/parameters%psisat + wd2 = wd2 + parameters%smcmax*(1.-temp**(-1./parameters%bexp))*dzfine + if(abs(wd2-wd1).le.0.01) then + zwt = zfine(k) + exit + endif + enddo + + end subroutine zwteq + +!== begin infil ==================================================================================== + + subroutine infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in + sicemax,qinsur , & !in + pddum ,runsrf ) !out +! -------------------------------------------------------------------------------- +! compute inflitration rate at soil surface and surface runoff +! -------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no. of soil layers + real, intent(in) :: dt !time step (sec) + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(1:nsoil), intent(in) :: sh2o !soil liquid water content [m3/m3] + real, dimension(1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + real, intent(in) :: qinsur !water input on soil surface [mm/s] + real, intent(in) :: sicemax!maximum soil ice content (m3/m3) + +! outputs + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: pddum !infiltration rate at surface + +! locals + integer :: ialp1, j, jj, k + real :: val + real :: ddt + real :: px + real :: dt1, dd, dice + real :: fcr + real :: sum + real :: acrt + real :: wdf + real :: wcnd + real :: smcav + real :: infmax + real, dimension(1:nsoil) :: dmax + integer, parameter :: cvfrz = 3 +! -------------------------------------------------------------------------------- + + if (qinsur > 0.0) then + dt1 = dt /86400. + smcav = parameters%smcmax - parameters%smcwlt + +! maximum infiltration rate + + dmax(1)= -zsoil(1) * smcav + dice = -zsoil(1) * sice(1) + dmax(1)= dmax(1)* (1.0-(sh2o(1) + sice(1) - parameters%smcwlt)/smcav) + + dd = dmax(1) + + do k = 2,nsoil + dice = dice + (zsoil(k-1) - zsoil(k) ) * sice(k) + dmax(k) = (zsoil(k-1) - zsoil(k)) * smcav + dmax(k) = dmax(k) * (1.0-(sh2o(k) + sice(k) - parameters%smcwlt)/smcav) + dd = dd + dmax(k) + end do + + val = (1. - exp ( - parameters%kdt * dt1)) + ddt = dd * val + px = max(0.,qinsur * dt) + infmax = (px * (ddt / (px + ddt)))/ dt + +! impermeable fraction due to frozen soil + + fcr = 1. + if (dice > 1.e-2) then + acrt = cvfrz * parameters%frzx / dice + sum = 1. + ialp1 = cvfrz - 1 + do j = 1,ialp1 + k = 1 + do jj = j +1,ialp1 + k = k * jj + end do + sum = sum + (acrt ** (cvfrz - j)) / float(k) + end do + fcr = 1. - exp (-acrt) * sum + end if + +! correction of infiltration limitation + + infmax = infmax * fcr + +! jref for urban areas +! if ( parameters%urban_flag ) infmax == infmax * 0.05 + + call wdfcnd2 (parameters,wdf,wcnd,sh2o(1),sicemax) + infmax = max (infmax,wcnd) + infmax = min (infmax,px) + + runsrf= max(0., qinsur - infmax) + pddum = qinsur - runsrf + + end if + + end subroutine infil + +!== begin srt ====================================================================================== + + subroutine srt (parameters,nsoil ,zsoil ,dt ,pddum ,etrani , & !in + qseva ,sh2o ,smc ,zwt ,fcr , & !in + sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in + rhstt ,ai ,bi ,ci ,qdrain , & !out + wcnd ) !out +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! water diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil + real, dimension(1:nsoil), intent(in) :: zsoil + real, intent(in) :: dt + real, intent(in) :: pddum + real, intent(in) :: qseva + real, dimension(1:nsoil), intent(in) :: etrani + real, dimension(1:nsoil), intent(in) :: sh2o + real, dimension(1:nsoil), intent(in) :: smc + real, intent(in) :: zwt ! water table depth [m] + real, dimension(1:nsoil), intent(in) :: fcr + real, intent(in) :: fcrmax !maximum of fcr (-) + real, intent(in) :: sicemax!maximum soil ice content (m3/m3) + real, intent(in) :: smcwtd !soil moisture between bottom of the soil and the water table + +! output + + real, dimension(1:nsoil), intent(out) :: rhstt + real, dimension(1:nsoil), intent(out) :: ai + real, dimension(1:nsoil), intent(out) :: bi + real, dimension(1:nsoil), intent(out) :: ci + real, dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s) + real, intent(out) :: qdrain !bottom drainage (m/s) + +! local + integer :: k + real, dimension(1:nsoil) :: ddz + real, dimension(1:nsoil) :: denom + real, dimension(1:nsoil) :: dsmdz + real, dimension(1:nsoil) :: wflux + real, dimension(1:nsoil) :: wdf + real, dimension(1:nsoil) :: smx + real :: temp1 + real :: smxwtd !soil moisture between bottom of the soil and water table + real :: smxbot !soil moisture below bottom to calculate flux + +! niu and yang (2006), j. of hydrometeorology +! ---------------------------------------------------------------------- + + if(opt_inf == 1) then + do k = 1, nsoil + call wdfcnd1 (parameters,wdf(k),wcnd(k),smc(k),fcr(k)) + smx(k) = smc(k) + end do + if(opt_run == 5)smxwtd=smcwtd + end if + + if(opt_inf == 2) then + do k = 1, nsoil + call wdfcnd2 (parameters,wdf(k),wcnd(k),sh2o(k),sicemax) + smx(k) = sh2o(k) + end do + if(opt_run == 5)smxwtd=smcwtd*sh2o(nsoil)/smc(nsoil) !same liquid fraction as in the bottom layer + end if + + do k = 1, nsoil + if(k == 1) then + denom(k) = - zsoil (k) + temp1 = - zsoil (k+1) + ddz(k) = 2.0 / temp1 + dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1 + wflux(k) = wdf(k) * dsmdz(k) + wcnd(k) - pddum + etrani(k) + qseva + else if (k < nsoil) then + denom(k) = (zsoil(k-1) - zsoil(k)) + temp1 = (zsoil(k-1) - zsoil(k+1)) + ddz(k) = 2.0 / temp1 + dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1 + wflux(k) = wdf(k ) * dsmdz(k ) + wcnd(k ) & + - wdf(k-1) * dsmdz(k-1) - wcnd(k-1) + etrani(k) + else + denom(k) = (zsoil(k-1) - zsoil(k)) + if(opt_run == 1 .or. opt_run == 2) then + qdrain = 0. + end if + if(opt_run == 3) then + qdrain = parameters%slope*wcnd(k) + end if + if(opt_run == 4) then + qdrain = (1.0-fcrmax)*wcnd(k) + end if + if(opt_run == 5) then !gmm new m-m&f water table dynamics formulation + temp1 = 2.0 * denom(k) + if(zwt < zsoil(nsoil)-denom(nsoil))then +!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom + smxbot = smx(k) - (smx(k)-smxwtd) * denom(k) * 2./ (denom(k) + zsoil(k) - zwt) + else + smxbot = smxwtd + endif + dsmdz(k) = 2.0 * (smx(k) - smxbot) / temp1 + qdrain = wdf(k ) * dsmdz(k ) + wcnd(k ) + end if + wflux(k) = -(wdf(k-1)*dsmdz(k-1))-wcnd(k-1)+etrani(k) + qdrain + end if + end do + + do k = 1, nsoil + if(k == 1) then + ai(k) = 0.0 + bi(k) = wdf(k ) * ddz(k ) / denom(k) + ci(k) = - bi (k) + else if (k < nsoil) then + ai(k) = - wdf(k-1) * ddz(k-1) / denom(k) + ci(k) = - wdf(k ) * ddz(k ) / denom(k) + bi(k) = - ( ai (k) + ci (k) ) + else + ai(k) = - wdf(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - ( ai (k) + ci (k) ) + end if + rhstt(k) = wflux(k) / (-denom(k)) + end do + +! ---------------------------------------------------------------------- + end subroutine srt + +!== begin sstep ==================================================================================== + + subroutine sstep (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + sice ,iloc ,jloc ,zwt , & !in + sh2o ,smc ,ai ,bi ,ci , & !inout + rhstt ,smcwtd ,qdrain ,deeprech, & !inout + wplus ) !out + +! ---------------------------------------------------------------------- +! calculate/update soil moisture content values +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil ! + integer, intent(in) :: nsnow ! + real, intent(in) :: dt + real, intent(in) :: zwt + real, dimension( 1:nsoil), intent(in) :: zsoil + real, dimension( 1:nsoil), intent(in) :: sice + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m] + +!input and output + real, dimension(1:nsoil), intent(inout) :: sh2o + real, dimension(1:nsoil), intent(inout) :: smc + real, dimension(1:nsoil), intent(inout) :: ai + real, dimension(1:nsoil), intent(inout) :: bi + real, dimension(1:nsoil), intent(inout) :: ci + real, dimension(1:nsoil), intent(inout) :: rhstt + real , intent(inout) :: smcwtd + real , intent(inout) :: qdrain + real , intent(inout) :: deeprech + +!output + real, intent(out) :: wplus !saturation excess water (m) + +!local + integer :: k + real, dimension(1:nsoil) :: rhsttin + real, dimension(1:nsoil) :: ciin + real :: stot + real :: epore + real :: wminus +! ---------------------------------------------------------------------- + wplus = 0.0 + + do k = 1,nsoil + rhstt (k) = rhstt(k) * dt + ai (k) = ai(k) * dt + bi (k) = 1. + bi(k) * dt + ci (k) = ci(k) * dt + end do + +! copy values for input variables before calling rosr12 + + do k = 1,nsoil + rhsttin(k) = rhstt(k) + ciin(k) = ci(k) + end do + +! call rosr12 to solve the tri-diagonal matrix + + call rosr12 (ci,ai,bi,ciin,rhsttin,rhstt,1,nsoil,0) + + do k = 1,nsoil + sh2o(k) = sh2o(k) + ci(k) + enddo + +! excessive water above saturation in a layer is moved to +! its unsaturated layer like in a bucket + +!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table + if(opt_run == 5) then + +!update smcwtd + + if(zwt < zsoil(nsoil)-dzsnso(nsoil))then +!accumulate qdrain to update deep water table and soil moisture later + deeprech = deeprech + dt * qdrain + else + smcwtd = smcwtd + dt * qdrain / dzsnso(nsoil) + wplus = max((smcwtd-parameters%smcmax), 0.0) * dzsnso(nsoil) + wminus = max((1.e-4-smcwtd), 0.0) * dzsnso(nsoil) + + smcwtd = max( min(smcwtd,parameters%smcmax) , 1.e-4) + sh2o(nsoil) = sh2o(nsoil) + wplus/dzsnso(nsoil) + +!reduce fluxes at the bottom boundaries accordingly + qdrain = qdrain - wplus/dt + deeprech = deeprech - wminus + endif + + endif + + do k = nsoil,2,-1 + epore = max ( 1.e-4 , ( parameters%smcmax - sice(k) ) ) + wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k) + sh2o(k) = min(epore,sh2o(k)) + sh2o(k-1) = sh2o(k-1) + wplus/dzsnso(k-1) + end do + + epore = max ( 1.e-4 , ( parameters%smcmax - sice(1) ) ) + wplus = max((sh2o(1)-epore), 0.0) * dzsnso(1) + sh2o(1) = min(epore,sh2o(1)) + + end subroutine sstep + +!== begin wdfcnd1 ================================================================================== + + subroutine wdfcnd1 (parameters,wdf,wcnd,smc,fcr) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + real,intent(in) :: smc + real,intent(in) :: fcr + +! output + real,intent(out) :: wcnd + real,intent(out) :: wdf + +! local + real :: expon + real :: factr + real :: vkwgt +! ---------------------------------------------------------------------- + +! soil water diffusivity + + factr = max(0.01, smc/parameters%smcmax) + expon = parameters%bexp + 2.0 + wdf = parameters%dwsat * factr ** expon + wdf = wdf * (1.0 - fcr) + +! hydraulic conductivity + + expon = 2.0*parameters%bexp + 3.0 + wcnd = parameters%dksat * factr ** expon + wcnd = wcnd * (1.0 - fcr) + + end subroutine wdfcnd1 + +!== begin wdfcnd2 ================================================================================== + + subroutine wdfcnd2 (parameters,wdf,wcnd,smc,sice) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + real,intent(in) :: smc + real,intent(in) :: sice + +! output + real,intent(out) :: wcnd + real,intent(out) :: wdf + +! local + real :: expon + real :: factr + real :: vkwgt +! ---------------------------------------------------------------------- + +! soil water diffusivity + + factr = max(0.01, smc/parameters%smcmax) + expon = parameters%bexp + 2.0 + wdf = parameters%dwsat * factr ** expon + + if (sice > 0.0) then + vkwgt = 1./ (1. + (500.* sice)**3.) + wdf = vkwgt * wdf + (1.-vkwgt)*parameters%dwsat*(0.2/parameters%smcmax)**expon + end if + +! hydraulic conductivity + + expon = 2.0*parameters%bexp + 3.0 + wcnd = parameters%dksat * factr ** expon + + end subroutine wdfcnd2 + +!== begin groundwater ============================================================================== + + subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in + stc ,wcnd ,fcrmax ,iloc ,jloc , & !in + sh2o ,zwt ,wa ,wt , & !inout + qin ,qdis ) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + real, intent(in) :: dt !timestep [sec] + real, intent(in) :: fcrmax!maximum fcr (-) + real, dimension( 1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension( 1:nsoil), intent(in) :: wcnd !hydraulic conductivity (m/s) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + +! input and output + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil water [m3/m3] + real, intent(inout) :: zwt !the depth to water table [m] + real, intent(inout) :: wa !water storage in aquifer [mm] + real, intent(inout) :: wt !water storage in aquifer + !+ saturated soil [mm] +! output + real, intent(out) :: qin !groundwater recharge [mm/s] + real, intent(out) :: qdis !groundwater discharge [mm/s] + +! local + real :: fff !runoff decay factor (m-1) + real :: rsbmx !baseflow coefficient [mm/s] + integer :: iz !do-loop index + integer :: iwt !layer index above water table layer + real, dimension( 1:nsoil) :: dzmm !layer thickness [mm] + real, dimension( 1:nsoil) :: znode !node depth [m] + real, dimension( 1:nsoil) :: mliq !liquid water mass [kg/m2 or mm] + real, dimension( 1:nsoil) :: epore !effective porosity [-] + real, dimension( 1:nsoil) :: hk !hydraulic conductivity [mm/s] + real, dimension( 1:nsoil) :: smc !total soil water content [m3/m3] + real(kind=8) :: s_node!degree of saturation of iwt layer + real :: dzsum !cumulative depth above water table [m] + real :: smpfz !matric potential (frozen effects) [mm] + real :: ka !aquifer hydraulic conductivity [mm/s] + real :: wh_zwt!water head at water table [mm] + real :: wh !water head at layer above zwt [mm] + real :: ws !water used to fill air pore [mm] + real :: wtsub !sum of hk*dzmm + real :: watmin!minimum soil vol soil moisture [m3/m3] + real :: xs !excessive water above saturation [mm] + real, parameter :: rous = 0.2 !specific yield [-] + real, parameter :: cmic = 0.20 !microprore content (0.0-1.0) + !0.0-close to free drainage +! ------------------------------------------------------------- + qdis = 0.0 + qin = 0.0 + +! derive layer-bottom depth in [mm] +!kwm: derive layer thickness in mm + + dzmm(1) = -zsoil(1)*1.e3 + do iz = 2, nsoil + dzmm(iz) = 1.e3 * (zsoil(iz - 1) - zsoil(iz)) + enddo + +! derive node (middle) depth in [m] +!kwm: positive number, depth below ground surface in m + znode(1) = -zsoil(1) / 2. + do iz = 2, nsoil + znode(iz) = -zsoil(iz-1) + 0.5 * (zsoil(iz-1) - zsoil(iz)) + enddo + +! convert volumetric soil moisture "sh2o" to mass + + do iz = 1, nsoil + smc(iz) = sh2o(iz) + sice(iz) + mliq(iz) = sh2o(iz) * dzmm(iz) + epore(iz) = max(0.01,parameters%smcmax - sice(iz)) + hk(iz) = 1.e3*wcnd(iz) + enddo + +! the layer index of the first unsaturated layer, +! i.e., the layer right above the water table + + iwt = nsoil + do iz = 2,nsoil + if(zwt .le. -zsoil(iz) ) then + iwt = iz-1 + exit + end if + enddo + +! groundwater discharge [mm/s] + + fff = 6.0 + rsbmx = 5.0 + + qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) + +! matric potential at the layer above the water table + + s_node = min(1.0,smc(iwt)/parameters%smcmax ) + s_node = max(s_node,real(0.01,kind=8)) + smpfz = -parameters%psisat*1000.*s_node**(-parameters%bexp) ! m --> mm + smpfz = max(-120000.0,cmic*smpfz) + +! recharge rate qin to groundwater + + ka = hk(iwt) + + wh_zwt = - zwt * 1.e3 !(mm) + wh = smpfz - znode(iwt)*1.e3 !(mm) + qin = - ka * (wh_zwt-wh) /((zwt-znode(iwt))*1.e3) + qin = max(-10.0/dt,min(10./dt,qin)) + +! water storage in the aquifer + saturated soil + + wt = wt + (qin - qdis) * dt !(mm) + + if(iwt.eq.nsoil) then + wa = wa + (qin - qdis) * dt !(mm) + wt = wa + zwt = (-zsoil(nsoil) + 25.) - wa/1000./rous !(m) + mliq(nsoil) = mliq(nsoil) - qin * dt ! [mm] + + mliq(nsoil) = mliq(nsoil) + max(0.,(wa - 5000.)) + wa = min(wa, 5000.) + else + + if (iwt.eq.nsoil-1) then + zwt = -zsoil(nsoil) & + - (wt-rous*1000*25.) / (epore(nsoil))/1000. + else + ws = 0. ! water used to fill soil air pores + do iz = iwt+2,nsoil + ws = ws + epore(iz) * dzmm(iz) + enddo + zwt = -zsoil(iwt+1) & + - (wt-rous*1000.*25.-ws) /(epore(iwt+1))/1000. + endif + + wtsub = 0. + do iz = 1, nsoil + wtsub = wtsub + hk(iz)*dzmm(iz) + end do + + do iz = 1, nsoil ! removing subsurface runoff + mliq(iz) = mliq(iz) - qdis*dt*hk(iz)*dzmm(iz)/wtsub + end do + end if + + zwt = max(1.5,zwt) + +! +! limit mliq to be greater than or equal to watmin. +! get water needed to bring mliq equal watmin from lower layer. +! + watmin = 0.01 + do iz = 1, nsoil-1 + if (mliq(iz) .lt. 0.) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz ) = mliq(iz ) + xs + mliq(iz+1) = mliq(iz+1) - xs + end do + + iz = nsoil + if (mliq(iz) .lt. watmin) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz) = mliq(iz) + xs + wa = wa - xs + wt = wt - xs + + do iz = 1, nsoil + sh2o(iz) = mliq(iz) / dzmm(iz) + end do + + end subroutine groundwater + +!== begin shallowwatertable ======================================================================== + + subroutine shallowwatertable (parameters,nsnow ,nsoil ,zsoil, dt , & !in + dzsnso ,smceq ,iloc ,jloc , & !in + smc ,wtd ,smcwtd ,rech, qdrain ) !inout +! ---------------------------------------------------------------------- +!diagnoses water table depth and computes recharge when the water table is within the resolved soil layers, +!according to the miguez-macho&fan scheme +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: iloc,jloc + real, intent(in) :: dt + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] + +! input and output + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: wtd !the depth to water table [m] + real, intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3] + real, intent(out) :: rech ! groundwater recharge (net vertical flux across the water table), positive up + real, intent(inout) :: qdrain + +! local + integer :: iz !do-loop index + integer :: iwtd !layer index above water table layer + integer :: kwtd !layer index where the water table layer is + real :: wtdold + real :: dzup + real :: smceqdeep + real, dimension( 0:nsoil) :: zsoil0 +! ------------------------------------------------------------- + + +zsoil0(1:nsoil) = zsoil(1:nsoil) +zsoil0(0) = 0. + +!find the layer where the water table is + do iz=nsoil,1,-1 + if(wtd + 1.e-6 < zsoil0(iz)) exit + enddo + iwtd=iz + + + kwtd=iwtd+1 !layer where the water table is + if(kwtd.le.nsoil)then !wtd in the resolved layers + wtdold=wtd + if(smc(kwtd).gt.smceq(kwtd))then + + if(smc(kwtd).eq.parameters%smcmax)then !wtd went to the layer above + wtd=zsoil0(iwtd) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + iwtd=iwtd-1 + kwtd=kwtd-1 + if(kwtd.ge.1)then + if(smc(kwtd).gt.smceq(kwtd))then + wtdold=wtd + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ), zsoil0(iwtd)) + rech=rech-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + endif + endif + else !wtd stays in the layer + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ), zsoil0(iwtd)) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + endif + + else !wtd has gone down to the layer below + wtd=zsoil0(kwtd) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + kwtd=kwtd+1 + iwtd=iwtd+1 +!wtd crossed to the layer below. now adjust it there + if(kwtd.le.nsoil)then + wtdold=wtd + if(smc(kwtd).gt.smceq(kwtd))then + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ) , zsoil0(iwtd) ) + else + wtd=zsoil0(kwtd) + endif + rech = rech - (wtdold-wtd) * & + (parameters%smcmax-smceq(kwtd)) + + else + wtdold=wtd +!restore smoi to equilibrium value with water from the ficticious layer below +! smcwtd=smcwtd-(smceq(nsoil)-smc(nsoil)) +! qdrain = qdrain - 1000 * (smceq(nsoil)-smc(nsoil)) * dzsnso(nsoil) / dt +! smc(nsoil)=smceq(nsoil) +!adjust wtd in the ficticious layer below + smceqdeep = parameters%smcmax * ( -parameters%psisat / ( -parameters%psisat - dzsnso(nsoil) ) ) ** (1./parameters%bexp) + wtd = min( ( smcwtd*dzsnso(nsoil) & + - smceqdeep*zsoil0(nsoil) + parameters%smcmax*(zsoil0(nsoil)-dzsnso(nsoil)) ) / & + ( parameters%smcmax-smceqdeep ) , zsoil0(nsoil) ) + rech = rech - (wtdold-wtd) * & + (parameters%smcmax-smceqdeep) + endif + + endif + elseif(wtd.ge.zsoil0(nsoil)-dzsnso(nsoil))then +!if wtd was already below the bottom of the resolved soil crust + wtdold=wtd + smceqdeep = parameters%smcmax * ( -parameters%psisat / ( -parameters%psisat - dzsnso(nsoil) ) ) ** (1./parameters%bexp) + if(smcwtd.gt.smceqdeep)then + wtd = min( ( smcwtd*dzsnso(nsoil) & + - smceqdeep*zsoil0(nsoil) + parameters%smcmax*(zsoil0(nsoil)-dzsnso(nsoil)) ) / & + ( parameters%smcmax-smceqdeep ) , zsoil0(nsoil) ) + rech = -(wtdold-wtd) * (parameters%smcmax-smceqdeep) + else + rech = -(wtdold-(zsoil0(nsoil)-dzsnso(nsoil))) * (parameters%smcmax-smceqdeep) + wtdold=zsoil0(nsoil)-dzsnso(nsoil) +!and now even further down + dzup=(smceqdeep-smcwtd)*dzsnso(nsoil)/(parameters%smcmax-smceqdeep) + wtd=wtdold-dzup + rech = rech - (parameters%smcmax-smceqdeep)*dzup + smcwtd=smceqdeep + endif + + + endif + +if(iwtd.lt.nsoil)smcwtd=parameters%smcmax + +end subroutine shallowwatertable + +! ================================================================================================== +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + +!== begin carbon =================================================================================== + + subroutine carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in + dzsnso ,stc ,smc ,tv ,tg ,psn , & !in + foln ,btran ,apar ,fveg ,igs , & !in + troot ,ist ,lat ,iloc ,jloc , & !in + lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout + gpp ,npp ,nee ,autors ,heters ,totsc , & !out + totlb ,xlai ,xsai ) !out +! ------------------------------------------------------------------------------------------ + implicit none +! ------------------------------------------------------------------------------------------ +! inputs (carbon) + + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer , intent(in) :: vegtyp !vegetation type + integer , intent(in) :: nsnow !number of snow layers + integer , intent(in) :: nsoil !number of soil layers + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: dt !time step (s) + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real , intent(in) :: tv !vegetation temperature (k) + real , intent(in) :: tg !ground temperature (k) + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: btran !soil water transpiration factor (0 to 1) + real , intent(in) :: psn !total leaf photosyn (umolco2/m2/s) [+] + real , intent(in) :: apar !par by canopy (w/m2) + real , intent(in) :: igs !growing season index (0=off, 1=on) + real , intent(in) :: fveg !vegetation greenness fraction + real , intent(in) :: troot !root-zone averaged temperature (k) + integer , intent(in) :: ist !surface type 1->soil; 2->lake + +! input & output (carbon) + + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + real , intent(inout) :: stblcp !stable carbon in deep soil [g/m2] + real , intent(inout) :: fastcp !short-lived carbon in shallow soil [g/m2] + +! outputs: (carbon) + + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c] + real , intent(out) :: npp !net primary productivity [g/m2/s c] + real , intent(out) :: nee !net ecosystem exchange [g/m2/s co2] + real , intent(out) :: autors !net ecosystem respiration [g/m2/s c] + real , intent(out) :: heters !organic respiration [g/m2/s c] + real , intent(out) :: totsc !total soil carbon [g/m2 c] + real , intent(out) :: totlb !total living carbon ([g/m2 c] + real , intent(out) :: xlai !leaf area index [-] + real , intent(out) :: xsai !stem area index [-] +! real , intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1] + +! local variables + + integer :: j !do-loop index + real :: wroot !root zone soil water [-] + real :: wstres !water stress coeficient [-] (1. for wilting ) + real :: lapm !leaf area per unit mass [m2/g] +! ------------------------------------------------------------------------------------------ + + if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. & + ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then + xlai = 0. + xsai = 0. + gpp = 0. + npp = 0. + nee = 0. + autors = 0. + heters = 0. + totsc = 0. + totlb = 0. + lfmass = 0. + rtmass = 0. + stmass = 0. + wood = 0. + stblcp = 0. + fastcp = 0. + + return + end if + + lapm = parameters%sla / 1000. ! m2/kg -> m2/g + +! water stress + + wstres = 1.- btran + + wroot = 0. + do j=1,parameters%nroot + wroot = wroot + smc(j)/parameters%smcmax * dzsnso(j) / (-zsoil(parameters%nroot)) + enddo + + call co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in + dzsnso ,stc ,psn ,troot ,tv , & !in + wroot ,wstres ,foln ,lapm , & !in + lat ,iloc ,jloc ,fveg , & !in + xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout + fastcp ,stblcp ,wood , & !inout + gpp ,npp ,nee ,autors ,heters , & !out + totsc ,totlb ) !out + +! call bvoc (parameters,vocflx, vegtyp, vegfac, apar, tv) +! call ch4 + + end subroutine carbon + +!== begin co2flux ================================================================================== + + subroutine co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in + dzsnso ,stc ,psn ,troot ,tv , & !in + wroot ,wstres ,foln ,lapm , & !in + lat ,iloc ,jloc ,fveg , & !in + xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout + fastcp ,stblcp ,wood , & !inout + gpp ,npp ,nee ,autors ,heters , & !out + totsc ,totlb ) !out +! ----------------------------------------------------------------------------------------- +! the original code is from re dickinson et al.(1998), modifed by guo-yue niu, 2004 +! ----------------------------------------------------------------------------------------- + implicit none +! ----------------------------------------------------------------------------------------- + +! input + + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer , intent(in) :: vegtyp !vegetation physiology type + integer , intent(in) :: nsnow !number of snow layers + integer , intent(in) :: nsoil !number of soil layers + real , intent(in) :: dt !time step (s) + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: igs !growing season index (0=off, 1=on) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k] + real , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s) + real , intent(in) :: troot !root-zone averaged temperature (k) + real , intent(in) :: tv !leaf temperature (k) + real , intent(in) :: wroot !root zone soil water + real , intent(in) :: wstres !soil water stress + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: lapm !leaf area per unit mass [m2/g] + real , intent(in) :: fveg !vegetation greenness fraction + +! input and output + + real , intent(inout) :: xlai !leaf area index from leaf carbon [-] + real , intent(inout) :: xsai !stem area index from leaf carbon [-] + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: fastcp !short lived carbon [g/m2] + real , intent(inout) :: stblcp !stable carbon pool [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + +! output + + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s] + real , intent(out) :: npp !net primary productivity [g/m2] + real , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp) + real , intent(out) :: autors !net ecosystem resp. (maintance and growth) + real , intent(out) :: heters !organic respiration + real , intent(out) :: totsc !total soil carbon (g/m2) + real , intent(out) :: totlb !total living carbon (g/m2) + +! local + + real :: cflux !carbon flux to atmosphere [g/m2/s] + real :: lfmsmn !minimum leaf mass [g/m2] + real :: rswood !wood respiration [g/m2] + real :: rsleaf !leaf maintenance respiration per timestep [g/m2] + real :: rsroot !fine root respiration per time step [g/m2] + real :: nppl !leaf net primary productivity [g/m2/s] + real :: nppr !root net primary productivity [g/m2/s] + real :: nppw !wood net primary productivity [g/m2/s] + real :: npps !wood net primary productivity [g/m2/s] + real :: dielf !death of leaf mass per time step [g/m2] + + real :: addnpplf !leaf assimil after resp. losses removed [g/m2] + real :: addnppst !stem assimil after resp. losses removed [g/m2] + real :: carbfx !carbon assimilated per model step [g/m2] + real :: grleaf !growth respiration rate for leaf [g/m2/s] + real :: grroot !growth respiration rate for root [g/m2/s] + real :: grwood !growth respiration rate for wood [g/m2/s] + real :: grstem !growth respiration rate for stem [g/m2/s] + real :: leafpt !fraction of carbon allocated to leaves [-] + real :: lfdel !maximum leaf mass available to change [g/m2/s] + real :: lftovr !stem turnover per time step [g/m2] + real :: sttovr !stem turnover per time step [g/m2] + real :: wdtovr !wood turnover per time step [g/m2] + real :: rssoil !soil respiration per time step [g/m2] + real :: rttovr !root carbon loss per time step by turnover [g/m2] + real :: stablc !decay rate of fast carbon to slow carbon [g/m2/s] + real :: woodf !calculated wood to root ratio [-] + real :: nonlef !fraction of carbon to root and wood [-] + real :: rootpt !fraction of carbon flux to roots [-] + real :: woodpt !fraction of carbon flux to wood [-] + real :: stempt !fraction of carbon flux to stem [-] + real :: resp !leaf respiration [umol/m2/s] + real :: rsstem !stem respiration [g/m2/s] + + real :: fsw !soil water factor for microbial respiration + real :: fst !soil temperature factor for microbial respiration + real :: fnf !foliage nitrogen adjustemt to respiration (<= 1) + real :: tf !temperature factor + real :: rf !respiration reduction factor (<= 1) + real :: stdel + real :: stmsmn + real :: sapm !stem area per unit mass (m2/g) + real :: diest +! -------------------------- constants ------------------------------- + real :: bf !parameter for present wood allocation [-] + real :: rswoodc !wood respiration coeficient [1/s] + real :: stovrc !stem turnover coefficient [1/s] + real :: rsdryc !degree of drying that reduces soil respiration [-] + real :: rtovrc !root turnover coefficient [1/s] + real :: wstrc !water stress coeficient [-] + real :: laimin !minimum leaf area index [m2/m2] + real :: xsamin !minimum leaf area index [m2/m2] + real :: sc + real :: sd + real :: vegfrac + +! respiration as a function of temperature + + real :: r,x + r(x) = exp(0.08*(x-298.16)) +! --------------------------------------------------------------------------------- + +! constants + rtovrc = 2.0e-8 !original was 2.0e-8 + rsdryc = 40.0 !original was 40.0 + rswoodc = 3.0e-10 ! + bf = 0.90 !original was 0.90 ! carbon to roots + wstrc = 100.0 + laimin = 0.05 + xsamin = 0.05 ! mb: change to prevent vegetation from not growing back in spring + + sapm = 3.*0.001 ! m2/kg -->m2/g + lfmsmn = laimin/lapm + stmsmn = xsamin/sapm +! --------------------------------------------------------------------------------- + +! respiration + + if(igs .eq. 0.) then + rf = 0.5 + else + rf = 1.0 + endif + + fnf = min( foln/max(1.e-06,parameters%folnmx), 1.0 ) + tf = parameters%arm**( (tv-298.16)/10. ) + resp = parameters%rmf25 * tf * fnf * xlai * rf * (1.-wstres) ! umol/m2/s + rsleaf = min((lfmass-lfmsmn)/dt,resp*12.e-6) ! g/m2/s + + rsroot = parameters%rmr25*(rtmass*1e-3)*tf *rf* 12.e-6 ! g/m2/s + rsstem = parameters%rms25*((stmass-stmsmn)*1e-3)*tf *rf* 12.e-6 ! g/m2/s + rswood = rswoodc * r(tv) * wood*parameters%wdpool + +! carbon assimilation +! 1 mole -> 12 g carbon or 44 g co2; 1 umol -> 12.e-6 g carbon; + + carbfx = psn * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon + +! fraction of carbon into leaf versus nonleaf + + leafpt = exp(0.01*(1.-exp(0.75*xlai))*xlai) + if(vegtyp == parameters%eblforest) leafpt = exp(0.01*(1.-exp(0.50*xlai))*xlai) + + nonlef = 1.0 - leafpt + stempt = xlai/10.0*leafpt + leafpt = leafpt - stempt + +! fraction of carbon into wood versus root + + if(wood.gt.0) then + woodf = (1.-exp(-bf*(parameters%wrrat*rtmass/wood))/bf)*parameters%wdpool + else + woodf = 0. + endif + + rootpt = nonlef*(1.-woodf) + woodpt = nonlef*woodf + +! leaf and root turnover per time step + + lftovr = parameters%ltovrc*5.e-7*lfmass + sttovr = parameters%ltovrc*5.e-7*stmass + rttovr = rtovrc*rtmass + wdtovr = 9.5e-10*wood + +! seasonal leaf die rate dependent on temp and water stress +! water stress is set to 1 at permanent wilting point + + sc = exp(-0.3*max(0.,tv-parameters%tdlef)) * (lfmass/120.) + sd = exp((wstres-1.)*wstrc) + dielf = lfmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc) + diest = stmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc) + +! calculate growth respiration for leaf, rtmass and wood + + grleaf = max(0.0,parameters%fragr*(leafpt*carbfx - rsleaf)) + grstem = max(0.0,parameters%fragr*(stempt*carbfx - rsstem)) + grroot = max(0.0,parameters%fragr*(rootpt*carbfx - rsroot)) + grwood = max(0.0,parameters%fragr*(woodpt*carbfx - rswood)) + +! impose lower t limit for photosynthesis + + addnpplf = max(0.,leafpt*carbfx - grleaf-rsleaf) + addnppst = max(0.,stempt*carbfx - grstem-rsstem) +! addnpplf = leafpt*carbfx - grleaf-rsleaf ! mb: test kjetil +! addnppst = stempt*carbfx - grstem-rsstem ! mb: test kjetil + if(tv.lt.parameters%tmin) addnpplf =0. + if(tv.lt.parameters%tmin) addnppst =0. + +! update leaf, root, and wood carbon +! avoid reducing leaf mass below its minimum value but conserve mass + + lfdel = (lfmass - lfmsmn)/dt + stdel = (stmass - stmsmn)/dt + dielf = min(dielf,lfdel+addnpplf-lftovr) + diest = min(diest,stdel+addnppst-sttovr) + +! net primary productivities + + nppl = max(addnpplf,-lfdel) + npps = max(addnppst,-stdel) + nppr = rootpt*carbfx - rsroot - grroot + nppw = woodpt*carbfx - rswood - grwood + +! masses of plant components + + lfmass = lfmass + (nppl-lftovr-dielf)*dt + stmass = stmass + (npps-sttovr-diest)*dt ! g/m2 + rtmass = rtmass + (nppr-rttovr) *dt + + if(rtmass.lt.0.0) then + rttovr = nppr + rtmass = 0.0 + endif + wood = (wood+(nppw-wdtovr)*dt)*parameters%wdpool + +! soil carbon budgets + + fastcp = fastcp + (rttovr+lftovr+sttovr+wdtovr+dielf+diest)*dt ! mb: add diest v3.7 + + fst = 2.0**( (stc(1)-283.16)/10. ) + fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot) + rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6 + + stablc = 0.1*rssoil + fastcp = fastcp - (rssoil + stablc)*dt + stblcp = stblcp + stablc*dt + +! total carbon flux + + cflux = - carbfx + rsleaf + rsroot + rswood + rsstem & ! mb: add rsstem,grstem,0.9*rssoil v3.7 + + 0.9*rssoil + grleaf + grroot + grwood + grstem ! g/m2/s + +! for outputs + + gpp = carbfx !g/m2/s c + npp = nppl + nppw + nppr +npps !g/m2/s c + autors = rsroot + rswood + rsleaf + rsstem + & !g/m2/s c mb: add rsstem, grstem v3.7 + grleaf + grroot + grwood + grstem !g/m2/s c mb: add 0.9* v3.7 + heters = 0.9*rssoil !g/m2/s c + nee = (autors + heters - gpp)*44./12. !g/m2/s co2 + totsc = fastcp + stblcp !g/m2 c + totlb = lfmass + rtmass +stmass + wood !g/m2 c mb: add stmass v3.7 + +! leaf area index and stem area index + + xlai = max(lfmass*lapm,laimin) + xsai = max(stmass*sapm,xsamin) + + end subroutine co2flux + +!== begin bvocflux ================================================================================= + +! subroutine bvocflux(parameters,vocflx, vegtyp, vegfrac, apar, tv ) +! +! ------------------------------------------------------------------------------------------ +! implicit none +! ------------------------------------------------------------------------------------------ +! +! ------------------------ code history --------------------------- +! source file: bvoc +! purpose: bvoc emissions +! description: +! volatile organic compound emission +! this code simulates volatile organic compound emissions +! following the algorithm presented in guenther, a., 1999: modeling +! biogenic volatile organic compound emissions to the atmosphere. in +! reactive hydrocarbons in the atmosphere, ch. 3 +! this model relies on the assumption that 90% of isoprene and monoterpene +! emissions originate from canopy foliage: +! e = epsilon * gamma * density * delta +! the factor delta (longterm activity factor) applies to isoprene emission +! from deciduous plants only. we neglect this factor at the present time. +! this factor is discussed in guenther (1997). +! subroutine written to operate at the patch level. +! in final implementation, remember: +! 1. may wish to call this routine only as freq. as rad. calculations +! 2. may wish to place epsilon values directly in pft-physiology file +! ------------------------ input/output variables ----------------- +! input +! integer ,intent(in) :: vegtyp !vegetation type +! real ,intent(in) :: vegfrac !green vegetation fraction [0.0-1.0] +! real ,intent(in) :: apar !photosynthesis active energy by canopy (w/m2) +! real ,intent(in) :: tv !vegetation canopy temperature (k) +! +! output +! real ,intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1] +! +! local variables +! +! real, parameter :: r = 8.314 ! univ. gas constant [j k-1 mol-1] +! real, parameter :: alpha = 0.0027 ! empirical coefficient +! real, parameter :: cl1 = 1.066 ! empirical coefficient +! real, parameter :: ct1 = 95000.0 ! empirical coefficient [j mol-1] +! real, parameter :: ct2 = 230000.0 ! empirical coefficient [j mol-1] +! real, parameter :: ct3 = 0.961 ! empirical coefficient +! real, parameter :: tm = 314.0 ! empirical coefficient [k] +! real, parameter :: tstd = 303.0 ! std temperature [k] +! real, parameter :: bet = 0.09 ! beta empirical coefficient [k-1] +! +! integer ivoc ! do-loop index +! integer ityp ! do-loop index +! real epsilon(5) +! real gamma(5) +! real density +! real elai +! real par,cl,reciprod,ct +! +! epsilon : +! +! do ivoc = 1, 5 +! epsilon(ivoc) = parameters%eps(vegtyp,ivoc) +! end do +! +! gamma : activity factor. units [dimensionless] +! +! reciprod = 1. / (r * tv * tstd) +! ct = exp(ct1 * (tv - tstd) * reciprod) / & +! (ct3 + exp(ct2 * (tv - tm) * reciprod)) +! +! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) +! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) +! +! gamma(1) = cl * ct ! for isoprenes +! +! do ivoc = 2, 5 +! gamma(ivoc) = exp(bet * (tv - tstd)) +! end do +! +! foliage density +! +! transform vegfrac to lai +! +! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) +! density = elai / (parameters%slarea(vegtyp) * 0.5) +! +! calculate the voc flux +! +! do ivoc = 1, 5 +! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density +! end do +! +! end subroutine bvocflux +! ================================================================================================== +! ********************************* end of carbon subroutines ***************************** +! ================================================================================================== + +!== begin noahmp_options =========================================================================== + + subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + implicit none + + integer, intent(in) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + integer, intent(in) :: iopt_crs !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer, intent(in) :: iopt_btr !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer, intent(in) :: iopt_run !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer, intent(in) :: iopt_sfc !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer, intent(in) :: iopt_frz !supercooled liquid water (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_inf !frozen soil permeability (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_rad !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer, intent(in) :: iopt_alb !snow surface albedo (1->bats; 2->class) + integer, intent(in) :: iopt_snf !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer, intent(in) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->noah) + + integer, intent(in) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original noah) + +! ------------------------------------------------------------------------------------------------- + + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + + end subroutine noahmp_options + + +end module module_sf_noahmplsm + diff --git a/physics/module_wrf_utl.f90 b/physics/module_wrf_utl.f90 new file mode 100755 index 000000000..29f8bb9e1 --- /dev/null +++ b/physics/module_wrf_utl.f90 @@ -0,0 +1,50 @@ +module module_wrf_utl + implicit none +contains + +subroutine wrf_error_fatal(string) + implicit none + character(len=*), intent(in) :: string + print*, string + stop +end subroutine wrf_error_fatal + +subroutine wrf_message(msg) + implicit none + character(len=*), intent(in) :: msg + write(*,'(A)') msg +end subroutine wrf_message + +logical function wrf_dm_on_monitor() result (return_value) + implicit none + return_value = .TRUE. +end function wrf_dm_on_monitor + +subroutine wrf_dm_bcast_real(rval, ival) + implicit none + real, intent(in) :: rval + integer, intent(in) :: ival +end subroutine wrf_dm_bcast_real + +subroutine wrf_dm_bcast_integer(ival1, ival2) + implicit none + real, intent(in) :: ival1 + integer, intent(in) :: ival2 +end subroutine wrf_dm_bcast_integer + +subroutine wrf_dm_bcast_string(sval, ival) + implicit none + character(len=*), intent(in) :: sval + integer, intent(in) :: ival +end subroutine wrf_dm_bcast_string + +subroutine wrf_debug( level , str ) + implicit none + character*(*) str + integer , intent (in) :: level + call wrf_message( str ) + return +end subroutine wrf_debug + +end module module_wrf_utl + diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 new file mode 100755 index 000000000..cbad19b4b --- /dev/null +++ b/physics/noahmp_tables.f90 @@ -0,0 +1,955 @@ +module noahmp_tables + + implicit none + + integer :: i + integer, private, parameter :: mvt = 30 ! use 30 instead of 27 + integer, private, parameter :: mband = 2 + integer, private, parameter :: msc = 8 + integer, private, parameter :: max_soiltyp = 30 + integer, private, parameter :: slcats = 30 + real :: slope_table(9) !slope factor for soil drainage + +! crops + + integer, private, parameter :: ncrop = 5 + integer, private, parameter :: nstage = 8 + + +! mptable.tbl vegetation parameters + + integer :: isurban_table = 13 + integer :: iswater_table = 17 + integer :: isbarren_table = 16 + integer :: isice_table = 15 + integer :: eblforest_table = 2 + +! + real :: ch2op_table(mvt) !maximum intercepted h2o per unit lai+sai (mm) + + data ( ch2op_table(i),i=1,mvt) / 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & + & 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & + & 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & + & 0.1, 0.1, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: dleaf_table(mvt) !characteristic leaf dimension (m) + data ( dleaf_table(i),i=1,mvt) / 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & + & 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & + & 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & + & 0.04, 0.04, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: z0mvt_table(mvt) !momentum roughness length (m) + data ( z0mvt_table(i),i=1,mvt) / 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, & + & 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, & + & 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, & + & 0.20, 0.03, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! + + real :: hvt_table(mvt) !top of canopy (m) + data ( hvt_table(i),i=1,mvt) / 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, & + & 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, & + & 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, & + & 2.00, 0.50, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: hvb_table(mvt) !bottom of canopy (m) + data ( hvb_table(i),i=1,mvt) / 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, & + & 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, & + & 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, & + & 0.20, 0.10, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: den_table(mvt) !tree density (no. of trunks per m2) + data ( den_table (i),i=1,mvt) / 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, & + & 10.0, 10.0, 0.02, 100., 5.05, 25.0, & + & 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, & + & 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / +! + real :: rc_table(mvt) !tree crown radius (m) + + data ( rc_table (i),i=1,mvt) / 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, & + & 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, & + & 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, & + & 0.30, 0.30, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: mfsno_table(mvt) !snowmelt curve parameter () + data ( mfsno_table(i),i=1,mvt) / 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, & + & 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, & + & 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, & + & 2.50, 2.50, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! + + real :: saim_table(mvt,12) !monthly stem area index, one-sided + + data (saim_table (i,1),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + +! &_______________________________________________________________________& + + data (saim_table (i,2),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,3),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,4),i=1,mvt) / 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (saim_table (i,5),i=1,mvt) / 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,6),i=1,mvt) / 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, & + & 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, & + & 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,7),i=1,mvt) / 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, & + & 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, & + & 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, & + & 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (saim_table (i,8),i=1,mvt) / 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, & + & 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, & + & 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,9),i=1,mvt) / 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, & + & 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, & + & 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, & + & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,10),i=1,mvt) / 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, & + & 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, & + & 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (saim_table (i,11),i=1,mvt) / 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, & + & 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, & + & 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,12),i=1,mvt) / 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +!! lai + real :: laim_table(mvt,12) !monthly leaf area index, one-sided + + data (laim_table (i,1),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, & + & 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,2),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,3),i=1,mvt) / 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, & + & 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, & + & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,4),i=1,mvt) / 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, & + & 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, & + & 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, & + & 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,5),i=1,mvt) / 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, & + & 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, & + & 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, & + & 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,6),i=1,mvt) / 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, & + & 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, & + & 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, & + & 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,7),i=1,mvt) / 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, & + & 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, & + & 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, & + & 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,8),i=1,mvt) / 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, & + & 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, & + & 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, & + & 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,9),i=1,mvt) / 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, & + & 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, & + & 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, & + & 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,10),i=1,mvt) / 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, & + & 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, & + & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,11),i=1,mvt) / 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,12),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, & + & 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: sla_table(mvt) !single-side leaf area per kg [m2/kg] + data ( sla_table (i),i=1,mvt) / 80, 80, 80, 80, 80, 60, & + & 60, 60, 50, 60, 80, 80, & + & 60, 80, 0, 0, 0, 80, & + & 80, 80, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + real :: dilefc_table(mvt) !coeficient for leaf stress death [1/s] + data (dilefc_table (i),i=1,mvt) / 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, & + & 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, & + & 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, & + & 0.40, 0.30, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: dilefw_table(mvt) !coeficient for leaf stress death [1/s] + data (dilefw_table(i),i=1,mvt) / 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, & + & 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, & + & 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, & + & 0.20, 0.20, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: fragr_table(mvt) !fraction of growth respiration !original was 0.3 + data ( fragr_table(i),i=1,mvt) / 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, & + & 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, & + & 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, & + & 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: ltovrc_table(mvt) !leaf turnover [1/s] + data ( ltovrc_table(i),i=1,mvt) / 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, & + & 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, & + & 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, & + & 1.4, 1.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! + real :: c3psn_table(mvt) !photosynthetic pathway: 0. = c4, 1. = c3 + data ( c3psn_table (i),i=1,mvt) / 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: kc25_table(mvt) !co2 michaelis-menten constant at 25c (pa) + data ( kc25_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & + & 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & + & 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & + & 30.0, 30.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: akc_table(mvt) !q10 for kc25 + data ( akc_table (i),i=1,mvt) / 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & + & 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & + & 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & + & 2.1, 2.1, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + + real :: ko25_table(mvt) !o2 michaelis-menten constant at 25c (pa) + data ( ko25_table (i),i=1,mvt) / 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & + & 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & + & 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & + & 3.e4, 3.e4, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: ako_table(mvt) !q10 for ko25 + data ( ako_table (i),i=1,mvt) / 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & + & 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & + & 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & + & 1.2, 1.2, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: vcmx25_table(mvt) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + data ( vcmx25_table(i),i=1,mvt) / 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, & + & 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, & + & 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, & + & 50.0, 50.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: avcmx_table(mvt) !q10 for vcmx25 + data ( avcmx_table (i),i=1,mvt) / 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & + & 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & + & 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & + & 2.4, 2.4, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + + + real :: bp_table(mvt) !minimum leaf conductance (umol/m**2/s) + data ( bp_table (i),i=1,mvt) / 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, & + & 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, & + & 1.e15, 2.e3,1.e15, 2.e3,1.e15, 2.e3, & + & 2.e3, 2.e3, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: mp_table(mvt) !slope of conductance-to-photosynthesis relationship + data ( mp_table (i),i=1,mvt) / 6., 9., 6., 9., 9., 9., & + & 9., 9., 9., 9., 9., 9., & + & 9., 9., 9., 9., 9., 9., & + & 9., 9., 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: qe25_table(mvt) !quantum efficiency at 25c (umol co2 / umo photon) + data ( qe25_table (i),i=1,mvt) / 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, & + & 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, & + & 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, & + & 0.06, 0.06, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: aqe_table(mvt) !q10 for qe25 + data ( aqe_table (i),i=1,mvt) / 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: rmf25_table(mvt) !leaf maintenance respiration at 25c (umol co2/m**2/s) + data ( rmf25_table (i),i=1,mvt) / 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, & + & 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, & + & 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, & + & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rms25_table(mvt) !stem maintenance respiration at 25c (umol co2/kg bio/s) + data ( rms25_table (i),i=1,mvt) / 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, & + & 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, & + & 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, & + & 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rmr25_table(mvt) !root maintenance respiration at 25c (umol co2/kg bio/s) + data ( rmr25_table (i),i=1,mvt) / 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, & + & 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, & + & 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: arm_table(mvt) !q10 for maintenance respiration + data ( arm_table (i),i=1,mvt) / 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & + & 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & + & 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & + & 2.0, 2.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: folnmx_table(mvt) !foliage nitrogen concentration when f(n)=1 (%) + data (folnmx_table (i),i=1,mvt) / 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, & + & 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, & + & 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, & + & 1.5, 1.5, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: tmin_table(mvt) !minimum temperature for photosynthesis (k) + data ( tmin_table (i),i=1,mvt) / 265, 273, 268, 273, 268, 273, & + & 273, 273, 273, 273, 268, 273, & + & 0, 273, 0, 0, 0, 268, & + & 268, 268, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + +! + real :: xl_table(mvt) !leaf/stem orientation index + data ( xl_table (i),i=1,mvt) / 0.010,0.010,0.010,0.250,0.250,0.010, & + & 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, & + & 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, & + & 0.250, 0.250, 0.000, 0.000, 0.000, 0.000, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / +! + real :: rhol_table(mvt,mband) !leaf reflectance: 1=vis, 2=nir + + data ( rhol_table (i,1),i=1,mvt) / 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, & + & 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, & + & 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, & + & 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! &_______________________________________________________________________& + + data ( rhol_table (i,2),i=1,mvt) / 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, & + & 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, & + & 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, & + & 0.45, 0.45, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rhos_table(mvt,mband) !stem reflectance: 1=vis, 2=nir + + data ( rhos_table (i,1),i=1,mvt) / 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, & + & 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, & + & 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, & + & 0.16,0.16, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + data ( rhos_table (i,2),i=1,mvt) / 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, & + & 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, & + & 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, & + & 0.39, 0.39, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! &_______________________________________________________________________& + + real :: taul_table(mvt,mband) !leaf transmittance: 1=vis, 2=nir +! + data ( taul_table (i,1),i=1,mvt) / 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, & + & 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, & + & 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, & + & 0.05, 0.05,0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + data ( taul_table (i,2),i=1,mvt) / 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, & + & 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, & + & 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, & + & 0.25, 0.25, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: taus_table(mvt,mband) !stem transmittance: 1=vis, 2=nir + data(taus_table (i,1),i=1,mvt) / 0.001,0.001,0.001,0.001,0.001, 0.001, & + & 0.001, 0.001, 0.001, 0.220, 0.1105,0.220, & + & 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / + + + data(taus_table (i,2),i=1,mvt) / 0.001,0.001,0.001,0.001,0.001, 0.001, & + & 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, & + & 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / + + + real :: mrp_table(mvt) !microbial respiration parameter (umol co2 /kg c/ s) + data ( mrp_table (i),i=1,mvt) / 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, & + & 0.19, 0.19, 0.40, 0.17,0.285, 0.23, & + & 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, & + & 0.20, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! + real :: cwpvt_table(mvt) !empirical canopy wind parameter + data ( cwpvt_table (i),i=1,mvt) / 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, & + & 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, & + & 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, & + & 0.18, 0.18, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: wrrat_table(mvt) !wood to non-wood ratio + data ( wrrat_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, & + & 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, & + & 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: wdpool_table(mvt) !wood pool (switch 1 or 0) depending on woody or not [-] + data ( wdpool_table(i),i=1,mvt) / 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, & + & 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, & + & 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: tdlef_table(mvt) !characteristic t for leaf freezing [k] + data ( tdlef_table (i),i=1,mvt) / 278, 278, 268, 278, 268, 278, & + & 278, 278, 278, 278, 268, 278, & + & 278, 278, 0, 0, 0, 268, & + & 268, 268, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + + real :: nroot_table(mvt) !number of soil layers with root present + data ( nroot_table (i),i=1,mvt) / 4, 4, 4, 4, 4, 3, & + & 3, 3, 3, 3, 2, 3, & + & 1, 3, 1, 1, 0, 3, & + & 3, 2, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + real :: rgl_table(mvt) !parameter used in radiation stress function + data ( rgl_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 100.0,& + & 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, & + & 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, & + & 100.0, 100.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rs_table(mvt) !minimum stomatal resistance [s m-1] + data ( rs_table (i),i=1,mvt) / 125.0, 150.0,150.0,100.0,125.0,300.0,& + & 170.0,300.0, 70.0, 40.0, 70.0, 40.0, & + & 200.0, 40.0, 999.0,999.0,100.0,150.0, & + & 150.0, 200.0,0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: hs_table(mvt) !parameter used in vapor pressure deficit function + data ( hs_table (i),i=1,mvt) / 47.35,41.69,47.35,54.53,51.93,42.00, & + & 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, & + & 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, & + & 42.00, 42.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: topt_table(mvt) !optimum transpiration air temperature [k] + data ( topt_table (i),i=1,mvt) / 298.0,298.0,298.0,298.0,298.0,298.0, & + & 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, & + & 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, & + & 298.0, 298.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rsmax_table(mvt) !maximal stomatal resistance [s m-1] + data ( rsmax_table (i),i=1,mvt) / 5000., 5000.,5000.,5000.,5000.,5000.,& + & 5000., 5000., 5000., 5000., 5000., 5000., & + & 5000., 5000., 5000., 5000., 5000., 5000., & + & 5000., 5000., 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +!!!!!!!!!!!!!! Wield not defined but read !!!!!!!!!!!!!!!!1 + + real :: slarea_table(mvt) + + data (slarea_table (i),i=1,mvt) / 0.0090,0.0200,0.0200,0.0258,0.0223, & + & 0.0227, 0.0188, 0.0227, 0.0236, 0.0060, & + & 0.0295, 0.0200, 0.0228, 0.0223, 0.02, & + & 0.02, 0.0422, 0.02, 0.02, 0.02, & + & 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + real :: esp1_table(mvt) + + data (esp1_table (i),i=1,mvt) / 0.46, 0.00, 0.00,46.86,30.98, 21.62, & + & 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, & + & 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, & + & 0.0, 0.0,0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: esp2_table(mvt) + + data (esp2_table (i),i=1,mvt) / 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, & + & 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, & + & 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + + real :: esp3_table(mvt) + + data (esp3_table (i),i=1,mvt) / 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, & + & 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, & + & 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + +! &_______________________________________________________________________& + + real :: esp4_table(mvt) + + data (esp4_table (i),i=1,mvt) / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + real :: esp5_table(mvt) + + data (esp5_table (i),i=1,mvt) / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +!!!!!!!!!!!!!!!!!!! what are the tables used for !!!!!!!!!!!!!! + +! soilparm.tbl parameters + + real :: bexp_table(max_soiltyp) + + data (bexp_table(i), i=1,slcats) /2.79, 4.26, 4.74, 5.33, 5.33, 5.25,& + & 6.77, 8.72, 8.17, 10.73, 10.39, 11.55, & + & 5.25, 0.0, 2.79, 4.26, 11.55, 2.79, & + & 2.79, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: smcdry_table(max_soiltyp) + data (smcdry_table(i), i=1,slcats) /0.010, 0.028, 0.047, 0.084, 0.084,& + & 0.066, 0.067, 0.120, 0.103, 0.100, 0.126, 0.138, & + & 0.066, 0.0, 0.006, 0.028, 0.030, 0.006, & + & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: f1_table(max_soiltyp) + + data (f1_table(i), i=1,slcats) /-0.472, -1.044, -0.569, 0.162, 0.162, & + & -0.327, -1.491, -1.118, -1.297, -3.209, -1.916, -2.138, & + & -0.327, 0.000, -1.111, -1.044, -10.472, -0.472, & + & -0.472, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: smcmax_table(max_soiltyp) + + data (smcmax_table(i), i=1,slcats) /0.339, 0.421, 0.434, 0.476, 0.476,& + & 0.439, 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, & + & 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, & + & 0.339, 0.339, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: smcref_table(max_soiltyp) + + data (smcref_table(i), i=1,slcats) /0.236, 0.383, 0.383, 0.360, 0.383, & + & 0.329, 0.314, 0.387, 0.382, 0.338, 0.404, 0.412, & + & 0.329, 0.000, 0.170, 0.283, 0.454, 0.170, & + & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: psisat_table(max_soiltyp) + + data (psisat_table(i), i=1,slcats) /0.069, 0.036, 0.141, 0.759, 0.759, & + & 0.355, 0.135, 0.617, 0.263, 0.098, 0.324, 0.468, & + & 0.355, 0.00, 0.069, 0.036, 0.468, 0.069, & + & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: dksat_table(max_soiltyp) + + data (dksat_table(i), i=1,slcats) /4.66e-5, 1.41e-5, 5.23e-6, 2.81e-6, & + & 2.81e-6, 3.38e-6, 4.45e-6, 2.03e-6, 2.45e-6,7.22e-6, & + & 1.34e-6, 9.74e-7, 3.38e-6, 0.00, 1.41e-4, & + & 1.41e-5, 9.74e-7, 1.41e-4, 4.66e-5,0.0, & + & 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: dwsat_table(max_soiltyp) + + data (dwsat_table(i), i=1,slcats) /0.608e-6, 0.514e-5, 0.805e-5, & + & 0.239e-4, 0.239e-4,0.143e-4, 0.99e-5, 0.237e-4, 0.113e-4, 0.187e-4, & + & 0.964e-5, 0.112e-4,0.143e-4,0.00, 0.136e-3, 0.514e-5, & + & 0.112e-4, 0.136e-3, 0.608e-6, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: smcwlt_table(max_soiltyp) + + data (smcwlt_table(i), i=1,slcats) /0.010, 0.028, 0.047, 0.084, 0.084,& + & 0.066, 0.067, 0.120, 0.103, 0.100, 0.126, 0.138, & + & 0.066, 0.00, 0.006, 0.028, 0.03, 0.006, & + & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: quartz_table(max_soiltyp) + + data (quartz_table(i), i=1,slcats) /0.92, 0.82, 0.60, 0.25, 0.10, & + & 0.40, 0.60, 0.10, 0.35, 0.52, 0.10, & + & 0.25, 0.05, 0.60, 0.07, 0.25, 0.60, & + & 0.52, 0.92, 0.00, 0.00, 0.00, 0.00,0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + +! genparm.tbl parameters + + data (slope_table(i), i=1,9) /0.1, 0.6, 1.0, 0.35, 0.55, 0.8, & + & 0.63, 0.0, 0.0 / + + real :: csoil_table = 2.00e+6 !soil heat capacity [j m-3 k-1] + real :: refdk_table = 2.0e-6 !parameter in the surface runoff parameterization + real :: refkdt_table = 3.0 !parameter in the surface runoff parameterization + real :: frzk_table =0.15 !frozen ground parameter + real :: zbot_table = -8.0 !depth [m] of lower boundary soil temperature + real :: czil_table = 0.075 !parameter used in the calculation of the roughness length for heat + +! mptable.tbl radiation parameters + +! &_______________________________________________________________________& + real :: albsat_table(msc,mband) !saturated soil albedos: 1=vis, 2=nir + data(albsat_table(i,1),i=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ + data(albsat_table(i,2),i=1,8)/0.30,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ + + real :: albdry_table(msc,mband) !dry soil albedos: 1=vis, 2=nir + data(albdry_table(i,1),i=1,8)/0.27,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ + data(albdry_table(i,2),i=1,8)/0.54,0.44,0.40,0.36,0.32,0.28,0.24,0.20/ + + real :: albice_table(mband) !albedo land ice: 1=vis, 2=nir + data (albice_table(i),i=1,mband) /0.80, 0.55/ + + real :: alblak_table(mband) !albedo frozen lakes: 1=vis, 2=nir + data (alblak_table(i),i=1,mband) /0.60, 0.40/ + + real :: omegas_table(mband) !two-stream parameter omega for snow + data (omegas_table(i),i=1,mband) /0.8, 0.4/ + + real :: betads_table = 0.5 !two-stream parameter betad for snow + real :: betais_table = 0.5 !two-stream parameter betad for snow + + real :: eg_table(2) !emissivity + data eg_table /0.97, 0.98 / + + real :: betads, betais + data betads, betais /0.5, 0.5/ + + +! mptable.tbl global parameters + + real :: co2_table = 395.e-06 !co2 partial pressure + real :: o2_table = 0.209 !o2 partial pressure + real :: timean_table = 10.5 !gridcell mean topgraphic index (global mean) + real :: fsatmx_table = 0.38 !maximum surface saturated fraction (global mean) + real :: z0sno_table = 0.002 !snow surface roughness length (m) (0.002) + real :: ssi_table = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + real :: swemx_table = 1.00 !new snow mass to fully cover old snow (mm) + real :: rsurf_snow_table = 50.0 !surface resistance for snow(s/m) + + +! Noah mp crops +! mptable.tbl crop parameters +! ! NCROP = 5 +! 1: Corn +! 2: Soybean +! 3: Sorghum +! 4: Rice +! 5: Winter wheat + + +! &_______________________________________________________________________& + integer :: pltday_table(ncrop) ! planting date + data (pltday_table(i), i=1,5) /130,111,111,111,111/ + + integer :: hsday_table(ncrop) ! harvest date + data (hsday_table(i),i=1,5) /280,300,300,300,300/ + + real :: plantpop_table(ncrop) ! plant density [per ha] - used? + data (plantpop_table(i),i=1,5) /78.0,78.0,78.0,78.0,78.0/ + + real :: irri_table(ncrop) ! irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + data (irri_table(i),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: gddtbase_table(ncrop) ! base temperature for gdd accumulation [c] + data (gddtbase_table(i),i=1,5) /10.0,10.0,10.0,10.0,10.0/ + + real :: gddtcut_table(ncrop) ! upper temperature for gdd accumulation [c] + data (gddtcut_table(i),i=1,5) /30.0,30.0,30.0,30.0,30.0/ + + real :: gdds1_table(ncrop) ! gdd from seeding to emergence + data (gdds1_table(i),i=1,5) /60.0,50.0,50.0,50.0,50.0/ + + real :: gdds2_table(ncrop) ! gdd from seeding to initial vegetative + data (gdds2_table(i),i=1,5) /675.0,718.0,718.0,718.0,718.0/ + + real :: gdds3_table(ncrop) ! gdd from seeding to post vegetative + data (gdds3_table(i),i=1,5) /1183.0,933.0,933.0,933.0,933.0/ + + real :: gdds4_table(ncrop) ! gdd from seeding to intial reproductive + data (gdds4_table(i),i=1,5) /1253.0,1103.0,1103.0,1103.0,1103.0/ + + real :: gdds5_table(ncrop) ! gdd from seeding to pysical maturity + data (gdds5_table(i),i=1,5) /1605.0,1555.0,1555.0,1555.0,1555.0/ + + integer :: c3c4_table(ncrop) ! photosynthetic pathway: 1. = c3 2. = c4 + data (c3c4_table(i),i=1,5) /2.0,1.0,2.0,2.0,2.0/ + + real :: aref_table(ncrop) ! reference maximum co2 assimulation rate + data (aref_table(i),i=1,5) /7.0,7.0,7.0,7.0,7.0/ + + real :: psnrf_table(ncrop) ! co2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + data (psnrf_table(i),i=1,5) /0.85,0.85,0.85,0.85,0.85/ + + real :: i2par_table(ncrop) ! fraction of incoming solar radiation to photosynthetically active radiation + data (i2par_table(i),i=1,5) / 0.5,0.5,0.5,0.5,0.5/ + + real :: tassim0_table(ncrop) ! minimum temperature for co2 assimulation [c] + data (tassim0_table(i),i=1,5) /8.0,8.0,8.0,8.0,8.0/ + + real :: tassim1_table(ncrop) ! co2 assimulation linearly increasing until temperature reaches t1 [c] + data (tassim1_table(i),i=1,5) /18.0,18.0,18.0,18.0,18.0/ + + real :: tassim2_table(ncrop) ! co2 assmilation rate remain at aref until temperature reaches t2 [c] + data (tassim2_table(i),i=1,5) /30.0,30.0,30.0,30.0,30.0/ + + real :: k_table(ncrop) ! light extinction coefficient + data ( k_table(i),i=1,5) /0.55,0.55,0.55,0.55,0.55/ + + real :: epsi_table(ncrop) ! initial light use efficiency + data (epsi_table(i),i=1,5) /12.5,12.5,12.5,12.5,12.5/ + + real :: q10mr_table(ncrop) ! q10 for maintainance respiration + data (q10mr_table(i),i=1,5) /2.0,2.0,2.0,2.0,2.0/ + + real :: foln_mx_table(ncrop) ! foliage nitrogen concentration when f(n)=1 (%) + data (foln_mx_table(i),i=1,5) /1.5,1.5,1.5,1.5,1.5/ + + real :: lefreez_table(ncrop) ! characteristic t for leaf freezing [k] + data (lefreez_table(i),i=1,5) /268,268,268,268,268/ + + + real :: dile_fc_table(ncrop,nstage) ! coeficient for temperature leaf stress death [1/s] + data (dile_fc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,5),i=1,5) /0.5,0.5,0.5,0.5,0.5/ + data (dile_fc_table(i,6),i=1,5) /0.5,0.5,0.5,0.5,0.5/ + data (dile_fc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: dile_fw_table(ncrop,nstage) ! coeficient for water leaf stress death [1/s] + data (dile_fw_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,5),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (dile_fw_table(i,6),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (dile_fw_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: fra_gr_table(ncrop) ! fraction of growth respiration + data (fra_gr_table(i),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + + real :: lf_ovrc_table(ncrop,nstage) ! fraction of leaf turnover [1/s] + data (lf_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,5),i=1,5) /0.2,0.48,0.48,0.48,0.48/ + data (lf_ovrc_table(i,6),i=1,5) /0.3,0.48,0.48,0.48,0.48/ + data (lf_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: st_ovrc_table(ncrop,nstage) ! fraction of stem turnover [1/s] + data (st_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,5),i=1,5) /0.12,0.12,0.12,0.12,0.12/ + data (st_ovrc_table(i,6),i=1,5) /0.06,0.06,0.06,0.06,0.06/ + data (st_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: rt_ovrc_table(ncrop,nstage) ! fraction of root tunrover [1/s] + data (rt_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,5),i=1,5) /0.12,0.12,0.12,0.12,0.12/ + data (rt_ovrc_table(i,6),i=1,5) /0.06,0.06,0.06,0.06,0.06/ + data (rt_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: lfmr25_table(ncrop) ! leaf maintenance respiration at 25c [umol co2/m**2 /s] + data (lfmr25_table(i),i=1,5) /1.0,1.0,1.0,1.0,1.0/ + + real :: stmr25_table(ncrop) ! stem maintenance respiration at 25c [umol co2/kg bio/s] + data (stmr25_table(i),i=1,5) /0.05,0.1,0.1,0.1,0.1/ + + real :: rtmr25_table(ncrop) ! root maintenance respiration at 25c [umol co2/kg bio/s] + data (rtmr25_table(i),i=1,5) /0.05,0.0,0.0,0.0,0.0/ + + real :: grainmr25_table(ncrop) ! grain maintenance respiration at 25c [umol co2/kg bio/s] + data (grainmr25_table(i),i=1,5) /0.0,0.1,0.1,0.1,0.1/ + + real :: lfpt_table(ncrop,nstage) ! fraction of carbohydrate flux to leaf + data (lfpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,3),i=1,5) /0.4,0.4,0.4,0.4,0.4/ + data (lfpt_table(i,4),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (lfpt_table(i,5),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,6),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + + real :: stpt_table(ncrop,nstage) ! fraction of carbohydrate flux to stem + data (stpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (stpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (stpt_table(i,3),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (stpt_table(i,4),i=1,5) /0.5,0.5,0.5,0.5,0.5/ + data (stpt_table(i,5),i=1,5) /0.0,0.15,0.15,0.15,0.15/ + data (stpt_table(i,6),i=1,5) /0.0,0.05,0.05,0.05,0.05/ + data (stpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (stpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + + real :: rtpt_table(ncrop,nstage) ! fraction of carbohydrate flux to root + data (rtpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rtpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rtpt_table(i,3),i=1,5) /0.34,0.4,0.4,0.4,0.4/ + data (rtpt_table(i,4),i=1,5) /0.3,0.3,0.3,0.3,0.3/ + data (rtpt_table(i,5),i=1,5) /0.05,0.05,0.05,0.05,0.05/ + data (rtpt_table(i,6),i=1,5) /0.0,0.05,0.05,0.05,0.05/ + data (rtpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rtpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: grainpt_table(ncrop,nstage) ! fraction of carbohydrate flux to grain + data (grainpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,5),i=1,5) /0.95,0.8,0.8,0.8,0.8/ + data (grainpt_table(i,6),i=1,5) /1.0,0.9,0.9,0.9,0.9/ + data (grainpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: bio2lai_table(ncrop) ! leaf are per living leaf biomass [m^2/kg] + data (bio2lai_table(i),i=1,5) /0.035,0.015,0.015,0.015,0.015/ + +end module noahmp_tables + diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f new file mode 100755 index 000000000..8d12d8fa4 --- /dev/null +++ b/physics/sfc_noahmp_drv.f @@ -0,0 +1,1142 @@ +!----------------------------------- + subroutine noahmpdrv & +!................................... +! --- inputs: + & ( im, km,itime,ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, & + & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & + & prsl1, prslki, zf, dry, ddvel, slopetyp, & + & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & + & idveg,iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & + & iopt_inf,iopt_rad, iopt_alb, iopt_snf,iopt_tbot,iopt_stc, & + & xlatin,xcoszin, iyrlen, julian, & + & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp, & + +! --- in/outs: + & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & + & canopy, trans, tsurf,zorl, & + +! --- Noah MP specific + + & snowxy, tvxy, tgxy, canicexy,canliqxy, eahxy,tahxy,cmxy, & + & chxy, fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, & + & zwtxy, waxy, wtxy, tsnoxy,zsnsoxy, snicexy, snliqxy, & + & lfmassxy, rtmassxy,stmassxy, woodxy, stblcpxy, fastcpxy, & + & xlaixy,xsaixy,taussxy,smoiseq,smcwtdxy,deeprechxy,rechxy, & + +! --- outputs: + & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & + & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & + & smcwlt2, smcref2,wet1,t2mmp,q2mp) +! +! + use machine , only : kind_phys +! use date_def, only : idate + use funcphys, only : fpvs + use physcons, only : con_g, con_hvap, con_cp, con_jcal, & + & con_eps, con_epsm1, con_fvirt, con_rd,con_hfus + + use module_sf_noahmplsm + use module_sf_noahmp_glacier + use noahmp_tables, only : isice_table, co2_table, o2_table, & + & isurban_table,smcref_table,smcdry_table, & + & smcmax_table,co2_table,o2_table, & + & saim_table,laim_table + + implicit none + +! --- constant parameters: + + real(kind=kind_phys), parameter :: cpinv = 1.0/con_cp + real(kind=kind_phys), parameter :: hvapi = 1.0/con_hvap + real(kind=kind_phys), parameter :: elocp = con_hvap/con_cp + real(kind=kind_phys), parameter :: rhoh2o = 1000.0 + real(kind=kind_phys), parameter :: convrad = con_jcal*1.e4/60.0 + real(kind=kind_phys), parameter :: a2 = 17.2693882 + real(kind=kind_phys), parameter :: a3 = 273.16 + real(kind=kind_phys), parameter :: a4 = 35.86 + real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) +! +! --- +! + + real, parameter :: undefined = -1.e36 + + real :: dz8w = undefined + real :: dx = undefined + real :: qc = undefined + real :: foln = 1.0 ! foliage + integer :: nsoil = 4 ! hardwired to Noah + integer :: nsnow = 3 ! max. snow layers + integer :: ist = 1 ! soil type, 1 soil; 2 lake; 14 is water + integer :: isc = 4 ! middle day soil color: soil 1-9 lightest + + real(kind=kind_phys), save :: zsoil(4),sldpth(4) + data zsoil / -0.1, -0.4, -1.0, -2.0 / + data sldpth /0.1, 0.3, 0.6, 1.0 / +! data dzs /0.1, 0.3, 0.6, 1.0 / + +! +! --- input: +! + + integer, intent(in) :: im, km, itime + + integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp + + real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & + & ch, prsl1, prslki, ddvel, shdmin, shdmax, & + & snoalb, sfalb, zf, & + & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp + + logical, dimension(im), intent(in) :: dry + + real (kind=kind_phys),dimension(im),intent(in) :: xlatin,xcoszin + + integer, intent(in) :: idveg, iopt_crs,iopt_btr,iopt_run, & + & iopt_sfc,iopt_frz,iopt_inf,iopt_rad, & + & iopt_alb,iopt_snf,iopt_tbot,iopt_stc + + real (kind=kind_phys), intent(in) :: julian + integer, intent(in) :: iyrlen + + + real (kind=kind_phys), intent(in) :: delt + logical, dimension(im), intent(in) :: flag_iter, flag_guess + +! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf,zorl + + real (kind=kind_phys), dimension(im,km), intent(inout) :: & + & smc, stc, slc + + real (kind=kind_phys), dimension(im), intent(inout) :: snowxy, & + & tvxy,tgxy,canicexy,canliqxy,eahxy,tahxy, & + & cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy, & + & wslakexy,zwtxy,waxy,wtxy,lfmassxy,rtmassxy, & + & stmassxy,woodxy,stblcpxy,fastcpxy,xlaixy, & + & xsaixy,taussxy,smcwtdxy,deeprechxy,rechxy + + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: tsnoxy + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: snicexy + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: snliqxy + real (kind=kind_phys),dimension(im,1:4), intent(inout) :: smoiseq + real (kind=kind_phys),dimension(im,-2:4),intent(inout) :: zsnsoxy + + integer, dimension(im) :: jsnowxy + real (kind=kind_phys),dimension(im) :: snodep + real (kind=kind_phys),dimension(im,-2:4) :: tsnsoxy + +! --- output: + + real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & + & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1, & + & t2mmp,q2mp + +! --- locals: + real (kind=kind_phys), dimension(im) :: rch, rho, & + & q0, qs1, theta1, tv1, wind, weasd_old, snwdph_old, & + & tprcp_old, srflag_old, tskin_old, canopy_old + + real (kind=kind_phys), dimension(km) :: et,stsoil,smsoil, slsoil + + real (kind=kind_phys),dimension(im,km) :: smc_old,stc_old,slc_old + + real (kind=kind_phys), dimension(im) :: snow_old, tv_old,tg_old, & + & canice_old,canliq_old,eah_old,tah_old,fwet_old,sneqvo_old, & + & albold_old,qsnow_old,wslake_old,zwt_old,wa_old,wt_old, & + & lfmass_old,rtmass_old,stmass_old,wood_old,stblcp_old, & + & fastcp_old,xlai_old,xsai_old,tauss_old,smcwtd_old, & + & deeprech_old,rech_old + + real(kind=kind_phys),dimension(im,1:4) :: smoiseq_old + real(kind=kind_phys),dimension(im,-2:0) :: tsno_old + real(kind=kind_phys),dimension(im,-2:0) :: snice_old + real(kind=kind_phys),dimension(im,-2:0) :: snliq_old + real(kind=kind_phys),dimension(im,-2:4) :: zsnso_old + real(kind=kind_phys),dimension(im,-2:4) :: tsnso_old + + + real (kind=kind_phys) :: alb, albedo, beta, chx, cmx, cmc, & + & dew, drip, dqsdt2, ec, edir, ett, eta, esnow, etp, & + & flx1, flx2, flx3, ffrozp, lwdn, pc, prcp, ptu, q2, & + & q2sat, solnet, rc, rcs, rct, rcq, rcsoil, rsmin, & + & runoff1, runoff2, runoff3, sfcspd, sfcprs, sfctmp, & + & sfcems, sheat, shdfac, shdmin1d, shdmax1d, smcwlt, & + & smcdry, smcref, smcmax, sneqv, snoalb1d, snowh, & + & snomlt, sncovr, soilw, soilm, ssoil, tsea, th2, & + & xlai, zlvl, swdn, tem, psfc,fdown,t2v,tbot + + real (kind=kind_phys) :: pconv,pnonc,pshcv,psnow,pgrpl,phail + real (kind=kind_phys) :: lat,cosz,uu,vv,swe + integer :: isnowx + + real (kind=kind_phys) :: tvx,tgx,canicex,canliqx,eahx, & + & tahx,fwetx,sneqvox,alboldx,qsnowx,wslakex,zwtx, & + & wax,wtx,lfmassx, rtmassx,stmassx, woodx,stblcpx, & + & fastcpx,xlaix,xsaix,taussx,smcwtdx,deeprechx,rechx, & + & qsfc1d + + real (kind=kind_phys), dimension(-2:0) :: tsnox, snicex, snliqx + real (kind=kind_phys), dimension(-2:0) :: ficeold + real (kind=kind_phys), dimension( km ) :: smoiseqx + real (kind=kind_phys), dimension(-2:4) :: zsnsox + real (kind=kind_phys), dimension(-2:4) :: tsnsox + + real (kind=kind_phys) :: z0wrf,fsa,fsr,fira,fsh,fcev,fgev, & + & fctr,ecan,etran,trad,tgb,tgv,t2mv, & + & t2mb,q2v,q2b,runsrf,runsub,apar, & + & psn,sav,sag,fsno,nee,gpp,npp,fveg, & + & qsnbot,ponding,ponding1,ponding2, & + & rssun,rssha,bgap,wgap,chv,chb,emissi, & + & shg,shc,shb,evg,evb,ghv,ghb,irg,irc, & + & irb,tr,evc,chleaf,chuc,chv2,chb2, & + & fpice,pahv,pahg,pahb,pah,co2pp,o2pp,ch2b + + integer :: i, k, ice, stype, vtype ,slope,nroot,couple + logical :: flag(im) + logical :: snowng,frzgra + + type(noahmp_parameters) :: parameters + +! +!===> ... begin here +! + +! --- ... set flag for land points + + do i = 1, im + flag(i) = dry(i) + enddo + +! --- ... save land-related prognostic fields for guess run + + do i = 1, im + if (flag(i) .and. flag_guess(i)) then + weasd_old(i) = weasd(i) + snwdph_old(i) = snwdph(i) + tskin_old(i) = tskin(i) + canopy_old(i) = canopy(i) + tprcp_old(i) = tprcp(i) + srflag_old(i) = srflag(i) +! +! + snow_old(i) = snowxy(i) + tv_old(i) = tvxy(i) + tg_old(i) = tgxy(i) + canice_old(i) = canicexy(i) + canliq_old(i) = canliqxy(i) + eah_old(i) = eahxy(i) + tah_old(i) = tahxy(i) + fwet_old(i) = fwetxy(i) + sneqvo_old(i) = sneqvoxy(i) + albold_old(i) = alboldxy(i) + qsnow_old(i) = qsnowxy(i) + wslake_old(i) = wslakexy(i) + zwt_old(i) = zwtxy(i) + wa_old(i) = waxy(i) + wt_old(i) = wtxy(i) + lfmass_old(i) = lfmassxy(i) + rtmass_old(i) = rtmassxy(i) + stmass_old(i) = stmassxy(i) + wood_old(i) = woodxy(i) + stblcp_old(i) = stblcpxy(i) + fastcp_old(i) = fastcpxy(i) + xlai_old(i) = xlaixy(i) + xsai_old(i) = xsaixy(i) + tauss_old(i) = taussxy(i) + smcwtd_old(i) = smcwtdxy(i) + rech_old(i) = rechxy(i) + + deeprech_old(i) = deeprechxy(i) +! + do k = 1, km + smc_old(i,k) = smc(i,k) + stc_old(i,k) = stc(i,k) + slc_old(i,k) = slc(i,k) + enddo + +! + do k = 1, km + smoiseq_old(i,k) = smoiseq(i,k) + enddo + + do k = -2,0 + tsno_old(i,k) = tsnoxy(i,k) + snice_old(i,k) = snicexy(i,k) + snliq_old(i,k) = snliqxy(i,k) + enddo + + do k = -2,4 + zsnso_old (i,k) = zsnsoxy(i,k) + enddo + + endif + enddo + +! +! call to init MP options +! +! &_________________________________________________________________ & + +! --- ... initialization block + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + ep(i) = 0.0 + evap (i) = 0.0 + hflx (i) = 0.0 + gflux(i) = 0.0 + drain(i) = 0.0 + canopy(i) = max(canopy(i), 0.0) + + evbs (i) = 0.0 + evcw (i) = 0.0 + trans(i) = 0.0 + sbsno(i) = 0.0 + snowc(i) = 0.0 + snohf(i) = 0.0 + endif + enddo + +! --- ... initialize variables + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + wind(i) = sqrt( u1(i)*u1(i) + v1(i)*v1(i) ) & + & + max(0.0, min(ddvel(i), 30.0)) + wind(i) = max(wind(i), 1.0) + + q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) + + tv1(i) = t1(i) * (1.0 + con_fvirt*q0(i)) + rho(i) = prsl1(i) / (con_rd * tv1(i)) + qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) + qs1(i) = con_eps*qs1(i) / (prsl1(i) + con_epsm1*qs1(i)) + qs1(i) = max(qs1(i), 1.e-8) + q0 (i) = min(qs1(i), q0(i)) + + if (vegtype(i) == isice_table ) then + if (weasd(i) < 0.1) then + weasd(i) = 0.1 + endif + endif + + endif + enddo + +! --- ... noah: prepare variables to run noah lsm +! 1. configuration information (c): +! ------------------------------ +! couple - couple-uncouple flag (=1: coupled, =0: uncoupled) +! ffrozp - fraction for snow-rain (1.=snow, 0.=rain, 0-1 mixed)) +! ice - sea-ice flag (=1: sea-ice, =0: land) +! dt - timestep (sec) (dt should not exceed 3600 secs) = delt +! zlvl - height (m) above ground of atmospheric forcing variables +! nsoil - number of soil layers (at least 2) +! sldpth - the thickness of each soil layer (m) + + do i = 1, im + + if (flag_iter(i) .and. flag(i)) then + + + couple = 1 + + ice = 0 + nsoil = km + snowng = .false. + frzgra = .false. + + +! if (srflag(i) == 1.0) then ! snow phase +! ffrozp = 1.0 +! elseif (srflag(i) == 0.0) then ! rain phase +! ffrozp = 0.0 +! endif +! use srflag directly to allow fractional rain/snow + ffrozp = srflag(i) + + zlvl = zf(i) + +! 2. forcing data (f): +! ----------------- +! lwdn - lw dw radiation flux (w/m2) +! solnet - net sw radiation flux (dn-up) (w/m2) +! sfcprs - pressure at height zlvl above ground (pascals) +! prcp - precip rate (kg m-2 s-1) +! sfctmp - air temperature (k) at height zlvl above ground +! th2 - air potential temperature (k) at height zlvl above ground +! q2 - mixing ratio at height zlvl above ground (kg kg-1) + + lat = xlatin(i) ! in radian + cosz = xcoszin(i) + + lwdn = dlwflx(i) !..downward lw flux at sfc in w/m2 + swdn = dswsfc(i) !..downward sw flux at sfc in w/m2 + solnet = snet(i) !..net sw rad flx (dn-up) at sfc in w/m2 + sfcems = sfcemis(i) + + sfctmp = t1(i) + sfcprs = prsl1(i) + psfc = ps(i) + prcp = rhoh2o * tprcp(i) / delt + + if (prcp > 0.0) then + if (ffrozp > 0.0) then ! rain/snow flag, one condition is enough? + snowng = .true. + qsnowxy(i) = ffrozp * prcp/10.0 !still use rho water? + else + if (sfctmp <= 275.15) frzgra = .true. + endif + endif + + th2 = theta1(i) + q2 = q0(i) + +! 3. other forcing (input) data (i): +! ------------------------------ +! sfcspd - wind speed (m s-1) at height zlvl above ground +! q2sat - sat mixing ratio at height zlvl above ground (kg kg-1) +! dqsdt2 - slope of sat specific humidity curve at t=sfctmp (kg kg-1 k-1) + + uu = u1(i) + vv = v1(i) + + sfcspd = wind(i) + q2sat = qs1(i) + dqsdt2 = q2sat * a23m4/(sfctmp-a4)**2 + +! 4. canopy/soil characteristics (s): +! -------------------------------- +! vegtyp - vegetation type (integer index) -> vtype +! soiltyp - soil type (integer index) -> stype +! slopetyp- class of sfc slope (integer index) -> slope +! shdfac - areal fractional coverage of green vegetation (0.0-1.0) +! shdmin - minimum areal fractional coverage of green vegetation -> shdmin1d +! ptu - photo thermal unit (plant phenology for annuals/crops) +! alb - backround snow-free surface albedo (fraction) +! snoalb - upper bound on maximum albedo over deep snow -> snoalb1d +! tbot - bottom soil temperature (local yearly-mean sfc air temp) + + vtype = vegtype(i) + stype = soiltyp(i) + slope = slopetyp(i) + shdfac= sigmaf(i) + + shdmin1d = shdmin(i) + shdmax1d = shdmax(i) + snoalb1d = snoalb(i) + + alb = sfalb(i) + + tbot = tg3(i) + ptu = 0.0 + + + cmc = canopy(i)/1000. ! convert from mm to m + tsea = tsurf(i) ! clu_q2m_iter + + snowh = snwdph(i) * 0.001 ! convert from mm to m + sneqv = weasd(i) * 0.001 ! convert from mm to m + + + +! 5. history (state) variables (h): +! ------------------------------ +! cmc - canopy moisture content (m) +! t1 - ground/canopy/snowpack) effective skin temperature (k) -> tsea +! stc(nsoil) - soil temp (k) -> stsoil +! smc(nsoil) - total soil moisture content (volumetric fraction) -> smsoil +! sh2o(nsoil)- unfrozen soil moisture content (volumetric fraction) -> slsoil +! snowh - actual snow depth (m) +! sneqv - liquid water-equivalent snow depth (m) +! albedo - surface albedo including snow effect (unitless fraction) +! ch - surface exchange coefficient for heat and moisture (m s-1) -> chx +! cm - surface exchange coefficient for momentum (m s-1) -> cmx + + isnowx = nint(snowxy(i)) + tvx = tvxy(i) + tgx = tgxy(i) + canliqx = canliqxy(i) !in mm + canicex = canicexy(i) + + eahxy(i) = (ps(i)*q2)/(0.622+q2) ! use q0 to reinit; + eahx = eahxy(i) + tahx = tahxy(i) + + co2pp = co2_table * sfcprs + o2pp = o2_table * sfcprs + fwetx = fwetxy(i) + + sneqvox = sneqvoxy(i) + alboldx = alboldxy(i) + + qsnowx = qsnowxy(i) + wslakex = wslakexy(i) + + zwtx = zwtxy(i) + wax = waxy(i) + wtx = waxy(i) + + do k = -2,0 + tsnsoxy(i,k) = tsnoxy(i,k) + enddo + + do k = 1,4 + tsnsoxy(i,k) = stc(i,k) + enddo + + do k = -2,0 + snicex(k) = snicexy(i,k) ! in k/m3; mm + snliqx(k) = snliqxy(i,k) ! in k/m3; mm + tsnox (k) = tsnoxy(i,k) + + ficeold(k) = 0.0 ! derived + + if (snicex(k) > 0.0 ) then + ficeold(k) = snicex(k) /(snicex(k)+snliqx(k)) + + endif + enddo + + do k = -2, km + zsnsox(k) = zsnsoxy(i,k) + tsnsox(k) = tsnsoxy(i,k) + enddo + + lfmassx = lfmassxy(i) + rtmassx = rtmassxy(i) + stmassx = stmassxy(i) + + woodx = woodxy(i) + stblcpx = stblcpxy(i) + fastcpx = fastcpxy(i) + + xsaix = xsaixy(i) + xlaix = xlaixy(i) + + taussx = taussxy(i) + + qsfc1d = undefined ! derive later, it is an in/out? + swe = weasd(i) + + do k = 1, km + smoiseqx(k) = smoiseq(i,k) + enddo + + smcwtdx = smcwtdxy(i) + rechx = rechxy(i) + deeprechx = deeprechxy(i) +!-- +! the optional details for precip +!-- + +! pconv = 0. ! convective - may introduce later +! pnonc = (1 - ffrozp) * prcp ! large scale total in mm/s; +! pshcv = 0. +! psnow = ffrozp * prcp /10.0 ! snow = qsnowx? +! pgrpl = 0. +! phail = 0. + pnonc = rainn_mp(i) + pconv = rainc_mp(i) + pshcv = 0. + psnow = snow_mp(i) + pgrpl = graupel_mp(i) + phail = ice_mp(i) +! +!-- old +! + do k = 1, km +! stsoil(k) = stc(i,k) + smsoil(k) = smc(i,k) + slsoil(k) = slc(i,k) + enddo + + snowh = snwdph(i) * 0.001 ! convert from mm to m + + if (swe /= 0.0 .and. snowh == 0.0) then + snowh = 10.0 * swe /1000.0 + endif + + chx = chxy(i) ! maybe chxy + cmx = cmxy(i) + + chh(i) = ch(i) * wind(i) * rho(i) + cmm(i) = cm(i) * wind(i) + + + + call transfer_mp_parameters(vtype,stype,slope,isc,parameters) + + call noahmp_options(idveg ,iopt_crs,iopt_btr,iopt_run,iopt_sfc, & + & iopt_frz,iopt_inf,iopt_rad,iopt_alb,iopt_snf,iopt_tbot,iopt_stc) + + + if ( vtype == isice_table ) then + + ice = -1 + tbot = min(tbot,263.15) + + call noahmp_options_glacier & + & (idveg ,iopt_crs ,iopt_btr, iopt_run ,iopt_sfc ,iopt_frz, & + & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + call noahmp_glacier ( & + & i ,1 ,cosz ,nsnow ,nsoil ,delt , & ! in : time/space/model-related + & sfctmp ,sfcprs ,uu ,vv ,q2 ,swdn , & ! in : forcing + & prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing + & qsnowx ,sneqvox ,alboldx ,cmx ,chx ,isnowx, & ! in/out :sneqvox + alboldx -LST + & swe ,smsoil ,zsnsox ,snowh ,snicex ,snliqx , & ! in/out : sneqvx + snowhx are avgd + & tgx ,tsnsox ,slsoil ,taussx ,qsfc1d , & ! in/out : + & fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : + & trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : albedo is surface albedo + & qsnbot ,ponding ,ponding1,ponding2,t2mb ,q2b , & ! out : + & emissi ,fpice ,ch2b ,esnow ) + +! +! in/out and outs +! + + fsno = 1.0 + + tvx = undefined + canicex = undefined + canliqx = undefined + eahx = undefined + tahx = undefined + + fwetx = undefined + wslakex = undefined + zwtx = undefined + wax = undefined + wtx = undefined + + lfmassx = undefined + rtmassx = undefined + stmassx = undefined + woodx = undefined + stblcpx = undefined + fastcpx = undefined + xlaix = undefined + xsaix = undefined + + smcwtdx = 0.0 + rechx = 0.0 + deeprechx = 0.0 + + do k = 1,4 + smoiseqx(k) = smsoil(k) + enddo + + fctr = undefined + fcev = undefined + + z0wrf = 0.002 + + eta = fgev + t2mmp(i) = t2mb + q2mp(i) = q2b +! +! Non-glacial case +! + else + ice = 0 + +! write(*,*)'tsnsox(1)=',tsnsox,'tgx=',tgx + call noahmp_sflx (parameters ,& + & i , 1 , lat , iyrlen , julian , cosz ,& ! in : time/space-related + & delt , dx , dz8w , nsoil , zsoil , nsnow ,& ! in : model configuration + & shdfac , shdmax1d, vtype , ice , ist ,& ! in : vegetation/soil + & smoiseqx ,& ! in + & sfctmp , sfcprs , psfc , uu , vv , q2 ,& ! in : forcing + & qc , swdn , lwdn ,& ! in : forcing + & pconv , pnonc , pshcv , psnow , pgrpl , phail ,& ! in : forcing + & tbot , co2pp , o2pp , foln , ficeold , zlvl ,& ! in : forcing + & alboldx , sneqvox ,& ! in/out : + & tsnsox , slsoil , smsoil , tahx , eahx , fwetx ,& ! in/out : + & canliqx , canicex , tvx , tgx , qsfc1d , qsnowx ,& ! in/out : + & isnowx , zsnsox , snowh , swe , snicex , snliqx ,& ! in/out : + & zwtx , wax , wtx , wslakex , lfmassx , rtmassx,& ! in/out : + & stmassx , woodx , stblcpx , fastcpx , xlaix ,xsaix ,& ! in/out : + & cmx , chx , taussx ,& ! in/out : + & smcwtdx ,deeprechx, rechx ,& ! in/out : + & z0wrf ,& ! out + & fsa , fsr , fira , fsh , ssoil , fcev ,& ! out : + & fgev , fctr , ecan , etran , edir , trad ,& ! out : + & tgb , tgv , t2mv , t2mb , q2v , q2b ,& ! out : + & runsrf , runsub , apar , psn , sav , sag ,& ! out : + & fsno , nee , gpp , npp , fveg , albedo ,& ! out : + & qsnbot , ponding , ponding1, ponding2, rssun , rssha ,& ! out : + & bgap , wgap , chv , chb , emissi ,& ! out : + & shg , shc , shb , evg , evb , ghv ,&! out : + & ghb , irg , irc , irb , tr , evc ,& ! out : + & chleaf , chuc , chv2 , chb2 , fpice , pahv ,& ! out + & pahg , pahb , pah , esnow ) + + + eta = fcev + fgev + fctr ! the flux w/m2 + + t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) + q2mp(i) = q2v*fveg+q2b*(1-fveg) + + endif ! glacial split ends + +! +! mp in/out +! + snowxy (i) = float(isnowx) + tvxy (i) = tvx + tgxy (i) = tgx + canliqxy (i) = canliqx + canicexy (i) = canicex + eahxy (i) = eahx + tahxy (i) = tahx + + cmxy (i) = cmx + chxy (i) = chx + + fwetxy (i) = fwetx + sneqvoxy (i) = sneqvox + alboldxy (i) = alboldx + qsnowxy (i) = qsnowx + + wslakexy (i) = wslakex + zwtxy (i) = zwtx + waxy (i) = wax + wtxy (i) = wtx + + do k = -2,0 + tsnoxy (i,k) = tsnsox(k) + snicexy (i,k) = snicex (k) + snliqxy (i,k) = snliqx (k) + enddo + + do k = -2,4 + zsnsoxy (i,k) = zsnsox(k) + enddo + + lfmassxy (i) = lfmassx + rtmassxy (i) = rtmassx + stmassxy (i) = stmassx + woodxy (i) = woodx + stblcpxy (i) = stblcpx + fastcpxy (i) = fastcpx + + xlaixy (i) = xlaix + xsaixy (i) = xsaix + + taussxy (i) = taussx + + rechxy (i) = rechx + deeprechxy(i) = deeprechx + smcwtdxy(i) = smcwtdx + smoiseq(i,1:4) = smoiseqx(1:4) + +! +! generic in/outs +! + do k = 1, km + stc(i,k) = tsnsox(k) + smc(i,k) = smsoil(k) + slc(i,k) = slsoil(k) + enddo + + canopy(i) = canicex + canliqx + weasd(i) = swe + snwdph(i) = snowh * 1000.0 + +! write(*,*) 'swe,snowh,can' +! write (*,*) swe,snowh*1000.0,canopy(i) +! + smcmax = smcmax_table(stype) + smcref = smcref_table(stype) + smcwlt = smcdry_table(stype) +! +! outs +! + wet1(i) = smsoil(1) / smcmax + smcwlt2(i) = smcwlt + smcref2(i) = smcref + + runoff(i) = runsrf + drain(i) = runsub + + zorl(i) = z0wrf * 100.0 + + sncovr1(i) = fsno + snowc (i) = fsno + + sbsno(i) = esnow + gflux(i) = -1.0*ssoil + hflx(i) = fsh + evbs(i) = fgev + evcw(i) = fcev + trans(i) = fctr + evap(i) = eta + +! write(*,*) 'vtype, stype are',vtype,stype +! write(*,*) 'fsh,gflx,eta',fsh,ssoil,eta +! write(*,*) 'esnow,runsrf,runsub',esnow,runsrf,runsub +! write(*,*) 'evbs,evcw,trans',fgev,fcev,fctr +! write(*,*) 'snowc',fsno + + tsurf(i) = trad + + stm(i) = 0.1*smsoil(1)+0.3*smsoil(2)+0.6*smsoil(3)+ & + & 1.0*smsoil(4) +! + snohf (i) = qsnbot * con_hfus ! only part of it but is diagnostic +! write(*,*) 'snohf',snohf(i) + + fdown = fsa + lwdn + t2v = sfctmp * (1.0 + 0.61*q2) +! ssoil = -1.0 *ssoil + + call penman (sfctmp,sfcprs,chx,t2v,th2,prcp,fdown,ssoil, & + & q2,q2sat,etp,snowng,frzgra,ffrozp,dqsdt2,emissi,fsno) + + ep(i) = etp + + endif ! end if_flag_iter_and_flag_block + enddo ! end do_i_loop + +! --- ... compute qsurf (specific humidity at sfc) + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + rch(i) = rho(i) * con_cp * ch(i) * wind(i) + qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo + +! --- ... restore land-related prognostic fields for guess run + + do i = 1, im + if (flag(i)) then + if (flag_guess(i)) then + weasd(i) = weasd_old(i) + snwdph(i) = snwdph_old(i) + tskin(i) = tskin_old(i) + canopy(i) = canopy_old(i) + tprcp(i) = tprcp_old(i) + srflag(i) = srflag_old(i) + + + snowxy(i) = snow_old(i) + tvxy(i) = tv_old(i) + tgxy(i) = tg_old(i) + + canicexy(i) = canice_old(i) + canliqxy(i) = canliq_old(i) + eahxy(i) = eah_old(i) + tahxy(i) = tah_old(i) + fwetxy(i) = fwet_old(i) + sneqvoxy(i) = sneqvo_old(i) + alboldxy(i) = albold_old(i) + qsnowxy(i) = qsnow_old(i) + wslakexy(i) = wslake_old(i) + zwtxy(i) = zwt_old(i) + waxy(i) = wa_old(i) + wtxy(i) = wt_old(i) + lfmassxy(i) = lfmass_old(i) + rtmassxy(i) = rtmass_old(i) + stmassxy(i) = stmass_old(i) + woodxy(i) = wood_old(i) + stblcpxy(i) = stblcp_old(i) + fastcpxy(i) = fastcp_old(i) + xlaixy(i) = xlai_old(i) + xsaixy(i) = xsai_old(i) + taussxy(i) = tauss_old(i) + smcwtdxy(i) = smcwtd_old(i) + deeprechxy(i) = deeprech_old(i) + rechxy(i) = rech_old(i) + + do k = 1, km + smc(i,k) = smc_old(i,k) + stc(i,k) = stc_old(i,k) + slc(i,k) = slc_old(i,k) + enddo +! + do k = 1, km + smoiseq(i,k) = smoiseq_old(i,k) + enddo + + do k = -2,0 + tsnoxy(i,k) = tsno_old(i,k) + snicexy(i,k) = snice_old(i,k) + snliqxy(i,k) = snliq_old(i,k) + enddo + + do k = -2,4 + zsnsoxy(i,k) = zsnso_old(i,k) + enddo + else + tskin(i) = tsurf(i) + endif + endif + enddo +! + return +!................................... + end subroutine noahmpdrv +!----------------------------------- + + subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & + & soilcolor,parameters) + + use noahmp_tables + use module_sf_noahmplsm + + implicit none + + integer, intent(in) :: vegtype + integer, intent(in) :: soiltype + integer, intent(in) :: slopetype + integer, intent(in) :: soilcolor + + type (noahmp_parameters), intent(out) :: parameters + + real :: refdk + real :: refkdt + real :: frzk + real :: frzfact + + parameters%iswater = iswater_table + parameters%isbarren = isbarren_table + parameters%isice = isice_table + parameters%eblforest = eblforest_table + +!-----------------------------------------------------------------------& + parameters%urban_flag = .false. + if( vegtype == isurban_table .or. vegtype == 31 & + & .or.vegtype == 32 .or. vegtype == 33) then + parameters%urban_flag = .true. + endif + +!------------------------------------------------------------------------------------------! +! transfer veg parameters +!------------------------------------------------------------------------------------------! + + parameters%ch2op = ch2op_table(vegtype) !maximum intercepted h2o per unit lai+sai (mm) + parameters%dleaf = dleaf_table(vegtype) !characteristic leaf dimension (m) + parameters%z0mvt = z0mvt_table(vegtype) !momentum roughness length (m) + parameters%hvt = hvt_table(vegtype) !top of canopy (m) + parameters%hvb = hvb_table(vegtype) !bottom of canopy (m) + parameters%den = den_table(vegtype) !tree density (no. of trunks per m2) + parameters%rc = rc_table(vegtype) !tree crown radius (m) + parameters%mfsno = mfsno_table(vegtype) !snowmelt m parameter () + parameters%saim = saim_table(vegtype,:) !monthly stem area index, one-sided + parameters%laim = laim_table(vegtype,:) !monthly leaf area index, one-sided + parameters%sla = sla_table(vegtype) !single-side leaf area per kg [m2/kg] + parameters%dilefc = dilefc_table(vegtype) !coeficient for leaf stress death [1/s] + parameters%dilefw = dilefw_table(vegtype) !coeficient for leaf stress death [1/s] + parameters%fragr = fragr_table(vegtype) !fraction of growth respiration !original was 0.3 + parameters%ltovrc = ltovrc_table(vegtype) !leaf turnover [1/s] + + parameters%c3psn = c3psn_table(vegtype) !photosynthetic pathway: 0. = c4, 1. = c3 + parameters%kc25 = kc25_table(vegtype) !co2 michaelis-menten constant at 25c (pa) + parameters%akc = akc_table(vegtype) !q10 for kc25 + parameters%ko25 = ko25_table(vegtype) !o2 michaelis-menten constant at 25c (pa) + parameters%ako = ako_table(vegtype) !q10 for ko25 + parameters%vcmx25 = vcmx25_table(vegtype) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + parameters%avcmx = avcmx_table(vegtype) !q10 for vcmx25 + parameters%bp = bp_table(vegtype) !minimum leaf conductance (umol/m**2/s) + parameters%mp = mp_table(vegtype) !slope of conductance-to-photosynthesis relationship + parameters%qe25 = qe25_table(vegtype) !quantum efficiency at 25c (umol co2 / umol photon) + parameters%aqe = aqe_table(vegtype) !q10 for qe25 + parameters%rmf25 = rmf25_table(vegtype) !leaf maintenance respiration at 25c (umol co2/m**2/s) + parameters%rms25 = rms25_table(vegtype) !stem maintenance respiration at 25c (umol co2/kg bio/s) + parameters%rmr25 = rmr25_table(vegtype) !root maintenance respiration at 25c (umol co2/kg bio/s) + parameters%arm = arm_table(vegtype) !q10 for maintenance respiration + parameters%folnmx = folnmx_table(vegtype) !foliage nitrogen concentration when f(n)=1 (%) + parameters%tmin = tmin_table(vegtype) !minimum temperature for photosynthesis (k) + + parameters%xl = xl_table(vegtype) !leaf/stem orientation index + parameters%rhol = rhol_table(vegtype,:) !leaf reflectance: 1=vis, 2=nir + parameters%rhos = rhos_table(vegtype,:) !stem reflectance: 1=vis, 2=nir + parameters%taul = taul_table(vegtype,:) !leaf transmittance: 1=vis, 2=nir + parameters%taus = taus_table(vegtype,:) !stem transmittance: 1=vis, 2=nir + + parameters%mrp = mrp_table(vegtype) !microbial respiration parameter (umol co2 /kg c/ s) + parameters%cwpvt = cwpvt_table(vegtype) !empirical canopy wind parameter + + parameters%wrrat = wrrat_table(vegtype) !wood to non-wood ratio + parameters%wdpool = wdpool_table(vegtype) !wood pool (switch 1 or 0) depending on woody or not [-] + parameters%tdlef = tdlef_table(vegtype) !characteristic t for leaf freezing [k] + + parameters%nroot = nroot_table(vegtype) !number of soil layers with root present + parameters%rgl = rgl_table(vegtype) !parameter used in radiation stress function + parameters%rsmin = rs_table(vegtype) !minimum stomatal resistance [s m-1] + parameters%hs = hs_table(vegtype) !parameter used in vapor pressure deficit function + parameters%topt = topt_table(vegtype) !optimum transpiration air temperature [k] + parameters%rsmax = rsmax_table(vegtype) !maximal stomatal resistance [s m-1] + +!------------------------------------------------------------------------------------------! +! transfer rad parameters +!------------------------------------------------------------------------------------------! + + parameters%albsat = albsat_table(soilcolor,:) + parameters%albdry = albdry_table(soilcolor,:) + parameters%albice = albice_table + parameters%alblak = alblak_table + parameters%omegas = omegas_table + parameters%betads = betads_table + parameters%betais = betais_table + parameters%eg = eg_table + +!------------------------------------------------------------------------------------------! +! transfer global parameters +!------------------------------------------------------------------------------------------! + + parameters%co2 = co2_table + parameters%o2 = o2_table + parameters%timean = timean_table + parameters%fsatmx = fsatmx_table + parameters%z0sno = z0sno_table + parameters%ssi = ssi_table + parameters%swemx = swemx_table + +! ---------------------------------------------------------------------- +! transfer soil parameters +! ---------------------------------------------------------------------- + + parameters%bexp = bexp_table (soiltype) + parameters%dksat = dksat_table (soiltype) + parameters%dwsat = dwsat_table (soiltype) + parameters%f1 = f1_table (soiltype) + parameters%psisat = psisat_table (soiltype) + parameters%quartz = quartz_table (soiltype) + parameters%smcdry = smcdry_table (soiltype) + parameters%smcmax = smcmax_table (soiltype) + parameters%smcref = smcref_table (soiltype) + parameters%smcwlt = smcwlt_table (soiltype) + +! ---------------------------------------------------------------------- +! transfer genparm parameters +! ---------------------------------------------------------------------- + parameters%csoil = csoil_table + parameters%zbot = zbot_table + parameters%czil = czil_table + + frzk = frzk_table + refdk = refdk_table + refkdt = refkdt_table + parameters%kdt = refkdt * parameters%dksat / refdk + parameters%slope = slope_table(slopetype) + + if(parameters%urban_flag)then ! hardcoding some urban parameters for soil + parameters%smcmax = 0.45 + parameters%smcref = 0.42 + parameters%smcwlt = 0.40 + parameters%smcdry = 0.40 + parameters%csoil = 3.e6 + endif + + ! adjust frzk parameter to actual soil type: frzk * frzfact + +!-----------------------------------------------------------------------& + if(soiltype /= 14) then + frzfact = (parameters%smcmax / parameters%smcref) & + & * (0.412 / 0.468) + parameters%frzx = frzk * frzfact + end if + + end subroutine transfer_mp_parameters + +!-----------------------------------------------------------------------& + + + subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & + & q2,q2sat,etp,snowng,frzgra,ffrozp, & + & dqsdt2,emissi_in,sncovr) + +! etp is calcuated right after ssoil + +! ---------------------------------------------------------------------- +! subroutine penman +! ---------------------------------------------------------------------- +! calculate potential evaporation for the current point. various +! partial sums/products are also calculated and passed back to the +! calling routine for later use. +! ---------------------------------------------------------------------- + implicit none + logical, intent(in) :: snowng, frzgra + real, intent(in) :: ch, dqsdt2,fdown,prcp,ffrozp, & + & q2, q2sat,ssoil, sfcprs, sfctmp, & + & t2v, th2,emissi_in,sncovr + real, intent(out) :: etp + real :: epsca,flx2,rch,rr,t24 + real :: a, delta, fnet,rad,rho,emissi,elcp1,lvs + + real, parameter :: elcp = 2.4888e+3, lsubc = 2.501000e+6,cp = 1004.6 + real, parameter :: lsubs = 2.83e+6, rd = 287.05, cph2o = 4.1855e+3 + real, parameter :: cpice = 2.106e+3, lsubf = 3.335e5 + real, parameter :: sigma = 5.6704e-8 + +! ---------------------------------------------------------------------- +! executable code begins here: +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! prepare partial quantities for penman equation. +! ---------------------------------------------------------------------- + emissi=emissi_in +! elcp1 = (1.0-sncovr)*elcp + sncovr*elcp*lsubs/lsubc + lvs = (1.0-sncovr)*lsubc + sncovr*lsubs + + flx2 = 0.0 + delta = elcp * dqsdt2 +! delta = elcp1 * dqsdt2 + t24 = sfctmp * sfctmp * sfctmp * sfctmp + rr = t24 * 6.48e-8 / (sfcprs * ch) + 1.0 +! rr = emissi*t24 * 6.48e-8 / (sfcprs * ch) + 1.0 + rho = sfcprs / (rd * t2v) + +! ---------------------------------------------------------------------- +! adjust the partial sums / products with the latent heat +! effects caused by falling precipitation. +! ---------------------------------------------------------------------- + rch = rho * cp * ch + if (.not. snowng) then + if (prcp > 0.0) rr = rr + cph2o * prcp / rch + else +! ---- ... fractional snowfall/rainfall + rr = rr + (cpice*ffrozp+cph2o*(1.-ffrozp)) & + & *prcp/rch + end if + +! ---------------------------------------------------------------------- +! include the latent heat effects of frzng rain converting to ice on +! impact in the calculation of flx2 and fnet. +! ---------------------------------------------------------------------- +! fnet = fdown - sigma * t24- ssoil + fnet = fdown - emissi*sigma * t24- ssoil + if (frzgra) then + flx2 = - lsubf * prcp + fnet = fnet - flx2 +! ---------------------------------------------------------------------- +! finish penman equation calculations. +! ---------------------------------------------------------------------- + end if + rad = fnet / rch + th2- sfctmp + a = elcp * (q2sat - q2) +! a = elcp1 * (q2sat - q2) + epsca = (a * rr + rad * delta) / (delta + rr) + etp = epsca * rch / lsubc +! etp = epsca * rch / lvs + +! ---------------------------------------------------------------------- + end subroutine penman + + diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta new file mode 100644 index 000000000..257963b31 --- /dev/null +++ b/physics/sfc_noahmp_drv.meta @@ -0,0 +1,1069 @@ +[ccpp-arg-table] + name = lsm_noahmp_run + type = scheme +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[itime] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ps] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[u1] + standard_name = x_wind_at_lowest_model_layer + long_name = zonal wind at lowest model layer + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind_at_lowest_model_layer + long_name = meridional wind at lowest model layer + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = mean temperature at lowest model layer + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = water vapor specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent= in + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent= in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[sfcemis] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[dlwflx] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground + long_name = total sky surface downward longwave flux absorbed by the ground + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[dswsfc] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[snet] + standard_name = surface_net_downwelling_shortwave_flux + long_name = surface net downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[delt] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tg3] + standard_name = deep_soil_temperature + long_name = deep soil temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = mean pressure at lowest model layer + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[ddvel] + standard_name = surface_wind_enhancement_due_to_convection + long_name = surface wind enhancement due to convection + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[slopetyp] + standard_name = surface_slope_classification + long_name = surface slope type at each grid cell + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[shdmin] + standard_name = minimum_vegetation_area_fraction + long_name = min fractional coverage of green vegetation + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractional coverage of green vegetation + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snoalb] + standard_name = upper_bound_on_max_albedo_over_deep_snow + long_name = maximum snow albedo + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfalb] + standard_name = surface_diffused_shortwave_albedo + long_name = mean surface diffused sw albedo + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[idveg] + standard_name = flag_for_dynamic_vegetation_option + long_name = choice for dynamic vegetation option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_crs] + standard_name = flag_for_canopy_stomatal_resistance_option + long_name = choice for canopy stomatal resistance option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_btr] + standard_name = flag_for_soil_moisture_factor_stomatal_resistance_option + long_name = choice for soil moisture factor for canopy stomatal resistance option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_run] + standard_name = flag_for_runoff_and_groundwater_option + long_name = choice for runoff and groundwater option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_sfc] + standard_name = flag_for_surface_layer_drag_coefficient_option + long_name = choice for surface layer drag coefficient option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_frz] + standard_name = flag_for_supercooled_liquid_water_option + long_name = choice for supercooled liquid water option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_inf] + standard_name = flag_for_frozen_soil_permeability_option + long_name = choice for frozen soil permeability option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_rad] + standard_name = flag_for_radiation_transfer_option + long_name = choice for radiation transfer option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_alb] + standard_name = flag_for_ground_snow_surface_albedo_option + long_name = choice for ground snow surface albedo option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_snf] + standard_name = flag_for_precipitation_partition_option + long_name = choice for precipitation partition option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_tbot] + standard_name = flag_for_lower_boundary_soil_temperature_option + long_name = choice for lower boundary soil temperature option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_stc] + standard_name = flag_for_soil_and_snow_temperature_time_stepping_option + long_name = choice for soil and snow temperature time stepping option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = latitude + units = radians + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[xcosz] + standard_name = instantaneous_cosine_of_zenith_angle + long_name = cosine of zenith angle at current time + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[iyrlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = in + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rainn_mp] + standard_name = explicit_rainfall_rate_from_previous_timestep + long_name = explicit rainfall rate previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rainc_mp] + standard_name = convective_precipitation_rate_from_previous_timestep + long_name = convective precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snow_mp] + standard_name = snow_precipitation_rate_from_previous_timestep + long_name = snow precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[graupel_mp] + standard_name = graupel_precipitation_rate_from_previous_timestep + long_name = graupel precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ice_mp] + standard_name = ice_precipitation_rate_from_previous_timestep + long_name = ice precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tskin] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[srflag] + standard_name = flag_for_precipitation_type + long_name = snow/rain flag for precipitation + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = total soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canopy] + standard_name = canopy_water_amount + long_name = canopy water amount + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[trans] + standard_name = transpiration_flux + long_name = total plant transpiration rate + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snowxy] + standard_name = number_of_snow_layers + long_name = number of snow layers + units = count + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tvxy] + standard_name = vegetation_temperature + long_name = vegetation temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tgxy] + standard_name = ground_temperature_for_noahmp + long_name = ground temperature for noahmp + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canicexy] + standard_name = canopy_intercepted_ice_mass + long_name = canopy intercepted ice mass + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canliqxy] + standard_name = canopy_intercepted_liquid_water + long_name = canopy intercepted liquid water + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[eahxy] + standard_name = canopy_air_vapor_pressure + long_name = canopy air vapor pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tahxy] + standard_name = canopy_air_temperature + long_name = canopy air temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cmxy] + standard_name = surface_drag_coefficient_for_momentum_for_noahmp + long_name = surface drag coefficient for momentum for noahmp + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chxy] + standard_name = surface_drag_coefficient_for_heat_and_moisture_for_noahmp + long_name = surface exchange coeff heat & moisture for noahmp + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fwetxy] + standard_name = area_fraction_of_wet_canopy + long_name = area fraction of canopy that is wetted/snowed + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sneqvoxy] + standard_name = snow_mass_at_previous_time_step + long_name = snow mass at previous time step + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[alboldxy] + standard_name = snow_albedo_at_previous_time_step + long_name = snow albedo at previous time step + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qsnowxy] + standard_name = snow_precipitation_rate_at_surface + long_name = snow precipitation rate at surface + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wslakexy] + standard_name = lake_water_storage + long_name = lake water storage + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[zwtxy] + standard_name = water_table_depth + long_name = water table depth + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[waxy] + standard_name = water_storage_in_aquifer + long_name = water storage in aquifer + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wtxy] + standard_name = water_storage_in_aquifer_and_saturated_soil + long_name = water storage in aquifer and saturated soil + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsnoxy] + standard_name = snow_temperature + long_name = snow_temperature + units = K + dimensions = (horizontal_dimension, -2:0) + type = real + kind = kind_phys + intent = inout + optional = F +[zsnsoxy] + standard_name = layer_bottom_depth_from_snow_surface + long_name = depth from the top of the snow surface at the bottom of the layer + units = m + dimensions = (horizontal_dimension, -2:4) + type = real + kind = kind_phys + intent = inout + optional = F +[snicexy] + standard_name = snow_layer_ice + long_name = snow_layer_ice + units = mm + dimensions = (horizontal_dimension, -2:0) + type = real + kind = kind_phys + intent = inout + optional = F +[snliqxy] + standard_name = snow_layer_liquid_water + long_name = snow layer liquid water + units = mm + dimensions = (horizontal_dimension, -2:0) + type = real + kind = kind_phys + intent = inout + optional = F +[lfmassxy] + standard_name = leaf_mass + long_name = leaf mass + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rtmassxy] + standard_name = fine_root_mass + long_name = fine root mass + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stmassxy] + standard_name = stem_mass + long_name = stem mass + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[woodxy] + standard_name = wood_mass + long_name = wood mass including woody roots + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stblcpxy] + standard_name = slow_soil_pool_mass_content_of_carbon + long_name = stable carbon in deep soil + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fastcpxy] + standard_name = fast_soil_pool_mass_content_of_carbon + long_name = short-lived carbon in shallow soil + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[xlaixy] + standard_name = leaf_area_index + long_name = leaf area index + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[xsaixy] + standard_name = stem_area_index + long_name = stem area index + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[taussxy] + standard_name = nondimensional_snow_age + long_name = non-dimensional snow age + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smoiseq] + standard_name = equilibrium_soil_water_content + long_name = equilibrium soil water content + units = m3 m-3 + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwtdxy] + standard_name = soil_water_content_between_soil_bottom_and_water_table + long_name = soil water content between the bottom of the soil and the water table + units = m3 m-3 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[deeprechxy] + standard_name = water_table_recharge_when_deep + long_name = recharge to or from the water table when deep + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rechxy] + standard_name = water_table_recharge_when_shallow + long_name = recharge to or from the water table when shallow + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sncovr1] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[qsurf] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gflux] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[runoff] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land + long_name = momentum exchange coefficient over land + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land + long_name = thermal exchange coefficient over land + units = kg m-2 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[evbs] + standard_name = soil_upward_latent_heat_flux + long_name = soil upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[evcw] + standard_name = canopy_upward_latent_heat_flux + long_name = canopy upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[sbsno] + standard_name = snow_deposition_sublimation_upward_latent_heat_flux + long_name = latent heat flux from snow depo/subl + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[snowc] + standard_name = surface_snow_area_fraction + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[stm] + standard_name = soil_moisture_content + long_name = soil moisture + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = wilting point (volumetric) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[smcref2] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold (volumetric) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[wet1] + standard_name = normalized_soil_wetness + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[t2mmp] + standard_name = temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[q2mp] + standard_name = specific_humidity_at_2m + long_name = 2 meter specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From 6236796165e63dd851f13ba6cfea970e120f6d0d Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 20 Aug 2019 14:34:57 -0600 Subject: [PATCH 02/59] put sfc_noahmp_drv.f in module; add init/finalize + meta file html breadcrumb --- physics/sfc_noahmp_drv.f | 29 ++++++++++++++++++++++++++--- physics/sfc_noahmp_drv.meta | 6 +++--- 2 files changed, 29 insertions(+), 6 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 8d12d8fa4..f12d9df06 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -1,5 +1,28 @@ +!> \file sfc_noahmp_drv.f +!! This file contains the NoahMP land surface scheme driver. + +!> This module contains the CCPP-compliant NoahMP land surface scheme driver. + module noahmpdrv + + implicit none + + private + + public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_finalize + + contains + + subroutine noahmpdrv_init + end subroutine noahmpdrv_init + + subroutine noahmpdrv_finalize + end subroutine noahmpdrv_finalize + +!> \section arg_table_noahmpdrv_run Argument Table +!! \htmlinclude noahmpdrv_run.html +!! !----------------------------------- - subroutine noahmpdrv & + subroutine noahmpdrv_run & !................................... ! --- inputs: & ( im, km,itime,ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, & @@ -890,7 +913,7 @@ subroutine noahmpdrv & ! return !................................... - end subroutine noahmpdrv + end subroutine noahmpdrv_run !----------------------------------- subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & @@ -1139,4 +1162,4 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! ---------------------------------------------------------------------- end subroutine penman - +end module noahmpdrv diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 257963b31..f9b199f79 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -522,7 +522,7 @@ [canopy] standard_name = canopy_water_amount long_name = canopy water amount - units = mm + units = kg m-2 dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -891,7 +891,7 @@ [drain] standard_name = subsurface_runoff_flux long_name = subsurface runoff flux - units = mm s-1 + units = kg m-2 s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -927,7 +927,7 @@ [runoff] standard_name = surface_runoff_flux long_name = surface runoff flux - units = mm s-1 + units = kg m-2 s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys From 747c5a4dde4af16761316355b6ae96e42ab3a5d2 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 21 Aug 2019 15:25:52 -0600 Subject: [PATCH 03/59] fix soil_moisture_content unit error --- physics/sfc_noahmp_drv.f | 6 +++--- physics/sfc_noahmp_drv.meta | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index f12d9df06..bdda3f947 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -809,8 +809,8 @@ subroutine noahmpdrv_run & tsurf(i) = trad - stm(i) = 0.1*smsoil(1)+0.3*smsoil(2)+0.6*smsoil(3)+ & - & 1.0*smsoil(4) + stm(i) = (0.1*smsoil(1)+0.3*smsoil(2)+0.6*smsoil(3)+ & + & 1.0*smsoil(4))*1000.0 ! unit conversion from m to kg m-2 ! snohf (i) = qsnbot * con_hfus ! only part of it but is diagnostic ! write(*,*) 'snohf',snohf(i) @@ -1162,4 +1162,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_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index f9b199f79..6667c7196 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -1,5 +1,5 @@ [ccpp-arg-table] - name = lsm_noahmp_run + name = noahmpdrv_run type = scheme [im] standard_name = horizontal_dimension @@ -990,7 +990,7 @@ [stm] standard_name = soil_moisture_content long_name = soil moisture - units = m + units = kg m-2 dimensions = (horizontal_dimension) type = real kind = kind_phys From aa5aec76500a6a3923b04a4530e27659ec81d3a8 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 21 Aug 2019 16:32:38 -0600 Subject: [PATCH 04/59] add CCPP error variables to sfc_noahmp_drv.f and fix local name error in meta file --- physics/sfc_noahmp_drv.f | 36 ++++++++++++++++++++++-------------- physics/sfc_noahmp_drv.meta | 4 ++-- 2 files changed, 24 insertions(+), 16 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index bdda3f947..26bdf6043 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -25,31 +25,31 @@ end subroutine noahmpdrv_finalize subroutine noahmpdrv_run & !................................... ! --- inputs: - & ( im, km,itime,ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, & - & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & + & ( im, km, itime, ps, u1, v1, t1, q1, soiltyp, vegtype, & + & sigmaf, sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & & prsl1, prslki, zf, dry, ddvel, slopetyp, & & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & - & idveg,iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & - & iopt_inf,iopt_rad, iopt_alb, iopt_snf,iopt_tbot,iopt_stc, & - & xlatin,xcoszin, iyrlen, julian, & - & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp, & + & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & + & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & + & iopt_stc, xlatin, xcoszin, iyrlen, julian, & + & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - & canopy, trans, tsurf,zorl, & + & canopy, trans, tsurf, zorl, & ! --- Noah MP specific - & snowxy, tvxy, tgxy, canicexy,canliqxy, eahxy,tahxy,cmxy, & - & chxy, fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, & - & zwtxy, waxy, wtxy, tsnoxy,zsnsoxy, snicexy, snliqxy, & - & lfmassxy, rtmassxy,stmassxy, woodxy, stblcpxy, fastcpxy, & - & xlaixy,xsaixy,taussxy,smoiseq,smcwtdxy,deeprechxy,rechxy, & + & snowxy, tvxy, tgxy, canicexy, canliqxy, eahxy, tahxy, cmxy,& + & chxy, fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, zwtxy,& + & waxy, wtxy, tsnoxy, zsnsoxy, snicexy, snliqxy, lfmassxy, & + & rtmassxy, stmassxy, woodxy, stblcpxy, fastcpxy, xlaixy, & + & xsaixy, taussxy, smoiseq, smcwtdxy, deeprechxy, rechxy, & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2,wet1,t2mmp,q2mp) + & smcwlt2, smcref2, wet1, t2mmp, q2mp, errmsg, errflg) ! ! use machine , only : kind_phys @@ -157,7 +157,11 @@ subroutine noahmpdrv_run & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1, & & t2mmp,q2mp - + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & & q0, qs1, theta1, tv1, wind, weasd_old, snwdph_old, & @@ -228,6 +232,10 @@ subroutine noahmpdrv_run & !===> ... begin here ! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... set flag for land points do i = 1, im diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 6667c7196..c84998cad 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -367,7 +367,7 @@ type = integer intent = in optional = F -[xlat] +[xlatin] standard_name = latitude long_name = latitude units = radians @@ -376,7 +376,7 @@ kind = kind_phys intent = in optional = F -[xcosz] +[xcoszin] standard_name = instantaneous_cosine_of_zenith_angle long_name = cosine of zenith angle at current time units = none From e5e6b787c2ee5a991ea3e9b9d7147d65546c3f6f Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 22 Aug 2019 13:34:16 -0600 Subject: [PATCH 05/59] add NoahMP interstitial code (only pre routine needed for GFS suite for handling dates) --- physics/noahmp_pre.F90 | 72 +++++++++++++++++++++++++++++++++++++ physics/noahmp_pre.meta | 45 +++++++++++++++++++++++ physics/sfc_noahmp_drv.f | 24 +++++++------ physics/sfc_noahmp_drv.meta | 36 +++++++++---------- 4 files changed, 149 insertions(+), 28 deletions(-) create mode 100644 physics/noahmp_pre.F90 create mode 100644 physics/noahmp_pre.meta diff --git a/physics/noahmp_pre.F90 b/physics/noahmp_pre.F90 new file mode 100644 index 000000000..13d432209 --- /dev/null +++ b/physics/noahmp_pre.F90 @@ -0,0 +1,72 @@ +!> \file noahmp_pre.F90 +!! This file contains subroutines that prepare data for the NoahMP land surface model scheme +!! as part of the GFS physics suite. + module noahmp_pre + + implicit none + + contains + + subroutine noahmp_pre_init() + end subroutine noahmp_pre_init + + subroutine noahmp_pre_finalize() + end subroutine noahmp_pre_finalize + +!> \section arg_table_noahmp_pre_run Argument Table +!! \htmlinclude noahmp_pre_run.html +!! + subroutine noahmp_pre_run (jdat, julian, yearlen, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: jdat(1:8) + + real(kind=kind_phys), intent(out) :: julian + integer , intent(out) :: yearlen + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: iw3jdn + integer :: jd0, jd1 + real :: fjd + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 + endif + endif + endif + + end subroutine noahmp_pre_run + + end module noahmp_pre \ No newline at end of file diff --git a/physics/noahmp_pre.meta b/physics/noahmp_pre.meta new file mode 100644 index 000000000..a76fb1965 --- /dev/null +++ b/physics/noahmp_pre.meta @@ -0,0 +1,45 @@ +[ccpp-arg-table] + name = noahmp_pre_run + type = scheme +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 26bdf6043..a33ac8eac 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -36,7 +36,7 @@ subroutine noahmpdrv_run & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - & canopy, trans, tsurf, zorl, & + & canopy, trans, tsurf, zorl, t2mmp, q2mp, & ! --- Noah MP specific @@ -49,7 +49,7 @@ subroutine noahmpdrv_run & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2, wet1, t2mmp, q2mp, errmsg, errflg) + & smcwlt2, smcref2, wet1, errmsg, errflg) ! ! use machine , only : kind_phys @@ -129,7 +129,8 @@ subroutine noahmpdrv_run & ! --- in/out: real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & - & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf,zorl + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl, & + & t2mmp, q2mp real (kind=kind_phys), dimension(im,km), intent(inout) :: & & smc, stc, slc @@ -150,13 +151,12 @@ subroutine noahmpdrv_run & integer, dimension(im) :: jsnowxy real (kind=kind_phys),dimension(im) :: snodep real (kind=kind_phys),dimension(im,-2:4) :: tsnsoxy - + ! --- output: real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & - & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1, & - & t2mmp,q2mp + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1 ! error messages character(len=*), intent(out) :: errmsg @@ -669,8 +669,10 @@ subroutine noahmpdrv_run & z0wrf = 0.002 eta = fgev - t2mmp(i) = t2mb - q2mp(i) = q2b + if (dry(i)) then + t2mmp(i) = t2mb + q2mp(i) = q2b + endif ! ! Non-glacial case ! @@ -711,8 +713,10 @@ subroutine noahmpdrv_run & eta = fcev + fgev + fctr ! the flux w/m2 - t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) - q2mp(i) = q2v*fveg+q2b*(1-fveg) + if (dry(i)) then + t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) + q2mp(i) = q2v*fveg+q2b*(1-fveg) + endif endif ! glacial split ends diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index c84998cad..2422cffb3 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -555,6 +555,24 @@ kind = kind_phys intent = inout optional = F +[t2mmp] + standard_name = temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[q2mp] + standard_name = specific_humidity_at_2m + long_name = 2 meter specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers @@ -1032,24 +1050,6 @@ kind = kind_phys intent = out optional = F -[t2mmp] - standard_name = temperature_at_2m - long_name = 2 meter temperature - units = K - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[q2mp] - standard_name = specific_humidity_at_2m - long_name = 2 meter specific humidity - units = kg kg-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 6c2cab88ee8249d42e7645f7f8e966a1a5b47390 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 23 Aug 2019 11:10:11 -0600 Subject: [PATCH 06/59] send physical constants through the argument list --- physics/sfc_noahmp_drv.f | 32 ++++++++------- physics/sfc_noahmp_drv.meta | 81 +++++++++++++++++++++++++++++++++++++ 2 files changed, 98 insertions(+), 15 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index a33ac8eac..1406ec366 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -33,6 +33,8 @@ subroutine noahmpdrv_run & & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & & iopt_stc, xlatin, xcoszin, iyrlen, julian, & & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & + & con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & + & con_fvirt, con_rd, con_hfus, & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & @@ -55,8 +57,6 @@ subroutine noahmpdrv_run & use machine , only : kind_phys ! use date_def, only : idate use funcphys, only : fpvs - use physcons, only : con_g, con_hvap, con_cp, con_jcal, & - & con_eps, con_epsm1, con_fvirt, con_rd,con_hfus use module_sf_noahmplsm use module_sf_noahmp_glacier @@ -66,22 +66,12 @@ subroutine noahmpdrv_run & & saim_table,laim_table implicit none - -! --- constant parameters: - - real(kind=kind_phys), parameter :: cpinv = 1.0/con_cp - real(kind=kind_phys), parameter :: hvapi = 1.0/con_hvap - real(kind=kind_phys), parameter :: elocp = con_hvap/con_cp - real(kind=kind_phys), parameter :: rhoh2o = 1000.0 - real(kind=kind_phys), parameter :: convrad = con_jcal*1.e4/60.0 + real(kind=kind_phys), parameter :: a2 = 17.2693882 real(kind=kind_phys), parameter :: a3 = 273.16 real(kind=kind_phys), parameter :: a4 = 35.86 real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) -! -! --- -! - + real, parameter :: undefined = -1.e36 real :: dz8w = undefined @@ -126,6 +116,10 @@ subroutine noahmpdrv_run & real (kind=kind_phys), intent(in) :: delt logical, dimension(im), intent(in) :: flag_iter, flag_guess + + real (kind=kind_phys), intent(in) :: con_hvap, con_cp, con_jcal, & + & rhoh2o, con_eps, con_epsm1, con_fvirt, & + & con_rd, con_hfus ! --- in/out: real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & @@ -225,12 +219,20 @@ subroutine noahmpdrv_run & integer :: i, k, ice, stype, vtype ,slope,nroot,couple logical :: flag(im) logical :: snowng,frzgra + + ! --- local derived constants: + real(kind=kind_phys) :: cpinv, hvapi, convrad, elocp + type(noahmp_parameters) :: parameters ! !===> ... begin here -! +! + cpinv = 1.0/con_cp + hvapi = 1.0/con_hvap + convrad = con_jcal*1.e4/60.0 + elocp = con_hvap/con_cp ! Initialize CCPP error handling variables errmsg = '' diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 2422cffb3..cd3b1e962 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -447,6 +447,87 @@ kind = kind_phys intent = in optional = F +[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 + optional = F +[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 + optional = F +[con_jcal] + standard_name = joules_per_calorie_constant + long_name = joules per calorie constant + units = J cal-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rhoh2o] + standard_name = liquid_water_density + long_name = density of liquid water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[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 + optional = F [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land From 24b8942dd25f7c72015610dae10912676c002055 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 23 Aug 2019 18:01:07 -0600 Subject: [PATCH 07/59] remove WRF error handling in favor of CCPP error handling --- physics/module_sf_noahmp_glacier.f90 | 48 ++++++++++- physics/module_sf_noahmplsm.f90 | 123 ++++++++++++++++++++++++++- physics/module_wrf_utl.f90 | 50 ----------- physics/sfc_noahmp_drv.f | 18 +++- 4 files changed, 181 insertions(+), 58 deletions(-) delete mode 100755 physics/module_wrf_utl.f90 diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index a26e108e4..35bad73d9 100755 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -111,7 +111,9 @@ end module noahmp_glacier_globals module noahmp_glacier_routines use noahmp_glacier_globals +#ifndef CCPP use module_wrf_utl +#endif implicit none public :: noahmp_options_glacier @@ -158,7 +160,12 @@ subroutine noahmp_glacier (& fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : qsnbot ,ponding ,ponding1,ponding2,t2m ,q2e , & ! out : +#ifdef CCPP + emissi, fpice ,ch2b , esnow, errmsg, errflg) +#else emissi, fpice ,ch2b , esnow) +#endif + ! -------------------------------------------------------------------------------------------------- ! initial code: guo-yue niu, oct. 2007 @@ -232,6 +239,11 @@ subroutine noahmp_glacier (& real , intent(out) :: ch2b real , intent(out) :: esnow +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! local integer :: iz !do-loop index integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] @@ -529,7 +541,15 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i fire = lwdn + fira - if(fire <=0.) call wrf_error_fatal("stop in noah-mp: emitted longwave <0") + if(fire <=0.) then +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp: emitted longwave <0" + return +#else + call wrf_error_fatal("stop in noah-mp: emitted longwave <0") +#endif + end if ! compute a net emissivity emissi = emg @@ -1252,7 +1272,13 @@ subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in if(zlvl <= zpd) then write(*,*) 'critical glacier problem: zlvl <= zpd; model stops', zlvl, zpd +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp glacier" + return +#else call wrf_error_fatal("stop in noah-mp glacier") +#endif endif tmpcm = log((zlvl-zpd) / z0m) @@ -2918,17 +2944,33 @@ subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & write(*,*) "fsa =",fsa write(*,*) "fsr =",fsr write(message,*) 'errsw =',errsw +#ifdef CCPP + errflg = 1 + errmsg = trim(message)//NEW_LINE('A')//"radiation budget problem in noahmp glacier" + return +#else call wrf_message(trim(message)) call wrf_error_fatal("radiation budget problem in noahmp glacier") +#endif end if erreng = sag-(fira+fsh+fgev+ssoil) if(erreng > 0.01) then write(message,*) 'erreng =',erreng +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(i6,1x,i6,1x,5f10.4)')iloc,jloc,sag,fira,fsh,fgev,ssoil - call wrf_message(trim(message)) - call wrf_error_fatal("energy budget problem in noahmp glacier") +#ifdef CCPP + errflg = 1 + errmsg = trim(errmsg)//NEW_LINE('A')//"energy budget problem in noahmp glacier" + return +#else + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp glacier") +#endif end if end_wb = sneqv diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 139c53277..791988a9a 100755 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -1,5 +1,7 @@ module module_sf_noahmplsm +#ifndef CCPP use module_wrf_utl +#endif implicit none @@ -303,7 +305,11 @@ subroutine noahmp_sflx (parameters, & shg , shc , shb , evg , evb , ghv , & ! out : ghb , irg , irc , irb , tr , evc , & ! out : chleaf , chuc , chv2 , chb2 , fpice , pahv , & - pahg , pahb , pah , esnow) +#ifdef CCPP + pahg , pahb , pah , esnow, errmsg, errflg) +#else + pahg , pahb , pah , esnow) +#endif ! -------------------------------------------------------------------------------------------------- ! initial code: guo-yue niu, oct. 2007 @@ -432,6 +438,10 @@ subroutine noahmp_sflx (parameters, & real :: q1 real, intent(out) :: emissi !jref:end +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif ! local integer :: iz !do-loop index @@ -606,7 +616,13 @@ subroutine noahmp_sflx (parameters, & if(fveg <= 0.05) fveg = 0.05 else write(*,*) "-------- fatal called in sflx -----------" +#ifdef CCPP + errflg = 1 + errmsg = "namelist parameter dveg unknown" + return +#else call wrf_error_fatal("namelist parameter dveg unknown") +#endif endif if(parameters%urban_flag .or. vegtyp == parameters%isbarren) fveg = 0.0 if(elai+esai == 0.0) fveg = 0.0 @@ -1271,36 +1287,89 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & write(*,*) "fsa =",fsa !jref:end write(message,*) 'errsw =',errsw +#ifdef CCPP + errflg = 1 + errmsg = trim(message)//NEW_LINE('A')//"stop in noah-mp" + return +#else call wrf_message(trim(message)) call wrf_error_fatal("stop in noah-mp") +#endif end if erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah ! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) if(abs(erreng) > 0.01) then write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "net solar: ",fsa +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "net longwave: ",fira +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "total sensible: ",fsh +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "canopy evap: ",fcev +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "ground evap: ",fgev +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "transpiration: ",fctr +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "total ground: ",ssoil +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "precip: ",prcp +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "veg fraction: ",fveg +#ifdef CCPP + errflg = 1 + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message)//NEW_LINE('A')//"energy budget problem in noahmp lsm" + return +#else call wrf_message(trim(message)) call wrf_error_fatal("energy budget problem in noahmp lsm") +#endif + end if if (ist == 1) then !soil @@ -1880,7 +1949,14 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in write(6,*) 'input of shdfac with lai' write(6,*) iloc, jloc, 'shdfac=',fveg,'vai=',vai,'tv=',tv,'tg=',tg write(6,*) 'lwdn=',lwdn,'fira=',fira,'snowh=',snowh - call wrf_error_fatal("stop in noah-mp") +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp" + return +#else + call wrf_error_fatal("stop in noah-mp") +#endif + end if ! compute a net emissivity @@ -3396,16 +3472,39 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 if((hcan-zpd) <= 0.) then write(message,*) "critical problem: hcan <= zpd" +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message ( message ) +#endif write(message,*) 'i,j point=',iloc, jloc +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message ( message ) +#endif write(message,*) 'hcan =',hcan +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message ( message ) +#endif write(message,*) 'zpd =',zpd +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message ( message ) +#endif write (message, *) 'snowh =',snowh +#ifdef CCPP + errflg = 1 + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message)//NEW_LINE('A')//"critical problem in module_sf_noahmplsm:vegeflux" + return +#else call wrf_message ( message ) call wrf_error_fatal ( "critical problem in module_sf_noahmplsm:vegeflux" ) +#endif + end if ! prepare for longwave rad. @@ -4124,7 +4223,13 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in if(zlvl <= zpd) then write(*,*) 'critical problem: zlvl <= zpd; model stops' - call wrf_error_fatal("stop in noah-mp") +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp" + return +#else + call wrf_error_fatal("stop in noah-mp") +#endif endif tmpcm = log((zlvl-zpd) / z0m) @@ -4833,10 +4938,18 @@ subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & ! if (abs(err_est) > 1.) then ! w/m2 write(message,*) 'tsnosoi is losing(-)/gaining(+) false energy',err_est,' w/m2' +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(i6,1x,i6,1x,i3,f18.13,5f20.12)') & iloc, jloc, ist,err_est,ssoil,snowh,tg,stc(isnow+1),eflxb +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif !niu stop end if @@ -5397,7 +5510,11 @@ subroutine frh2o (parameters,free,tkelv,smc,sh2o) ! ---------------------------------------------------------------------- if (kcount == 0) then write(message, '("flerchinger used in new version. iterations=", i6)') nlog +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif fk = ( ( (hfus / (grav * ( - parameters%psisat)))* & ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax if (fk < 0.02) fk = 0.02 diff --git a/physics/module_wrf_utl.f90 b/physics/module_wrf_utl.f90 deleted file mode 100755 index 29f8bb9e1..000000000 --- a/physics/module_wrf_utl.f90 +++ /dev/null @@ -1,50 +0,0 @@ -module module_wrf_utl - implicit none -contains - -subroutine wrf_error_fatal(string) - implicit none - character(len=*), intent(in) :: string - print*, string - stop -end subroutine wrf_error_fatal - -subroutine wrf_message(msg) - implicit none - character(len=*), intent(in) :: msg - write(*,'(A)') msg -end subroutine wrf_message - -logical function wrf_dm_on_monitor() result (return_value) - implicit none - return_value = .TRUE. -end function wrf_dm_on_monitor - -subroutine wrf_dm_bcast_real(rval, ival) - implicit none - real, intent(in) :: rval - integer, intent(in) :: ival -end subroutine wrf_dm_bcast_real - -subroutine wrf_dm_bcast_integer(ival1, ival2) - implicit none - real, intent(in) :: ival1 - integer, intent(in) :: ival2 -end subroutine wrf_dm_bcast_integer - -subroutine wrf_dm_bcast_string(sval, ival) - implicit none - character(len=*), intent(in) :: sval - integer, intent(in) :: ival -end subroutine wrf_dm_bcast_string - -subroutine wrf_debug( level , str ) - implicit none - character*(*) str - integer , intent (in) :: level - call wrf_message( str ) - return -end subroutine wrf_debug - -end module module_wrf_utl - diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 1406ec366..c5654dd44 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -628,8 +628,15 @@ subroutine noahmpdrv_run & & fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : & trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : albedo is surface albedo & qsnbot ,ponding ,ponding1,ponding2,t2mb ,q2b , & ! out : +#ifdef CCPP + & emissi ,fpice ,ch2b ,esnow, errmsg, errflg ) +#else & emissi ,fpice ,ch2b ,esnow ) +#endif +#ifdef CCPP + if (errflg /= 0) return +#endif ! ! in/out and outs ! @@ -710,8 +717,15 @@ subroutine noahmpdrv_run & & shg , shc , shb , evg , evb , ghv ,&! out : & ghb , irg , irc , irb , tr , evc ,& ! out : & chleaf , chuc , chv2 , chb2 , fpice , pahv ,& ! out - & pahg , pahb , pah , esnow ) - +#ifdef CCPP + & pahg , pahb , pah , esnow, errmsg, errflg ) +#else + & pahg , pahb , pah , esnow ) +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif eta = fcev + fgev + fctr ! the flux w/m2 From 10985004bc192894cd2397f1e9947fb0051e06fa Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 23 Aug 2019 21:58:10 -0600 Subject: [PATCH 08/59] pass errmsg and errflg down call chain --- physics/module_sf_noahmp_glacier.f90 | 91 ++++++++++++++--- physics/module_sf_noahmplsm.f90 | 147 +++++++++++++++++++++++++-- 2 files changed, 213 insertions(+), 25 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 35bad73d9..ced43ae5c 100755 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -294,10 +294,18 @@ subroutine noahmp_glacier (& tbot ,zbot ,zsnso ,dzsnso , & !in tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout +#ifdef CCPP + tauss ,qsfc ,errmsg ,errflg , & !inout +#else tauss ,qsfc , & !inout +#endif imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out - sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out - trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + +#ifdef CCPP + if (errflg /= 0) return +#endif sice = max(0.0, smc - sh2o) sneqvo = sneqv @@ -324,7 +332,15 @@ subroutine noahmp_glacier (& call error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & fsh ,fgev ,ssoil ,sag ,prcp ,edir , & - runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#ifdef CCPP + runsrf ,runsub ,sneqv ,dt ,beg_wb, errmsg, errflg ) +#else + runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then snowh = 0.0 @@ -399,7 +415,11 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i tbot ,zbot ,zsnso ,dzsnso , & !in tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout +#ifdef CCPP + tauss ,qsfc ,errmsg, errflg, & !inout +#else tauss ,qsfc , & !inout +#endif imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out @@ -449,6 +469,11 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i real , intent(inout) :: ch !sensible heat exchange coefficient real , intent(inout) :: tauss !snow aging factor real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif ! outputs integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] @@ -531,11 +556,15 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i call glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0mg , & !in zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in - ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in - eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - cm ,ch ,tg ,qsfc , & !inout - fira ,fsh ,fgev ,ssoil , & !out - t2m ,q2e ,ch2b) !out + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in +#ifdef CCPP + cm ,ch ,tg ,qsfc ,errmsg ,errflg , & !inout +#else + cm ,ch ,tg ,qsfc , & !inout +#endif + fira ,fsh ,fgev ,ssoil , & !out + t2m ,q2e ,ch2b) !out !energy balance at surface: sag=(irb+shb+evb+ghb) @@ -952,9 +981,13 @@ end subroutine snowalb_class_glacier ! ================================================================================================== subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0m , & !in zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in - ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in - eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in +#ifdef CCPP + cm ,ch ,tgb ,qsfc ,errmsg ,errflg , & !inout +#else cm ,ch ,tgb ,qsfc , & !inout +#endif irb ,shb ,evb ,ghb , & !out t2mb ,q2b ,ehb2) !out @@ -1001,7 +1034,12 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z real, intent(inout) :: ch !sensible heat exchange coefficient real, intent(inout) :: tgb !ground temperature (k) real, intent(inout) :: qsfc !mixing ratio at lowest model layer - + +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! output ! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] @@ -1073,9 +1111,16 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z call sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#ifdef CCPP + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg, errflg, & !inout +#else + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif & fv ,cm ,ch ,ch2) !out +#ifdef CCPP + if (errflg /= 0) return +#endif ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) rawb = rahb @@ -1212,7 +1257,11 @@ end subroutine esat subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#ifdef CCPP + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg , & !inout +#else + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif & fv ,cm ,ch ,ch2 ) !out ! ------------------------------------------------------------------------------------------------- ! computing surface drag coefficient cm for momentum and ch for heat @@ -1240,6 +1289,11 @@ subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! outputs real, intent(out) :: fv !friction velocity (m/s) real, intent(out) :: cm !drag coefficient for momentum @@ -2906,7 +2960,11 @@ end subroutine snowh2o_glacier ! ================================================================================================== subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & fsh ,fgev ,ssoil ,sag ,prcp ,edir , & - runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#ifdef CCPP + runsrf ,runsub ,sneqv ,dt ,beg_wb, errmsg, errflg ) +#else + runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#endif ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance ! -------------------------------------------------------------------------------------------------- @@ -2932,6 +2990,11 @@ subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & real , intent(in) :: dt !time step [sec] real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif + real :: end_wb !water storage at end of a timestep [mm] real :: errwat !error in water balance [mm/timestep] real :: erreng !error in surface energy balance [w/m2] diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 791988a9a..4f1f7dbad 100755 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -645,7 +645,7 @@ subroutine noahmp_sflx (parameters, & elai ,esai ,fwet ,foln , & !in fveg ,pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in - z0wrf , & + z0wrf , & imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out @@ -654,16 +654,22 @@ subroutine noahmp_sflx (parameters, & tv ,tg ,stc ,snowh ,eah ,tah , & !inout sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout +#ifdef CCPP + tauss ,errmsg ,errflg , & !inout +#else tauss , & !inout +#endif !jref:start qc ,qsfc ,psfc , & !in t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,bgap ,wgap, tgv,tgb,& q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out emissi ,pah , & - shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out !jref:end - +#ifdef CCPP + if (errflg /= 0) return +#endif sice(:) = max(0.0, smc(:) - sh2o(:)) sneqvo = sneqv @@ -709,7 +715,15 @@ subroutine noahmp_sflx (parameters, & etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in nsnow ,ist ,errwat ,iloc , jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & +#ifdef CCPP + pahv ,pahg ,pahb ,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) +#else pahv ,pahg ,pahb ) !in ( except errwat, which is out ) +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif ! urban - jref qfx = etran + ecan + edir @@ -1209,7 +1223,11 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & etran ,edir ,runsrf ,runsub ,dt ,nsoil , & nsnow ,ist ,errwat, iloc ,jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & +#ifdef CCPP + pahv ,pahg ,pahb ,errmsg, errflg) +#else pahv ,pahg ,pahb ) +#endif ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance ! -------------------------------------------------------------------------------------------------- @@ -1258,6 +1276,11 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & real, intent(in) :: pahg !precipitation advected heat - total (w/m2) real, intent(in) :: pahb !precipitation advected heat - total (w/m2) +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif + integer :: iz !do-loop index real :: end_wb !water storage at end of a timestep [mm] !kwm real :: errwat !error in water balance [mm/timestep] @@ -1404,7 +1427,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in tv ,tg ,stc ,snowh ,eah ,tah , & !inout sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout +#ifdef CCPP + tauss ,errmsg ,errflg, & !inout +#else tauss , & !inout +#endif !jref:start qc ,qsfc ,psfc , & !in t2mv ,t2mb ,fsrv , & @@ -1568,6 +1595,10 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real , intent(inout) :: cm !momentum drag coefficient real , intent(inout) :: ch !sensible heat exchange coefficient real , intent(inout) :: q1 +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif ! real :: q2e real, intent(out) :: emissi real, intent(out) :: pah !precipitation advected heat - total (w/m2) @@ -1869,14 +1900,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in eah ,tah ,tv ,tgv ,cmv , & !inout +#ifdef CCPP + chv ,dx ,dz8w ,errmsg ,errflg , & !inout +#else chv ,dx ,dz8w , & !inout +#endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,ghv , & !out t2mv ,psnsun ,psnsha , & !out !jref:start qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout -!jref:end +!jref:end +#ifdef CCPP + if (errflg /= 0) return +#endif end if tgb = tg @@ -1888,14 +1926,20 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in +#ifdef CCPP + tgb ,cmb ,chb ,errmsg ,errflg , & !inout +#else tgb ,cmb ,chb , & !inout +#endif tauxb ,tauyb ,irb ,shb ,evb , & !out ghb ,t2mb ,dx ,dz8w ,vegtyp , & !out !jref:start qc ,qsfc ,psfc , & !in sfcprs ,q2b, chb2) !in -!jref:end - +!jref:end +#ifdef CCPP + if (errflg /= 0) return +#endif !energy balance at vege canopy: sav =(irc+shc+evc+tr) *fveg at fveg !energy balance at vege ground: sag* fveg =(irg+shg+evg+ghv) *fveg at fveg !energy balance at bare ground: sag*(1.-fveg)=(irb+shb+evb+ghb)*(1.-fveg) at 1-fveg @@ -1981,7 +2025,15 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in tbot ,zsnso ,ssoil ,df ,hcpct , & !in sag ,dt ,snowh ,dzsnso , & !in tg ,iloc ,jloc , & !in +#ifdef CCPP + stc ,errmsg ,errflg ) !inout +#else stc ) !inout +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif ! adjusting snow surface temperature if(opt_stc == 2) then @@ -2003,9 +2055,15 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in dzsnso ,hcpct ,ist ,iloc ,jloc , & !in stc ,snice ,snliq ,sneqv ,snowh , & !inout +#ifdef CCPP + smc ,sh2o ,errmsg ,errflg , & !inout +#else smc ,sh2o , & !inout +#endif qmelt ,imelt ,ponding ) !out - +#ifdef CCPP + if (errflg /= 0) return +#endif end subroutine energy @@ -3209,7 +3267,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in eah ,tah ,tv ,tg ,cm , & !inout - ch ,dx ,dz8w , & ! +#ifdef CCPP + ch ,dx ,dz8w ,errmsg ,errflg , & !inout +#else + ch ,dx ,dz8w , & !inout +#endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,gh , & !out t2mv ,psnsun ,psnsha , & !out @@ -3303,6 +3365,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real, intent(inout) :: cm !momentum drag coefficient real, intent(inout) :: ch !sensible heat exchange coefficient +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! output ! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 real, intent(out) :: tauxv !wind stress: e-w (n/m2) @@ -3528,8 +3595,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in zlvl ,zpd ,z0m ,z0h ,ur , & !in mpe ,iloc ,jloc , & !in - moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout +#ifdef CCPP + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg ,& !inout +#else + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif cm ,ch ,fv ,ch2 ) !out +#ifdef CCPP + if (errflg /= 0) return +#endif endif if(opt_sfc == 2) then @@ -3755,7 +3829,11 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in +#ifdef CCPP + tgb ,cm ,ch ,errmsg ,errflg , & !inout +#else tgb ,cm ,ch , & !inout +#endif tauxb ,tauyb ,irb ,shb ,evb , & !out ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out qc ,qsfc ,psfc , & !in @@ -3818,6 +3896,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real, intent(inout) :: tgb !ground temperature (k) real, intent(inout) :: cm !momentum drag coefficient real, intent(inout) :: ch !sensible heat exchange coefficient +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif ! output ! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 @@ -3937,8 +4019,15 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in zlvl ,zpd ,z0m ,z0h ,ur , & !in mpe ,iloc ,jloc , & !in - moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout +#ifdef CCPP + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg ,& !inout +#else + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif cm ,ch ,fv ,ch2 ) !out +#ifdef CCPP + if (errflg /= 0) return +#endif endif if(opt_sfc == 2) then @@ -4160,7 +4249,11 @@ end subroutine ragrb subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in & zlvl ,zpd ,z0m ,z0h ,ur , & !in & mpe ,iloc ,jloc , & !in +#ifdef CCPP + & moz ,mozsgn ,fm ,fh ,fm2,fh2,errmsg,errflg, & !inout +#else & moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout +#endif & cm ,ch ,fv ,ch2 ) !out ! ------------------------------------------------------------------------------------------------- ! computing surface drag coefficient cm for momentum and ch for heat @@ -4191,6 +4284,10 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif ! outputs @@ -4834,7 +4931,11 @@ subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & ! tbot ,zsnso ,ssoil ,df ,hcpct , & !in sag ,dt ,snowh ,dzsnso , & !in tg ,iloc ,jloc , & !in +#ifdef CCPP + stc ,errmsg ,errflg) !inout +#else stc ) !inout +#endif ! -------------------------------------------------------------------------------------------------- ! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures ! during melting season may exceed melting point (tfrz) but later in phasechange @@ -4867,6 +4968,10 @@ subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & ! !input and output real, dimension(-nsnow+1:nsoil), intent(inout) :: stc +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif !local @@ -5182,7 +5287,11 @@ end subroutine rosr12 subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in dzsnso ,hcpct ,ist ,iloc ,jloc , & !in stc ,snice ,snliq ,sneqv ,snowh , & !inout +#ifdef CCPP + smc ,sh2o ,errmsg ,errflg , & !inout +#else smc ,sh2o , & !inout +#endif qmelt ,imelt ,ponding ) !out ! ---------------------------------------------------------------------- ! melting/freezing of snow water and soil water @@ -5217,6 +5326,10 @@ subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif ! local @@ -5275,7 +5388,12 @@ subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , end if end if if (opt_frz == 2) then +#ifdef CCPP + call frh2o (parameters,supercool(j),stc(j),smc(j),sh2o(j),errmsg,errflg) + if (errflg /=0) return +#else call frh2o (parameters,supercool(j),stc(j),smc(j),sh2o(j)) +#endif supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) end if enddo @@ -5389,8 +5507,11 @@ subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , end subroutine phasechange !== begin frh2o ==================================================================================== - +#ifdef CCPP + subroutine frh2o (parameters,free,tkelv,smc,sh2o,errmsg,errflg) +#else subroutine frh2o (parameters,free,tkelv,smc,sh2o) +#endif ! ---------------------------------------------------------------------- ! subroutine frh2o @@ -5423,6 +5544,10 @@ subroutine frh2o (parameters,free,tkelv,smc,sh2o) type (noahmp_parameters), intent(in) :: parameters real, intent(in) :: sh2o,smc,tkelv real, intent(out) :: free +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif real :: bx,denom,df,dswl,fk,swl,swlk integer :: nlog,kcount ! parameter(ck = 0.0) From dab6e6d5305f0b2574d68489cca40f5ba44e80bd Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 26 Aug 2019 13:30:30 -0600 Subject: [PATCH 09/59] move NoahMP calculation of julian day and year length to GFS_time_vary_pre_run; update GFS_time_vary_pre_run.fv3.F90 to new metadata and remove DDT dependency --- physics/GFS_time_vary_pre.fv3.F90 | 135 +++++++++----- physics/GFS_time_vary_pre.fv3.meta | 271 +++++++++++++++++++++++++++++ physics/dcyc2.f | 2 +- physics/noahmp_pre.F90 | 72 -------- physics/noahmp_pre.meta | 45 ----- physics/sfc_nst.f | 2 +- 6 files changed, 364 insertions(+), 163 deletions(-) create mode 100644 physics/GFS_time_vary_pre.fv3.meta delete mode 100644 physics/noahmp_pre.F90 delete mode 100644 physics/noahmp_pre.meta diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 4fecabad5..6912a8af3 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -16,10 +16,7 @@ module GFS_time_vary_pre contains !> \section arg_table_GFS_time_vary_pre_init Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_time_vary_pre_init.html !! subroutine GFS_time_vary_pre_init (errmsg, errflg) @@ -43,10 +40,7 @@ end subroutine GFS_time_vary_pre_init !> \section arg_table_GFS_time_vary_pre_finalize Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_time_vary_pre_finalize.html !! subroutine GFS_time_vary_pre_finalize(errmsg, errflg) @@ -69,26 +63,40 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_time_vary_pre_run.html !! - subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) + subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & + nslwr, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, kdt, & + julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type implicit none - - type(GFS_control_type), intent(inout) :: Model + + integer, intent(in) :: idate(4) + integer, intent(in) :: jdat(1:8), idat(1:8) + integer, intent(in) :: lsm, lsm_noahmp, & + nsswr, nslwr, me, & + master, nscyc + logical, intent(in) :: debug + real(kind=kind_phys), intent(in) :: dtp + + integer, intent(out) :: kdt, yearlen, ipt + logical, intent(out) :: lprnt, lssav, lsswr, & + lslwr + real(kind=kind_phys), intent(out) :: sec, phour, zhour, & + fhour, julian, solhr + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys real(kind=kind_phys) :: rinc(5) + + integer :: iw3jdn + integer :: jd0, jd1 + real :: fjd ! Initialize CCPP error handling variables errmsg = '' @@ -96,44 +104,83 @@ subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) ! Check initialization status if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called before GFS_time_vary_pre_init" + write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called & + &before GFS_time_vary_pre_init" errflg = 1 return end if - !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90 + !--- jdat is being updated directly inside of FV3GFS_cap.F90 !--- update calendars and triggers rinc(1:5) = 0 - call w3difdat(Model%jdat,Model%idat,4,rinc) - Model%sec = rinc(4) - Model%phour = Model%sec/con_hr + call w3difdat(jdat,idat,4,rinc) + sec = rinc(4) + phour = sec/con_hr !--- set current bucket hour - Model%zhour = Model%phour - Model%fhour = (Model%sec + Model%dtp)/con_hr - Model%kdt = nint((Model%sec + Model%dtp)/Model%dtp) - - Model%ipt = 1 - Model%lprnt = .false. - Model%lssav = .true. + zhour = phour + fhour = (sec + dtp)/con_hr + kdt = nint((sec + dtp)/dtp) + + if(lsm == lsm_noahmp) then + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depends + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in + ! a given year). *GJF + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 + endif + endif + endif + endif + + ipt = 1 + lprnt = .false. + lssav = .true. !--- radiation triggers - Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) - Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + lsswr = (mod(kdt, nsswr) == 1) + lslwr = (mod(kdt, nslwr) == 1) !--- set the solar hour based on a combination of phour and time initial hour - Model%solhr = mod(Model%phour+Model%idate(1),con_24) - - if ((Model%debug) .and. (Model%me == Model%master)) then - print *,' sec ', Model%sec - print *,' kdt ', Model%kdt - print *,' nsswr ', Model%nsswr - print *,' nslwr ', Model%nslwr - print *,' nscyc ', Model%nscyc - print *,' lsswr ', Model%lsswr - print *,' lslwr ', Model%lslwr - print *,' fhour ', Model%fhour - print *,' phour ', Model%phour - print *,' solhr ', Model%solhr + solhr = mod(phour+idate(1),con_24) + + if ((debug) .and. (me == master)) then + print *,' sec ', sec + print *,' kdt ', kdt + print *,' nsswr ', nsswr + print *,' nslwr ', nslwr + print *,' nscyc ', nscyc + print *,' lsswr ', lsswr + print *,' lslwr ', lslwr + print *,' fhour ', fhour + print *,' phour ', phour + print *,' solhr ', solhr endif end subroutine GFS_time_vary_pre_run diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta new file mode 100644 index 000000000..3dc91952e --- /dev/null +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -0,0 +1,271 @@ +[ccpp-arg-table] + name = GFS_time_vary_pre_init + 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 + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = GFS_time_vary_pre_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 + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = GFS_time_vary_pre_run + type = scheme +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[idat] + standard_name = date_and_time_at_model_initialization + long_name = initialization date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noahmp] + standard_name = flag_for_noahmp_land_surface_scheme + long_name = flag for NOAH MP land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nsswr] + standard_name = number_of_timesteps_between_shortwave_radiation_calls + long_name = number of timesteps between shortwave radiation calls + units = + dimensions = () + type = integer + intent = in + optional = F +[nslwr] + standard_name = number_of_timesteps_between_longwave_radiation_calls + long_name = number of timesteps between longwave radiation calls + units = + dimensions = () + type = integer + intent = in + optional = F +[idate] + standard_name = date_and_time_at_model_initialization_reordered + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in + optional = F +[debug] + standard_name = flag_debug + long_name = control flag for debug + units = flag + dimensions = () + type = logical + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[nscyc] + standard_name = number_of_timesteps_between_surface_cycling_calls + long_name = number of timesteps between surface cycling calls + units = + dimensions = () + type = integer + intent = in + optional = F +[sec] + standard_name = seconds_elapsed_since_model_initialization + long_name = seconds elapsed since model initialization + units = s + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[phour] + standard_name = forecast_time_at_previous_timestep + long_name = forecast time at the previous timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[zhour] + standard_name = time_since_diagnostics_zeroed + long_name = time since diagnostics variables have been zeroed + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = out + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = out + optional = F +[ipt] + standard_name = index_for_diagnostic_printout + long_name = horizontal index for point used for diagnostic printout + units = + dimensions = () + type = integer + intent = out + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lsswr] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lslwr] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[solhr] + standard_name = forecast_hour_of_the_day + long_name = time in hours after 00z at the current timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 5844e7371..ac6117e24 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -162,7 +162,7 @@ end subroutine dcyc2t3_finalize !> \section arg_table_dcyc2t3_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |----------------|------------------------------------------------------------------------------------------------|------------------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | solhr | forecast_hour | forecast time in 24-hour form | h | 0 | real | kind_phys | in | F | +!! | solhr | forecast_hour_of_the_day | time in hours after 00z at the current timestep | h | 0 | real | kind_phys | in | F | !! | slag | equation_of_time | equation of time | radians | 0 | real | kind_phys | in | F | !! | sdec | sine_of_solar_declination_angle | sine of solar declination angle | none | 0 | real | kind_phys | in | F | !! | cdec | cosine_of_solar_declination_angle | cosine of solar declination angle | none | 0 | real | kind_phys | in | F | diff --git a/physics/noahmp_pre.F90 b/physics/noahmp_pre.F90 deleted file mode 100644 index 13d432209..000000000 --- a/physics/noahmp_pre.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!> \file noahmp_pre.F90 -!! This file contains subroutines that prepare data for the NoahMP land surface model scheme -!! as part of the GFS physics suite. - module noahmp_pre - - implicit none - - contains - - subroutine noahmp_pre_init() - end subroutine noahmp_pre_init - - subroutine noahmp_pre_finalize() - end subroutine noahmp_pre_finalize - -!> \section arg_table_noahmp_pre_run Argument Table -!! \htmlinclude noahmp_pre_run.html -!! - subroutine noahmp_pre_run (jdat, julian, yearlen, errmsg, errflg) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: jdat(1:8) - - real(kind=kind_phys), intent(out) :: julian - integer , intent(out) :: yearlen - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: iw3jdn - integer :: jd0, jd1 - real :: fjd - - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Julian day calculation (fcst day of the year) - ! we need yearln and julian to - ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 - ! jdat is changing - ! - - jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) - jd0 = iw3jdn(jdat(1),1,1) - fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 - - julian = float(jd1-jd0) + fjd - - ! - ! Year length - ! - ! what if the integration goes from one year to another? - ! iyr or jyr ? from 365 to 366 or from 366 to 365 - ! - ! is this against model's noleap yr assumption? - if (mod(jdat(1),4) == 0) then - yearlen = 366 - if (mod(jdat(1),100) == 0) then - yearlen = 365 - if (mod(jdat(1),400) == 0) then - yearlen = 366 - endif - endif - endif - - end subroutine noahmp_pre_run - - end module noahmp_pre \ No newline at end of file diff --git a/physics/noahmp_pre.meta b/physics/noahmp_pre.meta deleted file mode 100644 index a76fb1965..000000000 --- a/physics/noahmp_pre.meta +++ /dev/null @@ -1,45 +0,0 @@ -[ccpp-arg-table] - name = noahmp_pre_run - type = scheme -[jdat] - standard_name = forecast_date_and_time - long_name = current forecast date and time - units = none - dimensions = (8) - type = integer - intent = in - optional = F -[julian] - standard_name = julian_day - long_name = julian day - units = days - dimensions = () - type = real - kind = kind_phys - intent = out - optional = F -[yearlen] - standard_name = number_of_days_in_year - long_name = number of days in a year - units = days - dimensions = () - type = integer - intent = out - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 086eb54f2..0f2f1ac0e 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -59,7 +59,7 @@ end subroutine sfc_nst_finalize !! | rain | nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ocean | total precipitation amount in each time step over ocean | m | 1 | real | kind_phys | in | F | !! | timestep | time_step_for_dynamics | timestep interval | s | 0 | real | kind_phys | in | F | !! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | solhr | forecast_hour | fcst hour at the end of prev time step | h | 0 | real | kind_phys | in | F | +!! | solhr | forecast_hour_of_the_day | time in hours after 00z at the current timestep | h | 0 | real | kind_phys | in | F | !! | xcosz | instantaneous_cosine_of_zenith_angle | cosine of solar zenith angle | none | 1 | real | kind_phys | in | F | !! | ddvel | surface_wind_enhancement_due_to_convection | wind enhancement due to convection | m s-1 | 1 | real | kind_phys | in | F | !! | flag_iter | flag_for_iteration | flag for iteration | flag | 1 | logical | | in | F | From 869e874e1196123b6647f51d17337f0d1f819275 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 27 Aug 2019 01:12:19 +0000 Subject: [PATCH 10/59] add MYJ surface layer scheme and MYJ PBL scheme to CCPP --- physics/module_BL_MYJPBL.F90 | 2183 +++++++++++++++++++++++++++++ physics/module_MYJPBL_wrapper.F90 | 856 +++++++++++ physics/module_MYJSFC_wrapper.F90 | 554 ++++++++ physics/module_SF_JSFC.F90 | 1319 +++++++++++++++++ 4 files changed, 4912 insertions(+) create mode 100755 physics/module_BL_MYJPBL.F90 create mode 100644 physics/module_MYJPBL_wrapper.F90 create mode 100644 physics/module_MYJSFC_wrapper.F90 create mode 100755 physics/module_SF_JSFC.F90 diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 new file mode 100755 index 000000000..6f455221b --- /dev/null +++ b/physics/module_BL_MYJPBL.F90 @@ -0,0 +1,2183 @@ +!----------------------------------------------------------------------- +! + MODULE MODULE_BL_MYJPBL +! +!----------------------------------------------------------------------- +! +!*** THE MYJ PBL SCHEME +! +!----------------------------------------------------------------------- +! +! USE MODULE_INCLUDE +! +! USE MODULE_CONSTANTS,ONLY : A2,A3,A4,CP,ELIV,ELWV,ELIWV & +! ,EP_1,EPSQ & +! ,G,P608,PI,PQ0,R_D,R_V,RHOWATER & +! ,STBOLT,CAPPA + +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! integer,parameter :: isingle=selected_int_kind(r=9) +! integer,parameter :: idouble=selected_int_kind(r=18) +! integer,parameter :: single=selected_real_kind(p=6,r=37) +! integer,parameter :: double=selected_real_kind(p=13,r=200) + +! integer,parameter:: & +! klog=4 & +! ,kint=isingle & +! ,kdin=idouble & +! ,kfpt=single & +! ,kdbl=double + +! real (kind=kfpt),parameter :: r4_in=x'ffbfffff' +! real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' +! integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) + + integer,parameter:: & + klog=4 & ! logical variables + ,kint=4 & ! integer variables + ,kfpt=4 & ! floating point variables + ,kdbl=8 ! double precision + + REAL(kind=kfpt),PARAMETER :: A2=17.2693882,A3=273.15,A4=35.86,CP=1004.6 & + ,ELIV=2.850e6,ELWV=2.501e6,R_V=461.6 & +! ,EPSQ=1.e-12,EPSQ2=0.02,G=9.8060226 & + ,EPSQ=1.e-12,G=9.8060226 & + ,PQ0=379.90516,R_D=287.04,EP_1=R_V/R_D-1. & + ,P608=R_V/R_D-1.,PI=3.141592653589793 & + ,RHOWATER=1000.,STBOLT=5.67051E-8,CAPPA=R_D/CP + REAL(kind=kfpt),PARAMETER :: eliwv=2.683e6 +! + REAL(kind=kfpt),PARAMETER :: CONW=1./G,CONT=CP/G,CONQ=ELWV/G + +!----------------------------------------------------------------------- +! + PRIVATE +! + PUBLIC:: MYJPBL_INIT, MYJPBL +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!*** FOR MYJ TURBULENCE +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + ELEVFC=0.6 +! + REAL(KIND=KFPT),PARAMETER:: & + VKARMAN=0.4 & +! + ,XLS=ELIV,XLV=ELWV & + ,RLIVWV=XLS/XLV,ELOCP=2.72E6/CP & +! + ,EPS1=1.E-12,EPS2=0. & + ,EPSRU=1.E-7,EPSRS=1.E-7 & + ,EPSTRB=1.E-24 & + ,FH=1.10 & +! + ,ALPH=0.30,BETA=1./273.,EL0MAX=1000.,EL0MIN=1. & +! ,ELFC=0.5,GAM1=0.2222222222222222222 & +! ,ELFC=0.23*0.25,GAM1=0.2222222222222222222 & + ,ELFC=1.,GAM1=0.2222222222222222222 & +! + ,A1=0.659888514560862645 & + ,A2X=0.6574209922667784586 & + ,B1=11.87799326209552761 & + ,B2=7.226971804046074028 & + ,C1=0.000830955950095854396 & + ,ELZ0=0.,ESQ=5.0 & +! + ,SEAFC=0.98,PQ0SEA=PQ0*SEAFC & +! + ,BTG=BETA*G & + ,ESQHF=0.5*5.0 & + ,RB1=1./B1 +! + REAL(KIND=KFPT),PARAMETER:: & + ADNH= 9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + ,ADNM=18.*A1*A1*A2X*(B2-3.*A2X)*BTG & + ,ANMH=-9.*A1*A2X*A2X*BTG*BTG & + ,ANMM=-3.*A1*A2X*(3.*A2X+3.*B2*C1+18.*A1*C1-B2)*BTG & + ,BDNH= 3.*A2X*(7.*A1+B2)*BTG & + ,BDNM= 6.*A1*A1 & + ,BEQH= A2X*B1*BTG+3.*A2X*(7.*A1+B2)*BTG & + ,BEQM=-A1*B1*(1.-3.*C1)+6.*A1*A1 & + ,BNMH=-A2X*BTG & + ,BNMM=A1*(1.-3.*C1) & + ,BSHH=9.*A1*A2X*A2X*BTG & + ,BSHM=18.*A1*A1*A2X*C1 & + ,BSMH=-3.*A1*A2X*(3.*A2X+3.*B2*C1+12.*A1*C1-B2)*BTG & + ,CESH=A2X & + ,CESM=A1*(1.-3.*C1) & + ,CNV=EP_1*G/BTG +! +!----------------------------------------------------------------------- +!*** FREE TERM IN THE EQUILIBRIUM EQUATION FOR (L/Q)**2 +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + AEQH=9.*A1*A2X*A2X*B1*BTG*BTG & + +9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + ,AEQM=3.*A1*A2X*B1*(3.*A2X+3.*B2*C1+18.*A1*C1-B2) & + *BTG+18.*A1*A1*A2X*(B2-3.*A2X)*BTG +! +!----------------------------------------------------------------------- +!*** FORBIDDEN TURBULENCE AREA +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + REQU=-AEQH/AEQM & + ,EPSGH=1.E-9,EPSGM=REQU*EPSGH +! +!----------------------------------------------------------------------- +!*** NEAR ISOTROPY FOR SHEAR TURBULENCE, WW/Q2 LOWER LIMIT +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + UBRYL=(18.*REQU*A1*A1*A2X*B2*C1*BTG & + +9.*A1*A2X*A2X*B2*BTG*BTG) & + /(REQU*ADNM+ADNH) & + ,UBRY=(1.+EPSRS)*UBRYL,UBRY3=3.*UBRY +! + REAL(KIND=KFPT),PARAMETER:: & + AUBH=27.*A1*A2X*A2X*B2*BTG*BTG-ADNH*UBRY3 & + ,AUBM=54.*A1*A1*A2X*B2*C1*BTG -ADNM*UBRY3 & + ,BUBH=(9.*A1*A2X+3.*A2X*B2)*BTG-BDNH*UBRY3 & + ,BUBM=18.*A1*A1*C1 -BDNM*UBRY3 & + ,CUBR=1. - UBRY3 & + ,RCUBR=1./CUBR +! +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!---LOOK-UP TABLES------------------------------------------------------ +INTEGER(KIND=KINT),PARAMETER:: & + ITBL=401 & ! CONVECTION TABLES, DIMENSION 1 +,JTBL=1201 & ! CONVECTION TABLES, DIMENSION 2 +,KERFM=301 & ! SIZE OF ERF HALF TABLE +,KERFM2=KERFM-2 ! INTERNAL POINTS OF ERF HALF TABLE + +REAL(KIND=KFPT),PARAMETER:: & + PL=2500. & ! LOWER BOUND OF PRESSURE RANGE +,PH=105000. & ! UPPER BOUND OF PRESSURE RANGE +,THL=210. & ! LOWER BOUND OF POTENTIAL TEMPERATURE RANGE +,THH=365. & ! UPPER BOUND OF POTENTIAL TEMPERATURE RANGE +,XEMIN=0. & ! LOWER BOUND OF ERF HALF TABLE +,XEMAX=3. ! UPPER BOUND OF ERF HALF TABLE + +REAL(KIND=KFPT),PRIVATE,SAVE:: & + RDP & ! SCALING FACTOR FOR PRESSURE +,RDQ & ! SCALING FACTOR FOR HUMIDITY +,RDTH & ! SCALING FACTOR FOR POTENTIAL TEMPERATURE +,RDTHE & ! SCALING FACTOR FOR EQUIVALENT POT. TEMPERATURE +,RDXE ! ERF HALF TABLE SCALING FACTOR + +REAL(KIND=KFPT),DIMENSION(1:ITBL),PRIVATE,SAVE:: & + STHE & ! RANGE FOR EQUIVALENT POTENTIAL TEMPERATURE +,THE0 ! BASE FOR EQUIVALENT POTENTIAL TEMPERATURE + +REAL(KIND=KFPT),DIMENSION(1:JTBL),PRIVATE,SAVE:: & + QS0 & ! BASE FOR SATURATION SPECIFIC HUMIDITY +,SQS ! RANGE FOR SATURATION SPECIFIC HUMIDITY + +REAL(KIND=KFPT),DIMENSION(1:KERFM),PRIVATE,SAVE:: & + HERFF ! HALF ERF TABLE + +REAL(KIND=KFPT),DIMENSION(1:ITBL,1:JTBL),PRIVATE,SAVE:: & + PTBL ! SATURATION PRESSURE TABLE + +REAL(KIND=KFPT),DIMENSION(1:JTBL,1:ITBL),PRIVATE,SAVE:: & + TTBL ! TEMPERATURE TABLE +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + CONTAINS +! +!----------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!----------------------------------------------------------------------- +! +! REFERENCES: JANJIC (2001), NCEP OFFICE NOTE 437 +! +! ABSTRACT: +! MYJ UPDATES THE TURBULENT KINETIC ENERGY WITH THE PRODUCTION/ +! DISSIPATION TERM AND THE VERTICAL DIFFUSION TERM +! (USING AN IMPLICIT FORMULATION) FROM MELLOR-YAMADA +! LEVEL 2.5 AS EXTENDED BY JANJIC. EXCHANGE COEFFICIENTS FOR +! THE SURFACE LAYER ARE COMPUTED FROM THE MONIN-OBUKHOV THEORY. +! THE TURBULENT VERTICAL EXCHANGE IS THEN EXECUTED. +! +!----------------------------------------------------------------------- + SUBROUTINE MYJPBL(NTSD,ME,DT_PHS,EPSL,EPSQ2,HT,STDH,DZ,DEL & + ,PMID,PINH,TH,T,EXNER,Q,CWM,U,V & + ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0 & + ,XLAND,SICE,SNOW & + ,Q2,EXCH_H,USTAR,Z0,EL_MYJ,PBLH,KPBL,CT & + ,AKHS,AKMS,ELFLX,MIXHT,THLM,QLM & + ,RUBLTEN,RVBLTEN,RTHBLTEN,RQBLTEN,RQCBLTEN & + ,DUSFC,DVSFC,DTSFC,DQSFC,xkzo,xkzmo,ICT & + ,IDS,IDE,JDS,JDE & + ,IMS,IME,JMS,JME & + ,ITS,ITE,JTS,JTE,LM) + +! SUBROUTINE MYJPBL(DT,NPHS,EPSL,EPSQ2,HT,STDH,DZ & +! ,PMID,PINH,TH,T,EXNER,Q,CWM,U,V & +! ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0 & +! ,XLAND,SICE,SNOW & +! ,Q2,EXCH_H,USTAR,Z0,EL_MYJ,PBLH,KPBL,CT & +! ,AKHS,AKMS,ELFLX,MIXHT & +! ,RUBLTEN,RVBLTEN,RTHBLTEN,RQBLTEN,RQCBLTEN & +! ,IDS,IDE,JDS,JDE & +! ,IMS,IME,JMS,JME & +! ,ITS,ITE,JTS,JTE,LM) + +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! + logical(kind=klog),save:: & + reinit +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + IDS,IDE,JDS,JDE & + ,IMS,IME,JMS,JME & + ,ITS,ITE,JTS,JTE,LM +! + INTEGER,INTENT(IN) :: ICT,ME,NTSD + +! INTEGER(KIND=KINT),INTENT(IN):: & +! NPHS +! + INTEGER(KIND=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT):: & + KPBL +! + REAL(KIND=KFPT),INTENT(IN):: & + DT_PHS +! DT +! + real(kind=kfpt),dimension(1:lm-1),intent(inout):: EPSL + real(kind=kfpt),dimension(1:lm),intent(in):: EPSQ2 +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN):: & + HT,SICE,SNOW,STDH & + ,TSK,XLAND & + ,CHKLOWQ,ELFLX,THLM,QLM +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN):: & + DZ,EXNER,PMID,Q,CWM,U,V,T,TH,DEL,xkzo,xkzmo +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN):: & + PINH +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT):: & + MIXHT & + ,PBLH +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT):: & + EL_MYJ +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT):: & + RQCBLTEN & + ,RUBLTEN,RVBLTEN & + ,RTHBLTEN,RQBLTEN +! + REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: & + DUSFC,DVSFC & + ,DTSFC,DQSFC +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: & + AKHS,AKMS +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: & + CT,QSFC,QZ0 & + ,THZ0,USTAR & + ,UZ0,VZ0,Z0 +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT):: & + EXCH_H & + ,Q2 +! +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + I,IQTB,ITTB,J,K,LLOW,LMH,LMXL +! + INTEGER(KIND=KINT),DIMENSION(IMS:IME,JMS:JME):: & + LPBL +! + REAL(KIND=KFPT):: & + AKHS_DENS,AKMS_DENS,BQ,BQS00K,BQS10K & + ,DCDT,DELTAZ,DQDT,DTDIF,DTDT,DTTURBL & + ,P00K,P01K,P10K,P11K,PELEVFC,PP1,PSFC,PSP,PTOP & + ,QBT,QFC1,QLOW,QQ1,QX & + ,RDTTURBL,RG,RSQDT,RXNERS,RXNSFC & + ,SEAMASK,SQ,SQS00K,SQS10K & + ,THBT,THNEW,THOLD,TQ,TTH & + ,ULOW,VLOW,RSTDH,STDFAC,ZSF,ZSX,ZSY,ZUV +! + REAL(KIND=KFPT),DIMENSION(1:LM):: & + CWMK,PK,PSK,Q2K,QK,RHOK,RXNERK,THEK,THK,THVK,TK,UK,VK +! + REAL(KIND=KFPT),DIMENSION(1:LM-1):: & + AKHK,AKMK,DCOL,EL,GH,GM +! + REAL(KIND=KFPT),DIMENSION(1:LM+1):: & + ZHK +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME):: & + THSK +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM):: & + RXNER,THV +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM-1):: & + AKH,AKM +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1):: & + ZINT +! +!*** Begin debugging + REAL(KIND=KFPT):: ZSL_DIAG + INTEGER(KIND=KINT):: IMD,JMD,PRINT_DIAG +!*** End debugging +!----------------------------------------------------------------------- +!*********************************************************************** + data reinit/.false./ +!----------------------------------------------------------------------- +! if(reinit) then +! call MYJPBL_INIT( & +! 1,IDE,1,1,LM, & +! 1,IDE,1,1, & +! 1,IDE,1,1) +! reinit=.false. +! endif +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! +!*** Begin debugging + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 +!*** End debugging +! +!*** MAKE PREPARATIONS +! +!---------------------------------------------------------------------- + STDFAC=1. +!---------------------------------------------------------------------- +! DTTURBL=DT*NPHS + DTTURBL=DT_PHS + RDTTURBL=1./DTTURBL + RSQDT=SQRT(RDTTURBL) + DTDIF=DTTURBL + RG=1./G +! + DO K=1,LM-1 + DO J=JTS,JTE + DO I=ITS,ITE + AKM(I,J,K)=0. + ENDDO + ENDDO + ENDDO +! + DO K=1,LM+1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=0. + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,LM+1)=HT(I,J) ! Z AT BOTTOM OF LOWEST SIGMA LAYER + ENDDO + ENDDO +! + DO K=LM,1,-1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=ZINT(I,J,K+1)+DZ(I,J,K) + RXNER(I,J,K)=1./EXNER(I,J,K) + THV(I,J,K)=(Q(I,J,K)*0.608+(1.-CWM(I,J,K)))*TH(I,J,K) + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + EL_MYJ(I,J,LM)=0. + ENDDO + ENDDO + DO J=JTS,JTE + DO I=ITS,ITE + DUSFC(I,J)=0. + DVSFC(I,J)=0. + DTSFC(I,J)=0. + DQSFC(I,J)=0. + ENDDO + ENDDO + +! +!---------------------------------------------------------------------- +!....................................................................... +!ZJ$OMP PARALLEL DO & +!ZJ$OMP PRIVATE(J,I,LMH,PTOP,PSFC,SEAMASK,K,TK,THVK,QK,Q2K,RXNERK, & +!ZJ$OMP PK,UK,VK,Q2K,ZHK,LMXL,GM,GH,EL,AKMK,AKHK,DELTAZ), & +!ZJ$OMP SCHEDULE(DYNAMIC) +!....................................................................... +!---------------------------------------------------------------------- + setup_integration: DO J=JTS,JTE +!---------------------------------------------------------------------- +! + DO I=ITS,ITE +! + LMH=LM +! + PTOP=PINH(I,J,1) + PSFC=PINH(I,J,LMH+1) +! +!*** CONVERT LAND MASK (1 FOR SEA; 0 FOR LAND) +! + SEAMASK=XLAND(I,J)-1. +! +!*** FILL 1-D VERTICAL ARRAYS +! + DO K=LM,1,-1 + PK(K)=PMID(I,J,K) + TK(K)=T(I,J,K) + QK(K)=Q(I,J,K) + THVK(K)=THV(I,J,K) + RXNERK(K)=RXNER(I,J,K) + UK(K)=U(I,J,K) + VK(K)=V(I,J,K) + Q2K(K)=Q2(I,J,K) +! +!*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES +! + ZHK(K)=ZINT(I,J,K) +! + ENDDO + ZHK(LM+1)=HT(I,J) ! Z AT BOTTOM OF LOWEST SIGMA LAYER +! +!*** POTENTIAL INSTABILITY +! + PELEVFC=PMID(I,J,LMH)*ELEVFC +! + DO K=LMH,1,-1 +!----------------------------------------------------------------------- + IF(K==LMH .OR. PMID(I,J,K)>PELEVFC) THEN +!---PREPARATION FOR SEARCH FOR MAX CAPE--------------------------------- + QBT=QK(K) + THBT=TH(I,J,K) + TTH=(THBT-THL)*RDTH + QQ1=TTH-AINT(TTH) + ITTB=INT(TTH)+1 +!---KEEPING INDICES WITHIN THE TABLE------------------------------------ + IF(ITTB.LT.1)THEN + ITTB=1 + QQ1=0. + ELSE IF(ITTB.GE.JTBL)THEN + ITTB=JTBL-1 + QQ1=0. + ENDIF +!---BASE AND SCALING FACTOR FOR SPEC. HUMIDITY-------------------------- + BQS00K=QS0(ITTB) + SQS00K=SQS(ITTB) + BQS10K=QS0(ITTB+1) + SQS10K=SQS(ITTB+1) +!--------------SCALING SPEC. HUMIDITY & TABLE INDEX--------------------- + BQ=(BQS10K-BQS00K)*QQ1+BQS00K + SQ=(SQS10K-SQS00K)*QQ1+SQS00K + TQ=(QBT-BQ)/SQ*RDQ + PP1=TQ-AINT(TQ) + IQTB=INT(TQ)+1 +!----------------KEEPING INDICES WITHIN THE TABLE----------------------- + IF(IQTB.LT.1)THEN + IQTB=1 + PP1=0. + ELSEIF(IQTB.GE.ITBL)THEN + IQTB=ITBL-1 + PP1=0. + ENDIF +!--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.------- + P00K=PTBL(IQTB ,ITTB ) + P10K=PTBL(IQTB+1,ITTB ) + P01K=PTBL(IQTB ,ITTB+1) + P11K=PTBL(IQTB+1,ITTB+1) +!--------------SATURATION POINT VARIABLES AT THE BOTTOM----------------- + PSP=P00K+(P10K-P00K)*PP1+(P01K-P00K)*QQ1 & + +(P00K-P10K-P01K+P11K)*PP1*QQ1 + RXNERS=(1.E5/PSP)**CAPPA + THEK(K)=THBT*EXP(ELOCP*QBT*RXNERS/THBT) + PSK (K)=PSP +!----------------------------------------------------------------------- + ELSE +!----------------------------------------------------------------------- + THEK(K)=THEK(K+1) + PSK (K)=PINH(I,J,1) +!----------------------------------------------------------------------- + ENDIF +!----------------------------------------------------------------------- + ENDDO +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=1 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=2 +!*** End debugging +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE MIXING LENGTH +!*** + CALL MIXLEN(LMH,RSQDT,UK,VK,THVK,THEK & + ,Q2K,EPSL,EPSQ2,ZHK,PK,PSK,RXNERK,GM,GH,EL & + ,PBLH(I,J),LPBL(I,J),LMXL,CT(I,J),MIXHT(I,J) & + ,I,J,LM) +! +!---------------------------------------------------------------------- +!*** +!*** SOLVE FOR THE PRODUCTION/DISSIPATION OF +!*** THE TURBULENT KINETIC ENERGY +!*** +! + CALL PRODQ2(NTSD,ME,LMH,DTTURBL,USTAR(I,J),GM,GH,EL,Q2K & + ,EPSL,EPSQ2,I,J,LM) + +! if(i.eq.4)print*,'11ql test Q2(LMH)=',Q2K(LMH),B1,USTAR(I,J) +! +!---------------------------------------------------------------------- +!*** THE MODEL LAYER (COUNTING UPWARD) CONTAINING THE TOP OF THE PBL +!---------------------------------------------------------------------- +! + KPBL(I,J)=LPBL(I,J) +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE EXCHANGE COEFFICIENTS IN THE FREE ATMOSPHERE +!*** + CALL DIFCOF(NTSD,ME,LMH,LMXL,GM,GH,EL,TK,Q2K,ZHK,AKMK,AKHK,I,J,LM & + ,PRINT_DIAG,KPBL(I,J)) +! +!*** COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH +!*** ARE DEFINED ON THE BOTTOMS OF THE LAYERS 1 TO LM-1. COUNTING +!*** COUNTING UPWARD FROM THE BOTTOM, THOSE SAME COEFFICIENTS EXCH_H +!*** ARE DEFINED ON THE TOPS OF THE LAYERS 1 TO LM-1. +! + DO K=1,LM-1 + + DELTAZ=0.5*(ZHK(K)-ZHK(K+2)) + AKHK(K)=max(AKHK(K),xkzo(I,J,K)/DELTAZ) ! add minimum background diffusion + AKMK(K)=max(AKMK(K),xkzmo(I,J,K)/DELTAZ) + if((THVK(LM)-THVK(K)).GT.0.) then + AKHK(K)=max(AKHK(K),3./DELTAZ) ! add minimum background diffusion + AKMK(K)=max(AKMK(K),3./DELTAZ) + end if + AKH(I,J,K)=AKHK(K) + AKM(I,J,K)=AKMK(K) + EXCH_H(I,J,K)=AKHK(K)*DELTAZ + ENDDO +! +!---------------------------------------------------------------------- +!*** +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TURBULENT KINETIC ENERGY +!*** +! + CALL VDIFQ(LMH,DTDIF,Q2K,EL,ZHK,I,J,LM) +! +!*** SAVE THE NEW Q2 AND MIXING LENGTH. +! + DO K=1,LM + Q2(I,J,K)=MAX(Q2K(K),EPSQ2(K)) + IF(K0..OR.SICE(I,J)>0.5)THEN + QFC1=QFC1*RLIVWV + ENDIF +! + IF(QFC1>0.)THEN + QLOW=QK(LM) +!ql QSFC(I,J)=QLOW+ELFLX(I,J)/QFC1 + ENDIF +! + ELSE + PSFC=PINH(I,J,LM+1) + RXNSFC=(1.E5/PSFC)**CAPPA + +!ql QSFC(I,J)=PQ0SEA/PSFC & +!ql & *EXP(A2*(THSK(I,J)-A3*RXNSFC)/(THSK(I,J)-A4*RXNSFC)) + ENDIF +! + QZ0 (I,J)=(1.-SEAMASK)*QSFC(I,J)+SEAMASK*QZ0 (I,J) +! + LMH=LM +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TEMPERATURE AND WATER VAPOR +!---------------------------------------------------------------------- +! + CALL VDIFH(DTDIF,LMH,THZ0(I,J),QZ0(I,J) & + ,AKHS_DENS,CHKLOWQ(I,J),CT(I,J) & + ,THK,QK,CWMK,AKHK,ZHK,RHOK,I,J,LM) +!---------------------------------------------------------------------- +!*** +! QL set lower bondary +! THK(LM)=THLM(I,J) +! QK(LM)=QLM(I,J) +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=1,LM + RTHBLTEN(I,J,K)=(THK(K)-TH(I,J,K))*RDTTURBL + RQBLTEN(I,J,K)=(QK(K)-Q(I,J,K))*RDTTURBL + RQCBLTEN(I,J,K)=(CWMK(K)-CWM(I,J,K))*RDTTURBL + DTSFC(I,J)=DTSFC(I,J)+CONT*DEL(I,J,K)*RTHBLTEN(I,J,K)*EXNER(I,J,K) + DQSFC(I,J)=DQSFC(I,J)+CONQ*DEL(I,J,K)*RQBLTEN(I,J,K) + ENDDO +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=0 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=0 +!*** End debugging +! + PSFC=.01*PINH(I,J,LM+1) + ZSL_DIAG=0.5*DZ(I,J,LM) +! +!*** Begin debugging +! IF(PRINT_DIAG==1)THEN +! +! WRITE(6,"(A, 2I5, 2I3, 2F8.2, F6.2, 2F8.2)") & +! '{TURB4 I,J, KPBL, KMXL, PSFC, ZSFC, ZSL, ZPBL, ZMXL = ' & +! , I, J, KPBL(I,J), LM-LMXL+1, PSFC, ZHK(LMH+1), ZSL_DIAG & +! , PBLH(I,J), ZHK(LMXL)-ZHK(LMH+1) +! WRITE(6,"(A, 2F7.2, F7.3, 3E11.4)") & +! '{TURB4 TSK, THSK, QZ0, Q**2_0, AKHS, EXCH_0 = ' & +! , TSK(I,J)-273.15, THSK(I,J), 1000.*QZ0(I,J) & +! , Q2(I,1,J), AKHS(I,J), AKHS(I,J)*ZSL_DIAG +! WRITE(6,"(A)") & +! '{TURB5 K, PMID, PINH_1, TC, TH, DTH, GH, GM, EL, Q**2, AKH, EXCH_H, DZ, DP' +! DO K=1,LM/2 +! WRITE(6,"(A,I3, 2F8.2, 2F8.3, 3E12.4, 4E11.4, F7.2, F6.2)") & +! '{TURB5 ', K, .01*PMID(I,K,J),.01*PINH(I,K,J), T(I,K,J)-273.15 & +! , TH(I,K,J), DTTURBL*RTHBLTEN(I,K,J), GH(K), GM(K) & +! , EL_MYJ(I,K,J), Q2(I,K+1,J), AKH(I,K,J) & +! , EXCH_H(I,K,J), DZ(I,K,J), .01*(PINH(I,K,J)-PINH(I,K+1,J)) +! ENDDO +! +! ELSEIF(PRINT_DIAG==2)THEN +! +! WRITE(6,"(A, 2I5, 2I3, 2F8.2, F6.2, 2F8.2)") & +! '}TURB4 I,J, KPBL, KMXL, PSFC, ZSFC, ZSL, ZPBL, ZMXL = ' & +! , I, J, KPBL(I,J), LM-LMXL+1, PSFC, ZHK(LMH+1), ZSL_DIAG & +! , PBLH(I,J), ZHK(LMXL)-ZHK(LMH+1) +! WRITE(6,"(A, 2F7.2, F7.3, 3E11.4)") & +! '}TURB4 TSK, THSK, QZ0, Q**2_0, AKHS, EXCH_0 = ' & +! , TSK(I,J)-273.15, THSK(I,J), 1000.*QZ0(I,J) & +! , Q2(I,1,J), AKHS(I,J), AKHS(I,J)*ZSL_DIAG +! WRITE(6,"(A)") & +! '}TURB5 K, PMID, PINH_1, TC, TH, DTH, GH, GM, EL, Q**2, AKH, EXCH_H, DZ, DP' +! DO K=1,LM/2 +! WRITE(6,"(A,I3, 2F8.2, 2F8.3, 3E12.4, 4E11.4, F7.2, F6.2)") & +! '}TURB5 ', K, .01*PMID(I,K,J),.01*PINH(I,K,J), T(I,K,J)-273.15 & +! , TH(I,K,J), DTTURBL*RTHBLTEN(I,K,J), GH(K), GM(K) & +! , EL_MYJ(I,K,J), Q2(I,K+1,J), AKH(I,K,J) & +! , EXCH_H(I,K,J), DZ(I,K,J), .01*(PINH(I,K,J)-PINH(I,K+1,J)) +! ENDDO +! ENDIF +!*** End debugging +! +!---------------------------------------------------------------------- +! + SEAMASK=XLAND(I,J)-1. +! + IF(SEAMASK.LT.0.5.AND.STDH(I,J).GT.1.) THEN + RSTDH=1./STDH(I,J) + ELSE + RSTDH=0. + ENDIF + ZHK(LM+1)=ZINT(I,J,LM+1) + ZSF=STDH(I,J)*STDFAC+ZHK(LM+1) +! +!---------------------------------------------------------------------- +! +!*** FILL 1-D VERTICAL ARRAYS +! + DO K=1,LM-1 + AKMK(K)=AKM(I,J,K) + AKMK(K)=AKMK(K)*(RHOK(K)+RHOK(K+1))*0.5 + ENDDO +! + AKMS_DENS=AKMS(I,J)*RHOK(LM) +! + DO K=LM,1,-1 + UK(K)=U(I,J,K) + VK(K)=V(I,J,K) + ZHK(K)=ZINT(I,J,K) + ENDDO + ZHK(LM+1)=ZINT(I,J,LM+1) +! +!---------------------------------------------------------------------- +! + DO K=1,LM-1 +!jun23 IF(SEAMASK.GT.0.5) THEN +!jun23 DCOL(K)=0. +!jun23 ELSE +!jun23 ZUV=(ZHK(K)+ZHK(K+1))*0.5 +!jun23 IF(ZUV.GT.ZSF) THEN +!jun23 DCOL(K)=0. +!jun23 ELSE +!jun23 DCOL(K)=HERF((((ZUV-ZHK(LM+1))*RSTDH)**2)*0.5) +!jun23 ENDIF +!jun23 ENDIF +!WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW + DCOL(K)=0. !ZJ +!MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM + ENDDO +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** VELOCITY COMPONENTS +!---------------------------------------------------------------------- +! + CALL VDIFV(LMH,DTDIF,UZ0(I,J),VZ0(I,J) & + & ,AKMS_DENS,DCOL,UK,VK,AKMK,ZHK,RHOK,I,J,LM) +! +!---------------------------------------------------------------------- +!*** +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=1,LM + RUBLTEN(I,J,K)=(UK(K)-U(I,J,K))*RDTTURBL + RVBLTEN(I,J,K)=(VK(K)-V(I,J,K))*RDTTURBL + DUSFC(I,J)=DUSFC(I,J)+CONW*DEL(I,J,K)*RUBLTEN(I,J,K) + DVSFC(I,J)=DVSFC(I,J)+CONW*DEL(I,J,K)*RVBLTEN(I,J,K) + ENDDO +! + ENDDO +!---------------------------------------------------------------------- +! + ENDDO main_integration +!JAA!ZJ$OMP END PARALLEL DO +! +!---------------------------------------------------------------------- +! + END SUBROUTINE MYJPBL +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE MIXLEN & +!---------------------------------------------------------------------- +! ****************************************************************** +! * * +! * LEVEL 2.5 MIXING LENGTH * +! * * +! ****************************************************************** +! + (LMH,RSQDT,U,V,THV,THE,Q2,EPSL,EPSQ2,Z,P,PS,RXNER & + ,GM,GH,EL,PBLH,LPBL,LMXL,CT,MIXHT,I,J,LM) +! +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + LMH,I,J,LM +! + REAL(KIND=KFPT),INTENT(IN):: & + RSQDT +! + INTEGER(KIND=KINT),INTENT(OUT):: & + LMXL,LPBL +! + real(kind=kfpt),dimension(1:lm-1),intent(inout):: EPSL + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(IN):: & + P,PS,EPSQ2,RXNER,THE,THV,U,V +! P,PS,Q2,EPSQ2,RXNER,THE,THV,U,V +! + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(INOUT):: Q2 +! + REAL(KIND=KFPT),DIMENSION(1:LM+1),INTENT(IN):: & + Z +! + REAL(KIND=KFPT),INTENT(OUT):: & + MIXHT & + ,PBLH +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(OUT):: & + EL,GH,GM +! + REAL(KIND=KFPT),INTENT(INOUT):: CT +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + K,LPBLM +! + REAL(KIND=KFPT):: & + ADEN,BDEN,AUBR,BUBR,BLMX,CUBRY,DTHV,DZ & + ,EL0,ELOQ2X,GHL,GML & + ,QOL2ST,QOL2UN,QDZL & + ,RDZ,SQ,SREL,SZQ,VKRMZ,WCON +! + REAL(KIND=KFPT),DIMENSION(1:LM):: & + Q1 +! + REAL(KIND=KFPT),DIMENSION(1:LM-1):: & + ELM,REL +! +!---------------------------------------------------------------------- +!*********************************************************************** +!--------1---------2---------3---------4---------5---------6---------7-- + CUBRY=UBRY*1.5 !*2. +!--------------FIND THE HEIGHT OF THE PBL------------------------------- + LPBL=LMH +! LPBL=LMH-1 + DO K=LMH-1,1,-1 +! EPSL(K)=1. + if((THV(LMH)-THV(K)).GT.0.) then + Q2(K)=max(Q2(K),1.0) + EPSL(K)=10. + ENDIF + ENDDO +! + DO K=LMH-1,1,-1 + if(q2(k)-epsq2(k)+epsq2(lm).le.epsq2(lm)*fh) then + LPBL=K + GO TO 110 + ENDIF + ENDDO +! + LPBL=1 +! +!--------------THE HEIGHT OF THE PBL------------------------------------ +! + 110 PBLH=Z(LPBL+1)-Z(LMH+1) +! +!----------------------------------------------------------------------- + DO K=1,LMH + Q1(K)=0. + ENDDO +!----------------------------------------------------------------------- + DO K=1,LMH-1 + DZ=(Z(K)-Z(K+2))*0.5 + RDZ=1./DZ + GML=((U(K)-U(K+1))**2+(V(K)-V(K+1))**2)*RDZ*RDZ + GM(K)=MAX(GML,EPSGM) +! + DTHV=THV(K)-THV(K+1) +!---------------------------------------------------------------------- + IF(DTHV.GT.0.) THEN + IF(THE(K+1).GT.THE(K)) THEN + IF(PS(K+1).GT.P(K)) THEN !>12KM +! + WCON=(P(K+1)-PS(K+1))/(P(K+1)-P(K)) +! + if( & + (q2(k).gt.epsq2(k)) .and. & + (q2(k)*cubry.gt.(dz*wcon*rsqdt)**2) & + ) then +! + DTHV=(THE(K)-THE(K+1))+DTHV +! + ENDIF + ENDIF + ENDIF + ENDIF +!-------------------------------------------------------------------------- +! + GHL=DTHV*RDZ + IF(ABS(GHL)<=EPSGH)GHL=EPSGH + GH(K)=GHL + ENDDO +! + CT=0. +! +!---------------------------------------------------------------------- +!*** FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP +!---------------------------------------------------------------------- +! + LMXL=LMH +! + DO K=1,LMH-1 + GML=GM(K) + GHL=GH(K) +! + IF(GHL>=EPSGH)THEN + IF(GML/GHL<=REQU)THEN + ELM(K)=EPSL(K) + LMXL=K+1 + ELSE + AUBR=(AUBM*GML+AUBH*GHL)*GHL + BUBR= BUBM*GML+BUBH*GHL + QOL2ST=(-0.5*BUBR+SQRT(BUBR*BUBR*0.25-AUBR*CUBR))*RCUBR + ELOQ2X=1./MAX(EPSGH, QOL2ST) + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL(K)) + ENDIF + ELSE + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + QOL2UN=-0.5*BDEN+SQRT(BDEN*BDEN*0.25-ADEN) + ELOQ2X=1./(QOL2UN+EPSRU) ! REPSR1/QOL2UN + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL(K)) + ENDIF + ENDDO +! + IF(ELM(LMH-1)==EPSL(LMH-1))LMXL=LMH +! +!---------------------------------------------------------------------- +!*** THE HEIGHT OF THE MIXED LAYER +!---------------------------------------------------------------------- +! + BLMX=Z(LMXL)-Z(LMH+1) + MIXHT=BLMX +! +!---------------------------------------------------------------------- + DO K=LPBL,LMH + Q1(K)=SQRT(Q2(K)) + ENDDO +!---------------------------------------------------------------------- + SZQ=0. + SQ =0. +! + DO K=1,LMH-1 + QDZL=(Q1(K)+Q1(K+1))*(Z(K+1)-Z(K+2)) + SZQ=(Z(K+1)+Z(K+2)-Z(LMH+1)-Z(LMH+1))*QDZL+SZQ + SQ=QDZL+SQ + ENDDO +! +!---------------------------------------------------------------------- +!*** COMPUTATION OF ASYMPTOTIC L IN BLACKADAR FORMULA +!---------------------------------------------------------------------- +! + EL0=MIN(ALPH*SZQ*0.5/SQ,EL0MAX) + EL0=MAX(EL0 ,EL0MIN) +! +!---------------------------------------------------------------------- +!*** ABOVE THE PBL TOP +!---------------------------------------------------------------------- +! + LPBLM=MAX(LPBL-1,1) +! + DO K=1,LPBLM + EL(K)=MIN((Z(K)-Z(K+2))*ELFC,ELM(K)) + REL(K)=EL(K)/ELM(K) + ENDDO +! +!---------------------------------------------------------------------- +!*** INSIDE THE PBL +!---------------------------------------------------------------------- +! + IF(LPBL=EPSGH.AND.GML/GHL<=REQU) & + & .OR.(EQOL2<=EPS2)))THEN +! & .OR.(EQOL2<=EPS2)).and.IFLAG.EQ.1)THEN +! +! if(ntsd.eq.23.and.me.eq.76.and.I.eq.32)then +! print*,'no turb=',K,GML,GHL,EPSTRB,EPSGH,REQU,EQOL2,EPS2,GML/GHL +! end if +!---------------------------------------------------------------------- +!*** NO TURBULENCE +!---------------------------------------------------------------------- +! + Q2(K)=EPSQ2(K) + EL(K)=EPSL(K) +! IFLAG=2 +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** TURBULENCE +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE NUMERATOR +!---------------------------------------------------------------------- +! + ANUM=(ANMM*GML+ANMH*GHL)*GHL + BNUM= BNMM*GML+BNMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE NUMERATOR OF THE LINEARIZED EQ. +!---------------------------------------------------------------------- +! + ARHS=-(ANUM*BDEN-BNUM*ADEN)*2. + BRHS=- ANUM*4. + CRHS=- BNUM*2. +! +!---------------------------------------------------------------------- +!*** INITIAL VALUE OF L/Q +!---------------------------------------------------------------------- +! + DLOQ1=EL(K)/SQRT(Q2(K)) +! +!---------------------------------------------------------------------- +!*** FIRST ITERATION FOR L/Q, RHS=0 +!---------------------------------------------------------------------- +! + ELOQ21=1./EQOL2 + ELOQ11=SQRT(ELOQ21) + ELOQ31=ELOQ21*ELOQ11 + ELOQ41=ELOQ21*ELOQ21 + ELOQ51=ELOQ21*ELOQ31 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN1=1./(ADEN*ELOQ41+BDEN*ELOQ21+CDEN) +! +!---------------------------------------------------------------------- +!*** D(RHS)/D(L/Q) +!---------------------------------------------------------------------- +! + RHSP1=(ARHS*ELOQ51+BRHS*ELOQ31+CRHS*ELOQ11)*RDEN1*RDEN1 +! +!---------------------------------------------------------------------- +!*** FIRST-GUESS SOLUTION +!---------------------------------------------------------------------- +! + ELOQ12=ELOQ11+(DLOQ1-ELOQ11)*EXP(RHSP1*DTTURBL) + ELOQ12=MAX(ELOQ12,EPS1) +! +!---------------------------------------------------------------------- +!*** SECOND ITERATION FOR L/Q +!---------------------------------------------------------------------- +! + ELOQ22=ELOQ12*ELOQ12 + ELOQ32=ELOQ22*ELOQ12 + ELOQ42=ELOQ22*ELOQ22 + ELOQ52=ELOQ22*ELOQ32 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN2=1./(ADEN*ELOQ42+BDEN*ELOQ22+CDEN) + RHS2 =-(ANUM*ELOQ42+BNUM*ELOQ22)*RDEN2+RB1 + RHSP2= (ARHS*ELOQ52+BRHS*ELOQ32+CRHS*ELOQ12)*RDEN2*RDEN2 + RHST2=RHS2/RHSP2 +! +!---------------------------------------------------------------------- +!*** CORRECTED SOLUTION +!---------------------------------------------------------------------- +! + ELOQ13=ELOQ12-RHST2+(RHST2+DLOQ1-ELOQ12)*EXP(RHSP2*DTTURBL) + ELOQ13=AMAX1(ELOQ13,EPS1) +! +!---------------------------------------------------------------------- +!*** TWO ITERATIONS IS ENOUGH IN MOST CASES ... +!---------------------------------------------------------------------- +! + ELOQN=ELOQ13 +! + IF(ELOQN>EPS1)THEN + Q2(K)=EL(K)*EL(K)/(ELOQN*ELOQN) + Q2(K)=AMAX1(Q2(K),EPSQ2(K)) + IF(Q2(K)==EPSQ2(K))THEN + EL(K)=EPSL(K) + ENDIF + ELSE + Q2(K)=EPSQ2(K) + EL(K)=EPSL(K) + ENDIF +! +!---------------------------------------------------------------------- +!*** END OF TURBULENT BRANCH +!---------------------------------------------------------------------- +! + ENDIF +!---------------------------------------------------------------------- +!*** END OF PRODUCTION/DISSIPATION LOOP +!---------------------------------------------------------------------- +! + ENDDO main_integration +! +!---------------------------------------------------------------------- +!*** LOWER BOUNDARY CONDITION FOR Q2 +!---------------------------------------------------------------------- +! + Q2(LMH)=AMAX1(B1**(2./3.)*USTAR*USTAR,EPSQ2(LMH)) +! if(I.eq.4)print*,'12ql test Q2(LMH)=',LMH,Q2(LMH),B1,USTAR + +!---------------------------------------------------------------------- +! + END SUBROUTINE PRODQ2 +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE DIFCOF & +! ****************************************************************** +! * * +! * LEVEL 2.5 DIFFUSION COEFFICIENTS * +! * * +! ****************************************************************** + (NTSD,ME,LMH,LMXL,GM,GH,EL,T,Q2,Z,AKM,AKH,I,J,LM,PRINT_DIAG,KPBL) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + LMH,LMXL,I,J,LM,ME,NTSD,KPBL +! + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(IN):: & + Q2,T +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(IN):: & + EL,GH,GM +! + REAL(KIND=KFPT),DIMENSION(1:LM+1),INTENT(IN):: & + Z +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(OUT):: & + AKH,AKM +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + K,KINV +! + REAL(KIND=KFPT):: & + ADEN,AKMIN,BDEN,BESH,BESM,CDEN,D2T,ELL,ELOQ2,ELOQ4,ELQDZ & + ,ESH,ESM,GHL,GML,Q1L,RDEN,RDZ +! +!*** Begin debugging + INTEGER(KIND=KINT),INTENT(IN):: PRINT_DIAG +! REAL(KIND=KFPT):: D2TMIN +!*** End debugging +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! + DO K=1,LMH-1 + ELL=EL(K) +! + ELOQ2=ELL*ELL/Q2(K) + ELOQ4=ELOQ2*ELOQ2 +! + GML=GM(K) + GHL=GH(K) +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SM DETERMINANT +!---------------------------------------------------------------------- +! + BESM=BSMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SH DETERMINANT +!---------------------------------------------------------------------- +! + BESH=BSHM*GML+BSHH*GHL +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN=1./(ADEN*ELOQ4+BDEN*ELOQ2+CDEN) +! +!---------------------------------------------------------------------- +!*** SM AND SH +!---------------------------------------------------------------------- +! + ESM=(BESM*ELOQ2+CESM)*RDEN + ESH=(BESH*ELOQ2+CESH)*RDEN +! +!---------------------------------------------------------------------- +!*** DIFFUSION COEFFICIENTS +!---------------------------------------------------------------------- +! + RDZ=2./(Z(K)-Z(K+2)) + Q1L=SQRT(Q2(K)) + ELQDZ=ELL*Q1L*RDZ + AKM(K)=ELQDZ*ESM + AKH(K)=ELQDZ*ESH +! if(NTSD.gt.22.and.me.eq.76.and.I.eq.32)then +! if(AKM(K).lt.RDZ*3.)then +! print*,'1K,ELQDZ,ESH,ELL,Q1L,RDZ,Q2=',K,ELQDZ,ESH & +! ,ELL,Q1L,RDZ,Q2(K),BESH,ELOQ2,CESH,RDEN & +! ,ADEN,ELOQ4,BDEN,CDEN,BSHM,GML,BSHH,GHL,BSMH & +! ,BDNM,BDNH,ADNM,ADNH +! else +! print*,'2K,ELQDZ,ESH,ELL,Q1L,RDZ,Q2=',K,ELQDZ,ESH & +! ,ELL,Q1L,RDZ,Q2(K),BESH,ELOQ2,CESH,RDEN & +! ,ADEN,ELOQ4,BDEN,CDEN,BSHM,GML,BSHH,GHL,BSMH & +! ,BDNM,BDNH,ADNM,ADNH +! end if +! if(K.eq.(LMH-1))stop +! end if +!WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW +! if(K.gt.KPBL)then +! AKM(K)=MAX(AKM(K),RDZ*3.) +! AKH(K)=MAX(AKH(K),RDZ*3.) +! end if +! AKM(K)=MAX(AKM(K),RDZ*3.) +! AKH(K)=MAX(AKH(K),RDZ*3.) +! AKM(K)=MAX(AKM(K),RDZ) +! AKH(K)=MAX(AKH(K),RDZ) +!MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM +!---------------------------------------------------------------------- + ENDDO +! qingfu test +! K=LM-1 +! RDZ=2./(Z(K)-Z(K+2)) +! AKH(LM-1)=AKH(LM-1)*10. +! AKM(K)=MAX(AKM(K),RDZ*3.)*10. +! AKH(K)=MAX(AKH(K),RDZ*3.)*10. +!---------------------------------------------------------------------- +! +!---------------------------------------------------------------------- +!*** INVERSIONS +!---------------------------------------------------------------------- +! +! IF(LMXL==LMH)THEN +! KINV=LMH +! D2TMIN=0. +! +! DO K=LMH/2,LMH-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! IF(D2T0)THEN +! WRITE(6,"(A,3I3)") '{TURB1 LMXL,LMH,KINV=',LMXL,LMH,KINV +! WRITE(6,"(A,3I3)") '}TURB1 LMXL,LMH,KINV=',LMXL,LMH,KINV +! IF(PRINT_DIAG==1)THEN +! WRITE(6,"(A)") & +! '{TURB3 K, T, D2T, RDZ, Z(K), Z(K+2), AKMIN, AKH ' +! ELSE +! WRITE(6,"(A)") & +! '}TURB3 K, T, D2T, RDZ, Z(K), Z(K+2), AKMIN, AKH ' +! ENDIF +! DO K=LMH-1,KINV-1,-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! RDZ=2./(Z(K)-Z(K+2)) +! AKMIN=0.5*RDZ +! IF(PRINT_DIAG==1)THEN +! WRITE(6,"(A,I3,F8.3,2E12.5,2F9.2,2E12.5)") '{TURB3 ' & +! ,K,T(K)-273.15,D2T,RDZ,Z(K),Z(K+2),AKMIN,AKH(K) +! ELSE +! WRITE(6,"(A,I3,F8.3,2E12.5,2F9.2,2E12.5)") '}TURB3 ' & +! ,K,T(K)-273.15,D2T,RDZ,Z(K),Z(K+2),AKMIN,AKH(K) +! ENDIF +! ENDDO +! ENDIF !- IF (PRINT_DIAG > 0) THEN +! ENDIF !- IF(KINV Date: Fri, 30 Aug 2019 16:07:57 -0600 Subject: [PATCH 13/59] add calculation of sncovr to GFS_surface_generic_pre_run (not to init because it was originally done after the call to ccpp_physics_init in FV3GFS_io.F90/sfc_prop_restart_read --- physics/GFS_surface_generic.F90 | 45 ++++++++++++++++++++++++++++----- 1 file changed, 38 insertions(+), 7 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 8acf186c1..c867a50dd 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -21,6 +21,7 @@ end subroutine GFS_surface_generic_pre_finalize !! |----------------|------------------------------------------------------------------------------|------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| !! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | !! | levs | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | +!! | first_time_step | flag_for_first_time_step | flag for first time step for time integration loop (cold/warmstart) | flag | 0 | logical | | in | F | !! | vfrac | vegetation_area_fraction | areal fractional cover of green vegetation | frac | 1 | real | kind_phys | in | F | !! | islmsk | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | !! | isot | soil_type_dataset_choice | soil type dataset choice | index | 0 | integer | | in | F | @@ -80,22 +81,26 @@ end subroutine GFS_surface_generic_pre_finalize !! | tsfco | sea_surface_temperature | sea surface temperature | K | 1 | real | kind_phys | in | F | !! | fice | sea_ice_concentration | sea-ice concentration [0,1] | frac | 1 | real | kind_phys | in | F | !! | hice | sea_ice_thickness | sea-ice thickness | m | 1 | real | kind_phys | in | F | +!! | weasd | water_equivalent_accumulated_snow_depth | water equiv of acc snow depth over land and sea ice | mm | 1 | real | kind_phys | in | F | +!! | sncovr | surface_snow_area_fraction_over_land | surface snow area fraction | frac | 1 | real | kind_phys | inout | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & + subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk, isot, ivegsrc, & + stype, vtype, slope, & prsik_1, prslk_1, semis, adjsfcdlw, tsfc, phil, con_g, sigmaf, soiltyp, vegtype, & slopetyp, work3, gabsbdlw, tsurf, zlvl, do_sppt, dtdtr, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, do_sfcperts, nsfcpert, sfc_wts, & pertz0, pertzt, pertshc, pertlai, pertvegf, z01d, zt1d, bexp1d, xlai1d, vegf1d, & cplflx, flag_cice, islmsk_cice,slimskin_cpl, dusfcin_cpl, dvsfcin_cpl, & dtsfcin_cpl, dqsfcin_cpl, ulwsfcin_cpl, ulwsfc_cice, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, & + dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, weasd, sncovr, & errmsg, errflg) use machine, only: kind_phys use surface_perturbation, only: cdfnor + use namelist_soilveg, only: salp_data, snupx implicit none @@ -106,8 +111,8 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), intent(in) :: con_g real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1, & - semis, adjsfcdlw - real(kind=kind_phys), dimension(im), intent(inout) :: tsfc + semis, adjsfcdlw, weasd + real(kind=kind_phys), dimension(im), intent(inout) :: tsfc, sncovr real(kind=kind_phys), dimension(im,levs), intent(in) :: phil real(kind=kind_phys), dimension(im), intent(inout) :: sigmaf, work3, gabsbdlw, tsurf, zlvl @@ -133,7 +138,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(im), intent(out) :: xlai1d real(kind=kind_phys), dimension(im), intent(out) :: vegf1d - logical, intent(in) :: cplflx + logical, intent(in) :: cplflx, first_time_step real(kind=kind_phys), dimension(im), intent(in) :: slimskin_cpl logical, dimension(im), intent(inout) :: flag_cice integer, dimension(im), intent(out) :: islmsk_cice @@ -151,14 +156,40 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, integer :: i real(kind=kind_phys) :: onebg real(kind=kind_phys) :: cdfz - + + !--- local variables for sncovr calculation + integer :: vegtyp + logical :: mand + real(kind=kind_phys) :: rsnow, tem + ! Set constants onebg = 1.0/con_g ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + + !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) + if (first_time_step) then + if (nint(sncovr(1)) == -9999) then + do i = 1, im + sncovr(i) = 0.0 + if (islmsk(i) > 0) then + ! GJF* this is different than the integer conversion below, but copied from FV3GFS_io.f90. + ! Can this block be moved to after vegetation_type_classification (integer) has been set? *GJF + vegtyp = vtype(i) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*weasd(i)/snupx(vegtyp) + if (0.001*weasd(i) < snupx(vegtyp)) then + sncovr(i) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + sncovr(i) = 1.0 + endif + endif + enddo + endif + endif + ! Set initial quantities for stochastic physics deltas if (do_sppt) then dtdtr = 0.0 From 78523cf154a75d74cf587d8f906a2bbab11457a7 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 3 Sep 2019 11:09:51 -0600 Subject: [PATCH 14/59] add calculation of sncovr to GFS_phys_time_vary_run (not to init because it was originally done after the call to ccpp_physics_init in FV3GFS_io.F90/sfc_prop_restart_read); this needs to happen before radition is called --- physics/GFS_phys_time_vary.fv3.F90 | 38 +++++++++++++++++++++---- physics/GFS_surface_generic.F90 | 45 +++++------------------------- 2 files changed, 40 insertions(+), 43 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index f66a43675..8f20300b6 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -22,6 +22,9 @@ module GFS_phys_time_vary use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol + + !--- variables needed for calculating 'sncovr' + use namelist_soilveg, only: salp_data, snupx implicit none @@ -329,23 +332,25 @@ end subroutine GFS_phys_time_vary_finalize !! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | !! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | !! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | +!! | first_time_step | flag_for_first_time_step | flag for first time step for time integration loop (cold/warmstart) | flag | 0 | logical | | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! !>\section gen_GFS_phys_time_vary_run GFS_phys_time_vary_run General Algorithm !> @{ - subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) + subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, errflg) use mersenne_twister, only: random_setseed, random_number use machine, only: kind_phys use GFS_typedefs, only: GFS_control_type, GFS_data_type - + implicit none ! Interface variables - type(GFS_data_type), intent(in) :: Data(:) + type(GFS_data_type), intent(inout) :: Data(:) type(GFS_control_type), intent(inout) :: Model integer, intent(in) :: nthrds + logical, intent(in) :: first_time_step character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -354,8 +359,8 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys - integer :: i, j, k, iseed, iskip, ix, nb, nblks, kdt_rad - real(kind=kind_phys) :: sec_zero + integer :: i, j, k, iseed, iskip, ix, nb, nblks, kdt_rad, vegtyp + real(kind=kind_phys) :: sec_zero, rsnow real(kind=kind_phys) :: wrk(1) real(kind=kind_phys) :: rannie(Model%cny) real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) @@ -508,6 +513,29 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) enddo endif endif + + !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) + if (first_time_step) then + if (nint(Data(1)%Sfcprop%sncovr(1)) == -9999) then + !--- compute sncovr from existing variables + !--- code taken directly from read_fix.f + do nb = 1, nblks + do ix = 1, Model%blksz(nb) + Data(nb)%Sfcprop%sncovr(ix) = 0.0 + if (Data(nb)%Sfcprop%slmsk(ix) > 0.001) then + vegtyp = Data(nb)%Sfcprop%vtype(ix) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*Data(nb)%Sfcprop%weasd(ix)/snupx(vegtyp) + if (0.001*Data(nb)%Sfcprop%weasd(ix) < snupx(vegtyp)) then + Data(nb)%Sfcprop%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + Data(nb)%Sfcprop%sncovr(ix) = 1.0 + endif + endif + enddo + enddo + endif + endif end subroutine GFS_phys_time_vary_run !> @} diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index c867a50dd..8acf186c1 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -21,7 +21,6 @@ end subroutine GFS_surface_generic_pre_finalize !! |----------------|------------------------------------------------------------------------------|------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| !! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | !! | levs | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | -!! | first_time_step | flag_for_first_time_step | flag for first time step for time integration loop (cold/warmstart) | flag | 0 | logical | | in | F | !! | vfrac | vegetation_area_fraction | areal fractional cover of green vegetation | frac | 1 | real | kind_phys | in | F | !! | islmsk | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | !! | isot | soil_type_dataset_choice | soil type dataset choice | index | 0 | integer | | in | F | @@ -81,26 +80,22 @@ end subroutine GFS_surface_generic_pre_finalize !! | tsfco | sea_surface_temperature | sea surface temperature | K | 1 | real | kind_phys | in | F | !! | fice | sea_ice_concentration | sea-ice concentration [0,1] | frac | 1 | real | kind_phys | in | F | !! | hice | sea_ice_thickness | sea-ice thickness | m | 1 | real | kind_phys | in | F | -!! | weasd | water_equivalent_accumulated_snow_depth | water equiv of acc snow depth over land and sea ice | mm | 1 | real | kind_phys | in | F | -!! | sncovr | surface_snow_area_fraction_over_land | surface snow area fraction | frac | 1 | real | kind_phys | inout | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk, isot, ivegsrc, & - stype, vtype, slope, & + subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & prsik_1, prslk_1, semis, adjsfcdlw, tsfc, phil, con_g, sigmaf, soiltyp, vegtype, & slopetyp, work3, gabsbdlw, tsurf, zlvl, do_sppt, dtdtr, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, do_sfcperts, nsfcpert, sfc_wts, & pertz0, pertzt, pertshc, pertlai, pertvegf, z01d, zt1d, bexp1d, xlai1d, vegf1d, & cplflx, flag_cice, islmsk_cice,slimskin_cpl, dusfcin_cpl, dvsfcin_cpl, & dtsfcin_cpl, dqsfcin_cpl, ulwsfcin_cpl, ulwsfc_cice, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, weasd, sncovr, & + dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, & errmsg, errflg) use machine, only: kind_phys use surface_perturbation, only: cdfnor - use namelist_soilveg, only: salp_data, snupx implicit none @@ -111,8 +106,8 @@ subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk real(kind=kind_phys), intent(in) :: con_g real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1, & - semis, adjsfcdlw, weasd - real(kind=kind_phys), dimension(im), intent(inout) :: tsfc, sncovr + semis, adjsfcdlw + real(kind=kind_phys), dimension(im), intent(inout) :: tsfc real(kind=kind_phys), dimension(im,levs), intent(in) :: phil real(kind=kind_phys), dimension(im), intent(inout) :: sigmaf, work3, gabsbdlw, tsurf, zlvl @@ -138,7 +133,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk real(kind=kind_phys), dimension(im), intent(out) :: xlai1d real(kind=kind_phys), dimension(im), intent(out) :: vegf1d - logical, intent(in) :: cplflx, first_time_step + logical, intent(in) :: cplflx real(kind=kind_phys), dimension(im), intent(in) :: slimskin_cpl logical, dimension(im), intent(inout) :: flag_cice integer, dimension(im), intent(out) :: islmsk_cice @@ -156,40 +151,14 @@ subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk integer :: i real(kind=kind_phys) :: onebg real(kind=kind_phys) :: cdfz - - !--- local variables for sncovr calculation - integer :: vegtyp - logical :: mand - real(kind=kind_phys) :: rsnow, tem - + ! Set constants onebg = 1.0/con_g ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - - !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) - if (first_time_step) then - if (nint(sncovr(1)) == -9999) then - do i = 1, im - sncovr(i) = 0.0 - if (islmsk(i) > 0) then - ! GJF* this is different than the integer conversion below, but copied from FV3GFS_io.f90. - ! Can this block be moved to after vegetation_type_classification (integer) has been set? *GJF - vegtyp = vtype(i) - if (vegtyp == 0) vegtyp = 7 - rsnow = 0.001*weasd(i)/snupx(vegtyp) - if (0.001*weasd(i) < snupx(vegtyp)) then - sncovr(i) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) - else - sncovr(i) = 1.0 - endif - endif - enddo - endif - endif - + ! Set initial quantities for stochastic physics deltas if (do_sppt) then dtdtr = 0.0 From af34508ebf09785fdd1584d297f1a93759a8c132 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 3 Sep 2019 16:13:37 -0600 Subject: [PATCH 15/59] fix GFS_time_vary_pre.fv3.F90 compilation error --- physics/GFS_time_vary_pre.fv3.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 450a5af4d..8f146de92 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -164,11 +164,11 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & lssav = .true. !--- radiation triggers - Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) - Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + lsswr = (mod(kdt, nsswr) == 1) + lslwr = (mod(kdt, nslwr) == 1) !--- allow for radiation to be called on every physics time step, if needed - if (Model%nsswr == 1) Model%lsswr = .true. - if (Model%nslwr == 1) Model%lslwr = .true. + if (nsswr == 1) lsswr = .true. + if (nslwr == 1) lslwr = .true. !--- set the solar hour based on a combination of phour and time initial hour solhr = mod(phour+idate(1),con_24) From 619afe09f93d77a2462281968339adaad7b455fc Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 4 Sep 2019 13:04:08 -0600 Subject: [PATCH 16/59] add calculation of precipitation variables for NoahMP in GFS_MP_generic_post_run --- physics/GFS_MP_generic.F90 | 33 ++++++++++++++++++++++++++++++--- 1 file changed, 30 insertions(+), 3 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 8d3074988..70efd23bf 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -165,11 +165,17 @@ end subroutine GFS_MP_generic_post_init !! | dsnow_cpl | tendency_of_lwe_thickness_of_snow_amount_for_coupling | change in show_cpl (coupling_type) | m | 1 | real | kind_phys | inout | F | !! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | !! | lsm_ruc | flag_for_ruc_land_surface_scheme | flag for RUC land surface model | flag | 0 | integer | | in | F | +!! | lsm_noahmp | flag_for_noahmp_land_surface_scheme | flag for NOAH MP land surface model | flag | 0 | integer | | in | F | !! | raincprv | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | rainncprv | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | inout | F | !! | iceprv | lwe_thickness_of_ice_amount_from_previous_timestep | ice amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | snowprv | lwe_thickness_of_snow_amount_from_previous_timestep | snow amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | graupelprv | lwe_thickness_of_graupel_amount_from_previous_timestep | graupel amount from previous timestep | m | 1 | real | kind_phys | inout | F | +!! | rainc_mp | convective_precipitation_rate_from_previous_timestep | convective precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | rainn_mp | explicit_rainfall_rate_from_previous_timestep | explicit rainfall rate previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | ice_mp | ice_precipitation_rate_from_previous_timestep | ice precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | snow_mp | snow_precipitation_rate_from_previous_timestep | snow precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | graupel_mp | graupel_precipitation_rate_from_previous_timestep | graupel precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | !! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | @@ -181,8 +187,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_qv, 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, dt3dt, dq3dt, rain_cpl, rainc_cpl, snow_cpl, pwat, & - do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, & - dtp, errmsg, errflg) + do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & + graupelprv, dtp, rainc_mp, rainn_mp, ice_mp, snow_mp, graupel_mp, errmsg, errflg) ! use machine, only: kind_phys @@ -225,7 +231,15 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt real(kind=kind_phys), dimension(im), intent(inout) :: graupelprv real(kind=kind_phys), intent(in) :: dtp - + + ! Rainfall variables previous time step (update for NoahMP LSM) + integer, intent(in) :: lsm_noahmp + real(kind=kind_phys), dimension(im), intent(inout) :: rainc_mp + real(kind=kind_phys), dimension(im), intent(inout) :: rainn_mp + real(kind=kind_phys), dimension(im), intent(inout) :: ice_mp + real(kind=kind_phys), dimension(im), intent(inout) :: snow_mp + real(kind=kind_phys), dimension(im), intent(inout) :: graupel_mp + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -286,6 +300,19 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt graupelprv(:) = graupel(:) end if end if + + !--- get the amount of different precip type for Noah MP + ! --- convert from m/dtp to mm/s + if (lsm == lsm_noahmp .and. (imp_physics == imp_physics_mg .or. imp_physics == imp_physics_gfdl)) then + tem = 1.0 / (dtp*con_p001) + do i=1,im + rainn_mp(i) = tem * (rain(i)-rainc(i)) + rainc_mp(i) = tem * rainc(i) + snow_mp(i) = tem * snow(i) + graupel_mp(i) = tem * graupel(i) + ice_mp(i) = tem * ice(i) + enddo + endif if (cal_pre) then ! hchuang: add dominant precipitation type algorithm ! From de728a80e66f03b203865fc756823c0068215abb Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 4 Sep 2019 22:14:12 -0600 Subject: [PATCH 17/59] add resetting of sfcprop%t2m and q2m to values from noahmp if noahmp is active --- physics/GFS_MP_generic.F90 | 10 +++++----- physics/sfc_diag_post.F90 | 32 ++++++++++++++++++++++++-------- physics/sfc_noahmp_drv.f | 22 +++++++++------------- physics/sfc_noahmp_drv.meta | 36 ++++++++++++++++++------------------ 4 files changed, 56 insertions(+), 44 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 70efd23bf..5fa9614d7 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -234,11 +234,11 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt ! Rainfall variables previous time step (update for NoahMP LSM) integer, intent(in) :: lsm_noahmp - real(kind=kind_phys), dimension(im), intent(inout) :: rainc_mp - real(kind=kind_phys), dimension(im), intent(inout) :: rainn_mp - real(kind=kind_phys), dimension(im), intent(inout) :: ice_mp - real(kind=kind_phys), dimension(im), intent(inout) :: snow_mp - real(kind=kind_phys), dimension(im), intent(inout) :: graupel_mp + real(kind=kind_phys), dimension(:), intent(inout) :: rainc_mp + real(kind=kind_phys), dimension(:), intent(inout) :: rainn_mp + real(kind=kind_phys), dimension(:), intent(inout) :: ice_mp + real(kind=kind_phys), dimension(:), intent(inout) :: snow_mp + real(kind=kind_phys), dimension(:), intent(inout) :: graupel_mp ! CCPP error handling character(len=*), intent(out) :: errmsg diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 80c90eadb..054e1ab24 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -15,13 +15,18 @@ end subroutine sfc_diag_post_finalize !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |----------------|---------------------------------------------------------------------------------------------------------------------|-------------------------------------------------------------------------------------|-------------|------|------------|-----------|--------|----------| !! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | +!! | lsm_noahmp | flag_for_noahmp_land_surface_scheme | flag for NOAH MP land surface model | flag | 0 | integer | | in | F | +!! | dry | flag_nonzero_land_surface_fraction | flag indicating presence of some land surface area fraction | flag | 1 | logical | | in | F | !! | lssav | flag_diagnostics | logical flag for storing diagnostics | flag | 0 | logical | | in | F | !! | dtf | time_step_for_dynamics | dynamics timestep | s | 0 | real | kind_phys | in | F | !! | con_eps | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | !! | con_epsm1 | ratio_of_dry_air_to_water_vapor_gas_constants_minus_one | (rd/rv) - 1 | none | 0 | real | kind_phys | in | F | !! | pgr | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | -!! | t2m | temperature_at_2m | 2 meter temperature | K | 1 | real | kind_phys | in | F | -!! | q2m | specific_humidity_at_2m | 2 meter specific humidity | kg kg-1 | 1 | real | kind_phys | in | F | +!! | t2mmp | temperature_at_2m_from_noahmp | 2 meter temperature from NoahMP | K | 1 | real | kind_phys | in | F | +!! | q2mp | specific_humidity_at_2m_from_noahmp | 2 meter specific humidity from noahmp | kg kg-1 | 1 | real | kind_phys | in | F | +!! | t2m | temperature_at_2m | 2 meter temperature | K | 1 | real | kind_phys | inout | F | +!! | q2m | specific_humidity_at_2m | 2 meter specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | !! | u10m | x_wind_at_10m | 10 meter u wind speed | m s-1 | 1 | real | kind_phys | in | F | !! | v10m | y_wind_at_10m | 10 meter v wind speed | m s-1 | 1 | real | kind_phys | in | F | !! | tmpmin | minimum_temperature_at_2m | min temperature at 2m height | K | 1 | real | kind_phys | inout | F | @@ -36,19 +41,21 @@ end subroutine sfc_diag_post_finalize !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine sfc_diag_post_run (im, lssav, dtf, con_eps, con_epsm1, pgr, & - t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax,& + subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con_epsm1, pgr,& + t2mmp, q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax,& wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) use machine, only: kind_phys implicit none - integer, intent(in) :: im + integer, intent(in) :: im, lsm, lsm_noahmp logical, intent(in) :: lssav real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1 - real(kind=kind_phys), dimension(im), intent(in) :: pgr, t2m, q2m, u10m, v10m - real(kind=kind_phys), dimension(im), intent(inout) :: tmpmin, tmpmax, spfhmin, spfhmax + logical , dimension(im), intent(in) :: dry + real(kind=kind_phys), dimension(im), intent(in) :: pgr, u10m, v10m + real(kind=kind_phys), dimension(:) , intent(in) :: t2mmp, q2mp + real(kind=kind_phys), dimension(im), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax real(kind=kind_phys), dimension(im), intent(inout) :: wind10mmax, u10mmax, v10mmax, dpt2m character(len=*), intent(out) :: errmsg @@ -60,7 +67,16 @@ subroutine sfc_diag_post_run (im, lssav, dtf, con_eps, con_epsm1, pgr, & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + + if (lsm == lsm_noahmp) then + do i=1,im + if(dry(i)) then + t2m(i) = t2mmp(i) + q2m(i) = q2mp(i) + endif + enddo + endif + if (lssav) then do i=1,im tmpmax(i) = max(tmpmax(i),t2m(i)) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 7d8b60d5f..a089e84d0 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -58,7 +58,7 @@ subroutine noahmpdrv_run & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - & canopy, trans, tsurf, zorl, t2mmp, q2mp, & + & canopy, trans, tsurf, zorl, & ! --- Noah MP specific @@ -71,7 +71,7 @@ subroutine noahmpdrv_run & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2, wet1, errmsg, errflg) + & smcwlt2, smcref2, wet1, t2mmp, q2mp, errmsg, errflg) ! ! use machine , only : kind_phys @@ -143,8 +143,7 @@ subroutine noahmpdrv_run & ! --- in/out: real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & - & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl, & - & t2mmp, q2mp + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl real (kind=kind_phys), dimension(im,km), intent(inout) :: & & smc, stc, slc @@ -170,7 +169,8 @@ subroutine noahmpdrv_run & real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & - & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1 + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2, wet1 + real (kind=kind_phys), dimension(:), intent(out) :: t2mmp, q2mp ! error messages character(len=*), intent(out) :: errmsg @@ -698,10 +698,8 @@ subroutine noahmpdrv_run & z0wrf = 0.002 eta = fgev - if (dry(i)) then - t2mmp(i) = t2mb - q2mp(i) = q2b - endif + t2mmp(i) = t2mb + q2mp(i) = q2b ! ! Non-glacial case ! @@ -749,10 +747,8 @@ subroutine noahmpdrv_run & eta = fcev + fgev + fctr ! the flux w/m2 - if (dry(i)) then - t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) - q2mp(i) = q2v*fveg+q2b*(1-fveg) - endif + t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) + q2mp(i) = q2v*fveg+q2b*(1-fveg) endif ! glacial split ends diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 2a604fc15..9baa85082 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -690,24 +690,6 @@ kind = kind_phys intent = inout optional = F -[t2mmp] - standard_name = temperature_at_2m - long_name = 2 meter temperature - units = K - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[q2mp] - standard_name = specific_humidity_at_2m - long_name = 2 meter specific humidity - units = kg kg-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers @@ -1185,6 +1167,24 @@ kind = kind_phys intent = out optional = F +[t2mmp] + standard_name = temperature_at_2m_from_noahmp + long_name = 2 meter temperature from noahmp + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[q2mp] + standard_name = specific_humidity_at_2m_from_noahmp + long_name = 2 meter specific humidity from noahmp + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 775f4ffe9d11c5cd1d7718423d1fe4983967fb41 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 6 Sep 2019 15:16:32 -0600 Subject: [PATCH 18/59] (temporarily?) move calculation of precip rates for NoahMP to scheme-specific interstitial to test for b4b --- physics/GFS_MP_generic.F90 | 31 +------ physics/sfc_noahmp_pre.F90 | 65 ++++++++++++++ physics/sfc_noahmp_pre.meta | 167 ++++++++++++++++++++++++++++++++++++ 3 files changed, 234 insertions(+), 29 deletions(-) create mode 100755 physics/sfc_noahmp_pre.F90 create mode 100644 physics/sfc_noahmp_pre.meta diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 5fa9614d7..3e6a8379c 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -165,17 +165,11 @@ end subroutine GFS_MP_generic_post_init !! | dsnow_cpl | tendency_of_lwe_thickness_of_snow_amount_for_coupling | change in show_cpl (coupling_type) | m | 1 | real | kind_phys | inout | F | !! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | !! | lsm_ruc | flag_for_ruc_land_surface_scheme | flag for RUC land surface model | flag | 0 | integer | | in | F | -!! | lsm_noahmp | flag_for_noahmp_land_surface_scheme | flag for NOAH MP land surface model | flag | 0 | integer | | in | F | !! | raincprv | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | rainncprv | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | inout | F | !! | iceprv | lwe_thickness_of_ice_amount_from_previous_timestep | ice amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | snowprv | lwe_thickness_of_snow_amount_from_previous_timestep | snow amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | graupelprv | lwe_thickness_of_graupel_amount_from_previous_timestep | graupel amount from previous timestep | m | 1 | real | kind_phys | inout | F | -!! | rainc_mp | convective_precipitation_rate_from_previous_timestep | convective precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | rainn_mp | explicit_rainfall_rate_from_previous_timestep | explicit rainfall rate previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | ice_mp | ice_precipitation_rate_from_previous_timestep | ice precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | snow_mp | snow_precipitation_rate_from_previous_timestep | snow precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | graupel_mp | graupel_precipitation_rate_from_previous_timestep | graupel precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | !! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | @@ -187,8 +181,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_qv, 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, dt3dt, dq3dt, rain_cpl, rainc_cpl, snow_cpl, pwat, & - do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & - graupelprv, dtp, rainc_mp, rainn_mp, ice_mp, snow_mp, graupel_mp, errmsg, errflg) + do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, dtp, & + errmsg, errflg) ! use machine, only: kind_phys @@ -232,14 +226,6 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt real(kind=kind_phys), intent(in) :: dtp - ! Rainfall variables previous time step (update for NoahMP LSM) - integer, intent(in) :: lsm_noahmp - real(kind=kind_phys), dimension(:), intent(inout) :: rainc_mp - real(kind=kind_phys), dimension(:), intent(inout) :: rainn_mp - real(kind=kind_phys), dimension(:), intent(inout) :: ice_mp - real(kind=kind_phys), dimension(:), intent(inout) :: snow_mp - real(kind=kind_phys), dimension(:), intent(inout) :: graupel_mp - ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -300,19 +286,6 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt graupelprv(:) = graupel(:) end if end if - - !--- get the amount of different precip type for Noah MP - ! --- convert from m/dtp to mm/s - if (lsm == lsm_noahmp .and. (imp_physics == imp_physics_mg .or. imp_physics == imp_physics_gfdl)) then - tem = 1.0 / (dtp*con_p001) - do i=1,im - rainn_mp(i) = tem * (rain(i)-rainc(i)) - rainc_mp(i) = tem * rainc(i) - snow_mp(i) = tem * snow(i) - graupel_mp(i) = tem * graupel(i) - ice_mp(i) = tem * ice(i) - enddo - endif if (cal_pre) then ! hchuang: add dominant precipitation type algorithm ! diff --git a/physics/sfc_noahmp_pre.F90 b/physics/sfc_noahmp_pre.F90 new file mode 100755 index 000000000..fff3562d6 --- /dev/null +++ b/physics/sfc_noahmp_pre.F90 @@ -0,0 +1,65 @@ +!> \file sfc_noahmp_pre.F90 +!! This file contains data preparation for the NoahMP LSM for use in the GFS physics suite. + +!> This module contains the CCPP-compliant data preparation for NoahMP LSM. + module sfc_noahmp_pre + + implicit none + + private + + public :: sfc_noahmp_pre_init, sfc_noahmp_pre_run, sfc_noahmp_pre_finalize + + contains + + subroutine sfc_noahmp_pre_init() + end subroutine sfc_noahmp_pre_init + + subroutine sfc_noahmp_pre_finalize + end subroutine sfc_noahmp_pre_finalize + +!> \section arg_table_sfc_noahmp_pre_run Argument Table +!! \htmlinclude sfc_noahmp_pre_run.html +!! +!----------------------------------- + subroutine sfc_noahmp_pre_run (im, lsm, lsm_noahmp, imp_physics, & + imp_physics_gfdl, imp_physics_mg, dtp, rain, rainc, ice, snow, & + graupel, rainn_mp, rainc_mp, ice_mp, snow_mp, graupel_mp, & + errmsg, errflg) + + use machine , only : kind_phys + + implicit none + + integer, intent(in) :: im, lsm, lsm_noahmp, & + imp_physics, imp_physics_gfdl, imp_physics_mg + real (kind=kind_phys), intent(in) :: dtp + real (kind=kind_phys), dimension(im), intent(in) :: rain, rainc,& + ice, snow, graupel + real (kind=kind_phys), dimension(:), intent(inout) :: rainn_mp, & + rainc_mp, ice_mp, snow_mp, graupel_mp + + ! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! --- locals: + integer :: i + real(kind=kind_phys) :: tem + real(kind=kind_phys), parameter :: con_p001= 0.001d0 + + !--- get the amount of different precip type for Noah MP + ! --- convert from m/dtp to mm/s + if (lsm == lsm_noahmp .and. (imp_physics == imp_physics_mg .or. imp_physics == imp_physics_gfdl)) then + tem = 1.0 / (dtp*con_p001) + do i=1,im + rainn_mp(i) = tem * (rain(i)-rainc(i)) + rainc_mp(i) = tem * rainc(i) + snow_mp(i) = tem * snow(i) + graupel_mp(i) = tem * graupel(i) + ice_mp(i) = tem * ice(i) + enddo + endif + + end subroutine sfc_noahmp_pre_run + end module sfc_noahmp_pre diff --git a/physics/sfc_noahmp_pre.meta b/physics/sfc_noahmp_pre.meta new file mode 100644 index 000000000..4cf834728 --- /dev/null +++ b/physics/sfc_noahmp_pre.meta @@ -0,0 +1,167 @@ +[ccpp-arg-table] + name = sfc_noahmp_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noahmp] + standard_name = flag_for_noahmp_land_surface_scheme + long_name = flag for NOAH MP land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_gfdl] + standard_name = flag_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_mg] + standard_name = flag_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rainc] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ice] + standard_name = lwe_thickness_of_ice_amount_on_dynamics_timestep + long_name = ice fall at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snow] + standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep + long_name = snow fall at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[graupel] + standard_name = lwe_thickness_of_graupel_amount_on_dynamics_timestep + long_name = graupel fall at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rainn_mp] + standard_name = explicit_rainfall_rate_from_previous_timestep + long_name = explicit rainfall rate previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rainc_mp] + standard_name = convective_precipitation_rate_from_previous_timestep + long_name = convective precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ice_mp] + standard_name = ice_precipitation_rate_from_previous_timestep + long_name = ice precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snow_mp] + standard_name = snow_precipitation_rate_from_previous_timestep + long_name = snow precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[graupel_mp] + standard_name = graupel_precipitation_rate_from_previous_timestep + long_name = graupel precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From e7bb31a6360b23d8b5c0845409648f9342e2dfa7 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 10 Sep 2019 17:23:59 -0600 Subject: [PATCH 19/59] revert whitespace changes to GFS_MP_generic.F90 --- physics/GFS_MP_generic.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 85f9333e6..b83f592f2 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -85,8 +85,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_qv, 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, dt3dt, dq3dt, rain_cpl, rainc_cpl, snow_cpl, pwat, & - do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, dtp, & - errmsg, errflg) + do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, & + dtp, errmsg, errflg) ! use machine, only: kind_phys @@ -129,7 +129,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt real(kind=kind_phys), dimension(im), intent(inout) :: graupelprv real(kind=kind_phys), intent(in) :: dtp - + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg From 69c215f7f628bb1868d303db9187744d3c2f3aea Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 12 Sep 2019 11:59:38 -0600 Subject: [PATCH 20/59] fix bug in metadata table for GFS_phys_time_vary_run for FV3 --- physics/GFS_phys_time_vary.fv3.meta | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index cccc1eaa1..ac2ccbf3c 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -33,14 +33,6 @@ type = integer intent = in optional = F -[first_time_step] - standard_name = flag_for_first_time_step - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -109,6 +101,14 @@ type = integer intent = in optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 822c6479bd92563fffc11326db8a96b6b4b6e060 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 13 Sep 2019 14:09:34 -0600 Subject: [PATCH 21/59] Revert changes to physics/module_BL_MYJPBL.F90 physics/module_SF_JSFC.F90 that replaced legacy code (GOTO statements) with more complicated code --- physics/module_BL_MYJPBL.F90 | 112 ++++++++++------------------------- physics/module_SF_JSFC.F90 | 6 +- 2 files changed, 34 insertions(+), 84 deletions(-) diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 index f0ddbd86b..6f455221b 100755 --- a/physics/module_BL_MYJPBL.F90 +++ b/physics/module_BL_MYJPBL.F90 @@ -915,7 +915,7 @@ SUBROUTINE MIXLEN & !--------1---------2---------3---------4---------5---------6---------7-- CUBRY=UBRY*1.5 !*2. !--------------FIND THE HEIGHT OF THE PBL------------------------------- - LPBL=LMH/3 + LPBL=LMH ! LPBL=LMH-1 DO K=LMH-1,1,-1 ! EPSL(K)=1. @@ -928,11 +928,11 @@ SUBROUTINE MIXLEN & DO K=LMH-1,1,-1 if(q2(k)-epsq2(k)+epsq2(lm).le.epsq2(lm)*fh) then LPBL=K -!QL GO TO 110 + GO TO 110 ENDIF ENDDO ! -!QL LPBL=1 + LPBL=1 ! !--------------THE HEIGHT OF THE PBL------------------------------------ ! @@ -2117,12 +2117,10 @@ SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) Q(1)=-RTDXC*DXR ! -!QL IF(NOLD.EQ.3) GO TO 700 - IF(NOLD.NE.3) THEN + IF(NOLD.EQ.3) GO TO 700 !----------------------------------------------------------------------- -! K=3 + K=3 ! - DO K=3,NOLD-1 100 DXL=DXR DYDXL=DYDXR DXR=XOLD(K+1)-XOLD(K) @@ -2133,97 +2131,49 @@ SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) Q(K-1)=-DEN*DXR ! -! K=K+1 -!QL IF(K.LT.NOLD) GO TO 100 - END DO - END IF + K=K+1 + IF(K.LT.NOLD) GO TO 100 !----------------------------------------------------------------------- -!QL 700 K=NOLDM1 -! K=NOLDM1 -! - DO K=NOLDM1, 2, -1 + 700 K=NOLDM1 +! 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) ! -! K=K-1 -!QL IF(K.GT.1) GO TO 200 - END DO + K=K-1 + IF(K.GT.1) GO TO 200 !----------------------------------------------------------------------- -! K1=1 + K1=1 ! - DO K1=1,NNEW 300 XK=XNEW(K1) ! - YNEW(K1)=YOLD(NOLD) DO 400 K2=2,NOLD - IF(XOLD(K2).LE.XK) CYCLE + IF(XOLD(K2).LE.XK) GO TO 400 KOLD=K2-1 -!QL GO TO 450 - IF(K1.EQ.1)THEN ! 450 - K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=.1666667*RDX*(Y2KP1-Y2K) - BK=.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) - X=XK-XOLD(K) - XSQ=X*X - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - EXIT - END IF - - IF(K.EQ.KOLD)THEN ! 550 - X=XK-XOLD(K) - XSQ=X*X - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) - EXIT - END IF - - K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=.1666667*RDX*(Y2KP1-Y2K) - BK=.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) - X=XK-XOLD(K) - XSQ=X*X - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - EXIT - + GO TO 450 400 CONTINUE -! GO TO 600 + YNEW(K1)=YOLD(NOLD) + GO TO 600 ! -! 450 IF(K1.EQ.1) GO TO 500 -! IF(K.EQ.KOLD) GO TO 550 + 450 IF(K1.EQ.1) GO TO 500 + IF(K.EQ.KOLD) GO TO 550 ! -! 500 K=KOLD + 500 K=KOLD ! -! Y2K=Y2(K) -! Y2KP1=Y2(K+1) -! DX=XOLD(K+1)-XOLD(K) -! RDX=1./DX + Y2K=Y2(K) + Y2KP1=Y2(K+1) + DX=XOLD(K+1)-XOLD(K) + RDX=1./DX ! -! AK=.1666667*RDX*(Y2KP1-Y2K) -! BK=.5*Y2K -! CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) + AK=.1666667*RDX*(Y2KP1-Y2K) + BK=.5*Y2K + CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) ! -! 550 X=XK-XOLD(K) -! XSQ=X*X + 550 X=XK-XOLD(K) + XSQ=X*X ! -! YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) + YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) ! -! 600 K1=K1+1 -! IF(K1.LE.NNEW) GO TO 300 - END DO + 600 K1=K1+1 + IF(K1.LE.NNEW) GO TO 300 !----------------------------------------------------------------------- ENDSUBROUTINE SPLINE !----------------------------------------------------------------------- diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 41c546d42..0c79f8de1 100755 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -327,15 +327,15 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & ! !*** FIND THE HEIGHT OF THE PBL ! - LPBL=LMH/3 + LPBL=LMH DO K=LMH-1,1,-1 IF(Q2K(K)<=EPSQ2(K)*FH) THEN LPBL=K -! GO TO 110 + GO TO 110 ENDIF ENDDO ! -! LPBL=1 + LPBL=1 ! !----------------------------------------------------------------------- !--------------THE HEIGHT OF THE PBL------------------------------------ From 248af59781eea8027d137564bc513ff59332598c Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 13 Sep 2019 15:07:02 -0600 Subject: [PATCH 22/59] Convert physics/module_MYJPBL_wrapper.F90 and physics/module_MYJSFC_wrapper.F90 to new metadata format --- physics/module_MYJPBL_wrapper.F90 | 77 +-- physics/module_MYJPBL_wrapper.meta | 651 +++++++++++++++++++++++ physics/module_MYJSFC_wrapper.F90 | 95 +--- physics/module_MYJSFC_wrapper.meta | 814 +++++++++++++++++++++++++++++ 4 files changed, 1467 insertions(+), 170 deletions(-) create mode 100644 physics/module_MYJPBL_wrapper.meta create mode 100644 physics/module_MYJSFC_wrapper.meta diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/module_MYJPBL_wrapper.F90 index ce1c95830..8114afea4 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/module_MYJPBL_wrapper.F90 @@ -15,82 +15,7 @@ end subroutine myjpbl_wrapper_finalize !> \brief This scheme (1) performs pre-myjpbl work, (2) runs the myjpbl, and (3) performs post-myjpbl work #if 0 !! \section arg_table_myjpbl_wrapper_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |---------------------|-----------------------------------------------------------------|-------------------------------------------------- ----|---------------|------|------------------|-----------|--------|----------| -!! | restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | -!! | do_myjsfc | do_myjsfc | flag for MYJ surface layer scheme | flag | 0 | logical | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | dt_phs | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | -!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | -!! | ntke | index_for_turbulent_kinetic_energy | tracer index for turbulent kinetic energy | index | 0 | integer | | in | F | -!! | ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | -!! | ntrw | index_for_rain_water | tracer index for rain water | index | 0 | integer | | in | F | -!! | ntsw | index_for_snow_water | tracer index for snow water | index | 0 | integer | | in | F | -!! | ntgl | index_for_graupel | tracer index for graupel | index | 0 | integer | | in | F | -!! | ugrs | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | vgrs | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | tgrs | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | qgrs | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | hprime1 | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | in | F | -!! | prsik_1 | dimensionless_exner_function_at_lowest_model_interface | dimensionless Exner function at lowest model interface| none | 1 | real | kind_phys | in | F | -!! | prslk_1 | dimensionless_exner_function_at_lowest_model_layer | dimensionless Exner function at lowest model layer | none | 1 | real | kind_phys | in | F | -!! | prslki | ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer | Exner function ratio bt midlayer and interface at 1st layer | ratio | 1 | real | kind_phys | in | F | -!! | tsfc | surface_skin_temperature | surface temperature | K | 1 | real | kind_phys | inout | F | -!! | qsfc | surface_specific_humidity | surface air saturation specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_qsfc | surface_specific_humidity_for_MYJ_schemes | surface air saturation specific humidity for MYJ schem| kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_thz0 | potential_temperature_at_viscous_sublayer_top | potential temperat at viscous sublayer top over water | K | 1 | real | kind_phys | inout | F | -!! | phy_myj_qz0 | specific_humidity_at_viscous_sublayer_top | specific humidity at_viscous sublayer top over water | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_uz0 | u_wind_component_at_viscous_sublayer_top | u wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_vz0 | v_wind_component_at_viscous_sublayer_top | v wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_z0base | baseline_surface_roughness_length | baseline surface roughness length for momentum in mete| m | 1 | real | kind_phys | inout | F | -!! | phy_myj_akhs | heat_exchange_coefficient_for_MYJ_schemes | surface heat exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_akms | momentum_exchange_coefficient_for_MYJ_schemes | surface momentum exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_chkqlm | surface_layer_evaporation_switch | surface layer evaporation switch | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_elflx | kinematic_surface_latent_heat_flux | kinematic surface latent heat flux | m s-1 kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1u | weight_for_momentum_at_viscous_sublayer_top | Weight for momentum at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1t | weight_for_potental_temperature_at_viscous_sublayer_top | Weight for potental temperature at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1q | weight_for_specific_humidity_at_viscous_sublayer_top | Weight for Specfic Humidity at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | pblh | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | -!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | -!! | kinver | index_of_highest_temperature_inversion | index of highest temperature inversion | index | 1 | integer | | in | F | -!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | -!! | garea | cell_area | area of the grid cell | m2 | 1 | real | kind_phys | in | F | -!! | ustar | surface_friction_velocity | boundary layer parameter | m s-1 | 1 | real | kind_phys | inout | F | -!! | cm | surface_drag_coefficient_for_momentum_in_air | surface exchange coeff for momentum | none | 1 | real | kind_phys | inout | F | -!! | ch | surface_drag_coefficient_for_heat_and_moisture_in_air | surface exchange coeff heat & moisture | none | 1 | real | kind_phys | inout | F | -!! | wind | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | -!! | snowd | surface_snow_thickness_water_equivalent | water equivalent snow depth over land | mm | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | inout | F | -!! | hflx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | dudt | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | dvdt | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | dtdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | -!! | dqdt | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers PBL vertical diff | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | -!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dkt | atmosphere_heat_diffusivity | diffusivity for heat | m2 s-1 | 2 | real | kind_phys | out | F | -!! | xkzm_m | atmosphere_momentum_diffusivity_background | background value of momentum diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | -!! | xkzm_h | atmosphere_heat_diffusivity_background | background value of heat diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | -!! | xkzm_s | diffusivity_background_sigma_level | sigma level threshold for background diffusivity | none | 0 | real | kind_phys | in | F | -!! | gamt | countergradient_mixing_term_for_temperature | countergradient mixing term for temperature | K | 1 | real | kind_phys | inout | F | -!! | gamq | countergradient_mixing_term_for_water_vapor | countergradient mixing term for water vapor | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | lprnt | flag_print | control flag for diagnostic print out | flag | 0 | logical | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude myjpbl_wrapper_run.html !! #endif !###=================================================================== diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/module_MYJPBL_wrapper.meta new file mode 100644 index 000000000..a70203def --- /dev/null +++ b/physics/module_MYJPBL_wrapper.meta @@ -0,0 +1,651 @@ +[ccpp-arg-table] + name = myjpbl_wrapper_run + type = scheme +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_myjsfc] + standard_name = do_myjsfc + long_name = flag for MYJ surface layer scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ix] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[dt_phs] + standard_name = time_step_for_physics + long_name = time step for physics + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current time step index + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_vertical_diffusion_tracers + long_name = number of tracers to diffuse vertically + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = cloud condensate index in tracer array + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrw] + standard_name = index_for_rain_water + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsw] + standard_name = index_for_snow_water + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = x component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = y component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = layer mean air temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs] + standard_name = vertically_diffused_tracer_concentration + long_name = tracer concentration diffused by PBL scheme + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[hprime1] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsik_1] + standard_name = dimensionless_exner_function_at_lowest_model_interface + long_name = dimensionless Exner function at lowest model interface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk_1] + standard_name = dimensionless_exner_function_at_lowest_model_layer + long_name = dimensionless Exner function at lowest model layer + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qsfc] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qsfc] + standard_name = surface_specific_humidity_for_MYJ_schemes + long_name = surface air saturation specific humidity for MYJ schem + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_thz0] + standard_name = potential_temperature_at_viscous_sublayer_top + long_name = potential temperat at viscous sublayer top over water + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qz0] + standard_name = specific_humidity_at_viscous_sublayer_top + long_name = specific humidity at_viscous sublayer top over water + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_uz0] + standard_name = u_wind_component_at_viscous_sublayer_top + long_name = u wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_vz0] + standard_name = v_wind_component_at_viscous_sublayer_top + long_name = v wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_z0base] + standard_name = baseline_surface_roughness_length + long_name = baseline surface roughness length for momentum in mete + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akhs] + standard_name = heat_exchange_coefficient_for_MYJ_schemes + long_name = surface heat exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akms] + standard_name = momentum_exchange_coefficient_for_MYJ_schemes + long_name = surface momentum exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_chkqlm] + standard_name = surface_layer_evaporation_switch + long_name = surface layer evaporation switch + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_elflx] + standard_name = kinematic_surface_latent_heat_flux + long_name = kinematic surface latent heat flux + units = m s-1 kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1u] + standard_name = weight_for_momentum_at_viscous_sublayer_top + long_name = Weight for momentum at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1t] + standard_name = weight_for_potental_temperature_at_viscous_sublayer_top + long_name = Weight for potental temperature at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1q] + standard_name = weight_for_specific_humidity_at_viscous_sublayer_top + long_name = Weight for Specfic Humidity at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[pblh] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = PBL top model level index + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[garea] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air + long_name = surface exchange coeff for momentum + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snowd] + standard_name = surface_snow_thickness_water_equivalent + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dqdt] + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers PBL vertical diff + units = kg kg-1 s-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = inout + optional = F +[dusfc] + standard_name = instantaneous_surface_x_momentum_flux + long_name = x momentum flux + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc] + standard_name = instantaneous_surface_y_momentum_flux + long_name = y momentum flux + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtsfc] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dqsfc] + standard_name = instantaneous_surface_upward_latent_heat_flux + long_name = surface upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dkt] + standard_name = atmosphere_heat_diffusivity + long_name = diffusivity for heat + units = m2 s-1 + dimensions = (horizontal_dimension,vertical_dimension_minus_one) + type = real + kind = kind_phys + intent = out + optional = F +[xkzm_m] + standard_name = atmosphere_momentum_diffusivity_background + long_name = background value of momentum diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[xkzm_h] + standard_name = atmosphere_heat_diffusivity_background + long_name = background value of heat diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[xkzm_s] + standard_name = diffusivity_background_sigma_level + long_name = sigma level threshold for background diffusivity + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[gamt] + standard_name = countergradient_mixing_term_for_temperature + long_name = countergradient mixing term for temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[gamq] + standard_name = countergradient_mixing_term_for_water_vapor + long_name = countergradient mixing term for water vapor + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[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 + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/module_MYJSFC_wrapper.F90 index 2d8399d90..219130374 100644 --- a/physics/module_MYJSFC_wrapper.F90 +++ b/physics/module_MYJSFC_wrapper.F90 @@ -15,100 +15,7 @@ end subroutine myjsfc_wrapper_finalize !> \brief This scheme (1) performs pre-myjsfc work, (20 runs the myj sfc layer scheme, and (3) performs post-myjsfc work #if 0 !! \section arg_table_myjsfc_wrapper_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-------------|-----------|--------|----------| -!! | restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | -!! | ntke | index_for_turbulent_kinetic_energy | tracer index for turbulent kinetic energy | index | 0 | integer | | in | F | -!! | ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | -!! | ntrw | index_for_rain_water | tracer index for rain water | index | 0 | integer | | in | F | -!! | ntsw | index_for_snow_water | tracer index for snow water | index | 0 | integer | | in | F | -!! | ntgl | index_for_graupel | tracer index for graupel | index | 0 | integer | | in | F | -!! | iter | ccpp_loop_counter | loop counter for subcycling loops in CCPP | index | 0 | integer | | in | F | -!! | flag_iter | flag_for_iteration | flag for iteration | flag | 1 | logical | | in | F | -!! | ugrs | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | vgrs | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | tgrs | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | qgrs | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | prsik_1 | dimensionless_exner_function_at_lowest_model_interface | dimensionless Exner function at lowest model interface| none | 1 | real | kind_phys | in | F | -!! | prslk_1 | dimensionless_exner_function_at_lowest_model_layer | dimensionless Exner function at lowest model layer | none | 1 | real | kind_phys | in | F | -!! | tsfc | surface_skin_temperature | surface temperature | K | 1 | real | kind_phys | in | F | -!! | qsfc | surface_specific_humidity | surface air saturation specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_qsfc | surface_specific_humidity_for_MYJ_schemes | surface air saturation specific humidity for MYJ schem| kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_thz0 | potential_temperature_at_viscous_sublayer_top | potential temperat at viscous sublayer top over water | K | 1 | real | kind_phys | inout | F | -!! | phy_myj_qz0 | specific_humidity_at_viscous_sublayer_top | specific humidity at_viscous sublayer top over water | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_uz0 | u_wind_component_at_viscous_sublayer_top | u wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_vz0 | v_wind_component_at_viscous_sublayer_top | v wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_z0base | baseline_surface_roughness_length | baseline surface roughness length for momentum in mete| m | 1 | real | kind_phys | inout | F | -!! | phy_myj_akhs | heat_exchange_coefficient_for_MYJ_schemes | surface heat exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_akms | momentum_exchange_coefficient_for_MYJ_schemes | surface momentum exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_chkqlm | surface_layer_evaporation_switch | surface layer evaporation switch | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_elflx | kinematic_surface_latent_heat_flux | kinematic surface latent heat flux | m s-1 kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1u | weight_for_momentum_at_viscous_sublayer_top | Weight for momentum at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1t | weight_for_potental_temperature_at_viscous_sublayer_top | Weight for potental temperature at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1q | weight_for_specific_humidity_at_viscous_sublayer_top | Weight for Specfic Humidity at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | pblh | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | inout | F | -!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length | cm | 1 | real | kind_phys | in | F | -!! | ustar | surface_friction_velocity | boundary layer parameter | m s-1 | 1 | real | kind_phys | inout | F | -!! | rib | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | inout | F | -!! | cm | surface_drag_coefficient_for_momentum_in_air | surface exchange coeff for momentum | none | 1 | real | kind_phys | inout | F | -!! | ch | surface_drag_coefficient_for_heat_and_moisture_in_air | surface exchange coeff heat & moisture | none | 1 | real | kind_phys | inout | F | -!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | -!! | ffm | Monin_Obukhov_similarity_function_for_momentum | Monin_Obukhov similarity function for momentum | none | 1 | real | kind_phys | inout | F | -!! | ffh | Monin_Obukhov_similarity_function_for_heat | Monin_Obukhov similarity function for heat | none | 1 | real | kind_phys | inout | F | -!! | fm10 | Monin_Obukhov_similarity_function_for_momentum_at_10m | Monin_Obukhov similarity parameter for momentum at 10m| none | 1 | real | kind_phys | inout | F | -!! | fh2 | Monin_Obukhov_similarity_function_for_heat_at_2m | Monin_Obukhov similarity parameter for heat at 2m | none | 1 | real | kind_phys | inout | F | -!! | landfrac | land_area_fraction | fraction of horizontal grid area occupied by land | frac | 1 | real | kind_phys | inout | F | -!! | lakefrac | lake_area_fraction | fraction of horizontal grid area occupied by lake | frac | 1 | real | kind_phys | inout | F | -!! | oceanfrac | sea_area_fraction | fraction of horizontal grid area occupied by ocean | frac | 1 | real | kind_phys | inout | F | -!! | fice | sea_ice_concentration | ice fraction over open water | frac | 1 | real | kind_phys | in | F | -!! | z0rl_ocn | surface_roughness_length_over_ocean_interstitial | surface roughness length over ocean (interstitial) | cm | 1 | real | kind_phys | inout | F | -!! | z0rl_lnd | surface_roughness_length_over_land_interstitial | surface roughness length over land (interstitial) | cm | 1 | real | kind_phys | inout | F | -!! | z0rl_ice | surface_roughness_length_over_ice_interstitial | surface roughness length over ice (interstitial) | cm | 1 | real | kind_phys | inout | F | -!! | ustar_ocn | surface_friction_velocity_over_ocean | surface friction velocity over ocean | m s-1 | 1 | real | kind_phys | inout | F | -!! | ustar_lnd | surface_friction_velocity_over_land | surface friction velocity over land | m s-1 | 1 | real | kind_phys | inout | F | -!! | ustar_ice | surface_friction_velocity_over_ice | surface friction velocity over ice | m s-1 | 1 | real | kind_phys | inout | F | -!! | cm_ocn | surface_drag_coefficient_for_momentum_in_air_over_ocean | surface exchange coeff for momentum over ocean | none | 1 | real | kind_phys | inout | F | -!! | cm_lnd | surface_drag_coefficient_for_momentum_in_air_over_land | surface exchange coeff for momentum over land | none | 1 | real | kind_phys | inout | F | -!! | cm_ice | surface_drag_coefficient_for_momentum_in_air_over_ice | surface exchange coeff for momentum over ice | none | 1 | real | kind_phys | inout | F | -!! | ch_ocn | surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean | surface exchange coeff heat & moisture over ocean | none | 1 | real | kind_phys | inout | F | -!! | ch_lnd | surface_drag_coefficient_for_heat_and_moisture_in_air_over_land | surface exchange coeff heat & moisture over land | none | 1 | real | kind_phys | inout | F | -!! | ch_ice | surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice | surface exchange coeff heat & moisture over ice | none | 1 | real | kind_phys | inout | F | -!! | rb_ocn | bulk_richardson_number_at_lowest_model_level_over_ocean | bulk Richardson number at the surface over ocean | none | 1 | real | kind_phys | inout | F | -!! | rb_lnd | bulk_richardson_number_at_lowest_model_level_over_land | bulk Richardson number at the surface over land | none | 1 | real | kind_phys | inout | F | -!! | rb_ice | bulk_richardson_number_at_lowest_model_level_over_ice | bulk Richardson number at the surface over ice | none | 1 | real | kind_phys | inout | F | -!! | stress_ocn | surface_wind_stress_over_ocean | surface wind stress over ocean | m2 s-2 | 1 | real | kind_phys | inout | F | -!! | stress_lnd | surface_wind_stress_over_land | surface wind stress over land | m2 s-2 | 1 | real | kind_phys | inout | F | -!! | stress_ice | surface_wind_stress_over_ice | surface wind stress over ice | m2 s-2 | 1 | real | kind_phys | inout | F | -!! | fm_ocn | Monin_Obukhov_similarity_function_for_momentum_over_ocean | Monin-Obukhov similarity funct for momentum over ocean| none | 1 | real | kind_phys | inout | F | -!! | fm_lnd | Monin_Obukhov_similarity_function_for_momentum_over_land | Monin-Obukhov similarity funct for momentum over land | none | 1 | real | kind_phys | inout | F | -!! | fm_ice | Monin_Obukhov_similarity_function_for_momentum_over_ice | Monin-Obukhov similarity funct for momentum over ice | none | 1 | real | kind_phys | inout | F | -!! | fh_ocn | Monin_Obukhov_similarity_function_for_heat_over_ocean | Monin-Obukhov similarity function for heat over ocean | none | 1 | real | kind_phys | inout | F | -!! | fh_lnd | Monin_Obukhov_similarity_function_for_heat_over_land | Monin-Obukhov similarity function for heat over land | none | 1 | real | kind_phys | inout | F | -!! | fh_ice | Monin_Obukhov_similarity_function_for_heat_over_ice | Monin-Obukhov similarity function for heat over ice | none | 1 | real | kind_phys | inout | F | -!! | fm10_ocn | Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean | Monin-Obukhov parameter for momentum at 10m over ocean| none | 1 | real | kind_phys | inout | F | -!! | fm10_lnd | Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land | Monin-Obukhov parameter for momentum at 10m over land | none | 1 | real | kind_phys | inout | F | -!! | fm10_ice | Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice | Monin-Obukhov parameter for momentum at 10m over ice | none | 1 | real | kind_phys | inout | F | -!! | fh2_ocn | Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean | Monin-Obukhov parameter for heat at 2m over ocean | none | 1 | real | kind_phys | inout | F | -!! | fh2_lnd | Monin_Obukhov_similarity_function_for_heat_at_2m_over_land | Monin-Obukhov parameter for heat at 2m over land | none | 1 | real | kind_phys | inout | F | -!! | fh2_ice | Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice | Monin-Obukhov parameter for heat at 2m over ice | none | 1 | real | kind_phys | inout | F | -!! | wind | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | out | F | -!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | lprnt | flag_print | control flag for diagnostic print out | flag | 0 | logical | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude myjsfc_wrapper_run.html !! #endif !###=================================================================== diff --git a/physics/module_MYJSFC_wrapper.meta b/physics/module_MYJSFC_wrapper.meta new file mode 100644 index 000000000..8100d0b05 --- /dev/null +++ b/physics/module_MYJSFC_wrapper.meta @@ -0,0 +1,814 @@ +[ccpp-arg-table] + name = myjsfc_wrapper_run + type = scheme +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ix] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current time step index + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = cloud condensate index in tracer array + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrw] + standard_name = index_for_rain_water + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsw] + standard_name = index_for_snow_water + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[iter] + standard_name = ccpp_loop_counter + long_name = loop counter for subcycling loops in CCPP + units = index + dimensions = () + type = integer + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = x component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = y component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = layer mean air temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[prsik_1] + standard_name = dimensionless_exner_function_at_lowest_model_interface + long_name = dimensionless Exner function at lowest model interface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk_1] + standard_name = dimensionless_exner_function_at_lowest_model_layer + long_name = dimensionless Exner function at lowest model layer + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qsfc] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qsfc] + standard_name = surface_specific_humidity_for_MYJ_schemes + long_name = surface air saturation specific humidity for MYJ schem + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_thz0] + standard_name = potential_temperature_at_viscous_sublayer_top + long_name = potential temperat at viscous sublayer top over water + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qz0] + standard_name = specific_humidity_at_viscous_sublayer_top + long_name = specific humidity at_viscous sublayer top over water + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_uz0] + standard_name = u_wind_component_at_viscous_sublayer_top + long_name = u wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_vz0] + standard_name = v_wind_component_at_viscous_sublayer_top + long_name = v wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_z0base] + standard_name = baseline_surface_roughness_length + long_name = baseline surface roughness length for momentum in mete + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akhs] + standard_name = heat_exchange_coefficient_for_MYJ_schemes + long_name = surface heat exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akms] + standard_name = momentum_exchange_coefficient_for_MYJ_schemes + long_name = surface momentum exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_chkqlm] + standard_name = surface_layer_evaporation_switch + long_name = surface layer evaporation switch + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_elflx] + standard_name = kinematic_surface_latent_heat_flux + long_name = kinematic surface latent heat flux + units = m s-1 kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1u] + standard_name = weight_for_momentum_at_viscous_sublayer_top + long_name = Weight for momentum at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1t] + standard_name = weight_for_potental_temperature_at_viscous_sublayer_top + long_name = Weight for potental temperature at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1q] + standard_name = weight_for_specific_humidity_at_viscous_sublayer_top + long_name = Weight for Specfic Humidity at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[pblh] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rib] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air + long_name = surface exchange coeff for momentum + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stress] + standard_name = surface_wind_stress + long_name = surface wind stress + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ffm] + standard_name = Monin_Obukhov_similarity_function_for_momentum + long_name = Monin_Obukhov similarity function for momentum + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ffh] + standard_name = Monin_Obukhov_similarity_function_for_heat + long_name = Monin_Obukhov similarity function for heat + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m + long_name = Monin_Obukhov similarity parameter for momentum at 10m + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m + long_name = Monin_Obukhov similarity parameter for heat at 2m + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[z0rl_ocn] + standard_name = surface_roughness_length_over_ocean_interstitial + long_name = surface roughness length over ocean (interstitial) + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[z0rl_lnd] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (interstitial) + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[z0rl_ice] + standard_name = surface_roughness_length_over_ice_interstitial + long_name = surface roughness length over ice (interstitial) + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_ocn] + standard_name = surface_friction_velocity_over_ocean + long_name = surface friction velocity over ocean + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_lnd] + standard_name = surface_friction_velocity_over_land + long_name = surface friction velocity over land + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm_ocn] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean + long_name = surface exchange coeff for momentum over ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm_lnd] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm_ice] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice + long_name = surface exchange coeff for momentum over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_ocn] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean + long_name = surface exchange coeff heat & moisture over ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_lnd] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_ice] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice + long_name = surface exchange coeff heat & moisture over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_ocn] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ocean + long_name = bulk Richardson number at the surface over ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_lnd] + standard_name = bulk_richardson_number_at_lowest_model_level_over_land + long_name = bulk Richardson number at the surface over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_ice] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ice + long_name = bulk Richardson number at the surface over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_ocn] + standard_name = surface_wind_stress_over_ocean + long_name = surface wind stress over ocean + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_lnd] + standard_name = surface_wind_stress_over_land + long_name = surface wind stress over land + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_ice] + standard_name = surface_wind_stress_over_ice + long_name = surface wind stress over ice + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_ocn] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean + long_name = Monin-Obukhov similarity funct for momentum over ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_land + long_name = Monin-Obukhov similarity funct for momentum over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice + long_name = Monin-Obukhov similarity funct for momentum over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_ocn] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean + long_name = Monin-Obukhov similarity function for heat over ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_land + long_name = Monin-Obukhov similarity function for heat over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice + long_name = Monin-Obukhov similarity function for heat over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_ocn] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean + long_name = Monin-Obukhov parameter for momentum at 10m over ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land + long_name = Monin-Obukhov parameter for momentum at 10m over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice + long_name = Monin-Obukhov parameter for momentum at 10m over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_ocn] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean + long_name = Monin-Obukhov parameter for heat at 2m over ocean + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_land + long_name = Monin-Obukhov parameter for heat at 2m over land + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice + long_name = Monin-Obukhov parameter for heat at 2m over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[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 + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From 268f9a54f8611854dc7158102d4f3d2327144016 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 13 Sep 2019 16:34:39 -0600 Subject: [PATCH 23/59] physics/GFS_time_vary_pre.fv3.F90: trim trailing whitespaces --- physics/GFS_time_vary_pre.fv3.F90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 8f146de92..46284a1bb 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -30,7 +30,7 @@ subroutine GFS_time_vary_pre_init (errmsg, errflg) errflg = 0 if (is_initialized) return - + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. call gfuncphys () @@ -72,7 +72,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & use machine, only: kind_phys implicit none - + integer, intent(in) :: idate(4) integer, intent(in) :: jdat(1:8), idat(1:8) integer, intent(in) :: lsm, lsm_noahmp, & @@ -80,21 +80,21 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & master, nscyc logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp - + integer, intent(out) :: kdt, yearlen, ipt logical, intent(out) :: lprnt, lssav, lsswr, & lslwr real(kind=kind_phys), intent(out) :: sec, phour, zhour, & fhour, julian, solhr - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys real(kind=kind_phys) :: rinc(5) - - integer :: iw3jdn + + integer :: iw3jdn integer :: jd0, jd1 real :: fjd @@ -120,14 +120,14 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & zhour = phour fhour = (sec + dtp)/con_hr kdt = nint((sec + dtp)/dtp) - + if(lsm == lsm_noahmp) then - !GJF* These calculations were originally in GFS_physics_driver.F90 for - ! NoahMP. They were moved to this routine since they only depends - ! on time (not space). Note that this code is included as-is from - ! GFS_physics_driver.F90, but it may be simplified by using more - ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day - ! of year and W3DIFDAT to determine the integer number of days in + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depend + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in ! a given year). *GJF ! Julian day calculation (fcst day of the year) ! we need yearln and julian to @@ -140,7 +140,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 julian = float(jd1-jd0) + fjd - + ! ! Year length ! @@ -158,7 +158,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & endif endif endif - + ipt = 1 lprnt = .false. lssav = .true. From 26ed03832a92345201157096f7edbc6bb4f8960e Mon Sep 17 00:00:00 2001 From: climbfuji Date: Mon, 16 Sep 2019 15:33:45 -0600 Subject: [PATCH 24/59] physics/GFS_phys_time_vary.fv3.F90: disable calculation of snocvr in CCPP (do in FV3-IPD) to avoid b4b issues when 32BIT=Y --- physics/GFS_phys_time_vary.fv3.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 2d97e6bf2..2b79d6883 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -22,9 +22,11 @@ module GFS_phys_time_vary use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol - + +#if 0 !--- variables needed for calculating 'sncovr' use namelist_soilveg, only: salp_data, snupx +#endif implicit none @@ -326,7 +328,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, use mersenne_twister, only: random_setseed, random_number use machine, only: kind_phys use GFS_typedefs, only: GFS_control_type, GFS_data_type - + implicit none ! Interface variables @@ -496,7 +498,8 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, enddo endif endif - + +#if 0 !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) if (first_time_step) then if (nint(Data(1)%Sfcprop%sncovr(1)) == -9999) then @@ -519,6 +522,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, enddo endif endif +#endif end subroutine GFS_phys_time_vary_run !> @} From d98248aad15ebeb9f3ba84e070be4b1ad543bc20 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 18 Sep 2019 13:46:17 -0600 Subject: [PATCH 25/59] CMakeLists.txt: compile ./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 with default double precision --- CMakeLists.txt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bfcceebc6..d34b491f8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -115,7 +115,7 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-ffree-line-length-none -fdefault-real-8 -ffree-form") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") - + SET_SOURCE_FILES_PROPERTIES(./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") if (PROJECT STREQUAL "CCPP-FV3") # Set 32-bit floating point precision flags for certain files # that are executed in the dynamics (fast physics part) @@ -167,6 +167,8 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 ./physics/module_mp_thompson_make_number_concentrations.F90 + ./physics/module_SF_JSFC.F90 + ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-r8 -ftz") # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files @@ -265,6 +267,8 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") SET_SOURCE_FILES_PROPERTIES(./physics/mersenne_twister.f PROPERTIES COMPILE_FLAGS "-r8 -ftz") SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-extend-source 132 -r8 -free") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-r8") endif (PROJECT STREQUAL "CCPP-FV3") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -r8) @@ -273,6 +277,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-r8 -Mfree") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-r8") if (PROJECT STREQUAL "CCPP-FV3") # Set 32-bit floating point precision flags for certain files # that are executed in the dynamics (fast physics part) From 806de330f2e8cda7bfa2e6ed4a6cc7753e3da27b Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 18 Sep 2019 13:47:52 -0600 Subject: [PATCH 26/59] physics/module_BL_MYJPBL.F90, physics/module_SF_JSFC.F90, physics/module_MYJSFC_wrapper.F90: use double precision floats, remove trailing whitespaces --- physics/module_BL_MYJPBL.F90 | 153 +++++++++++++++--------------- physics/module_MYJSFC_wrapper.F90 | 23 +++-- physics/module_SF_JSFC.F90 | 7 +- 3 files changed, 92 insertions(+), 91 deletions(-) diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 index 6f455221b..af7967ebf 100755 --- a/physics/module_BL_MYJPBL.F90 +++ b/physics/module_BL_MYJPBL.F90 @@ -24,7 +24,7 @@ MODULE MODULE_BL_MYJPBL ! integer,parameter :: idouble=selected_int_kind(r=18) ! integer,parameter :: single=selected_real_kind(p=6,r=37) ! integer,parameter :: double=selected_real_kind(p=13,r=200) - + ! integer,parameter:: & ! klog=4 & ! ,kint=isingle & @@ -39,7 +39,8 @@ MODULE MODULE_BL_MYJPBL integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision REAL(kind=kfpt),PARAMETER :: A2=17.2693882,A3=273.15,A4=35.86,CP=1004.6 & @@ -177,7 +178,7 @@ MODULE MODULE_BL_MYJPBL REAL(KIND=KFPT),DIMENSION(1:ITBL),PRIVATE,SAVE:: & STHE & ! RANGE FOR EQUIVALENT POTENTIAL TEMPERATURE -,THE0 ! BASE FOR EQUIVALENT POTENTIAL TEMPERATURE +,THE0 ! BASE FOR EQUIVALENT POTENTIAL TEMPERATURE REAL(KIND=KFPT),DIMENSION(1:JTBL),PRIVATE,SAVE:: & QS0 & ! BASE FOR SATURATION SPECIFIC HUMIDITY @@ -960,7 +961,7 @@ SUBROUTINE MIXLEN & if( & (q2(k).gt.epsq2(k)) .and. & (q2(k)*cubry.gt.(dz*wcon*rsqdt)**2) & - ) then + ) then ! DTHV=(THE(K)-THE(K+1))+DTHV ! @@ -1119,7 +1120,7 @@ SUBROUTINE PRODQ2 & !********************************************************************** !---------------------------------------------------------------------- ! - + ! IFLAG=1 main_integration: DO K=1,LMH-1 @@ -1149,7 +1150,7 @@ SUBROUTINE PRODQ2 & ! & .OR.(EQOL2<=EPS2)).and.IFLAG.EQ.1)THEN ! ! if(ntsd.eq.23.and.me.eq.76.and.I.eq.32)then -! print*,'no turb=',K,GML,GHL,EPSTRB,EPSGH,REQU,EQOL2,EPS2,GML/GHL +! print*,'no turb=',K,GML,GHL,EPSTRB,EPSGH,REQU,EQOL2,EPS2,GML/GHL ! end if !---------------------------------------------------------------------- !*** NO TURBULENCE @@ -2075,7 +2076,7 @@ SUBROUTINE TABLETT !----------------------------------------------------------------------- ENDSUBROUTINE TABLETT !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) + SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) ! ****************************************************************** ! * * ! * THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE * @@ -2102,80 +2103,80 @@ SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) ! ****************************************************************** IMPLICIT REAL(KIND=KFPT)(A-H,O-Z),INTEGER(KIND=KINT)(I-N) !----------------------------------------------------------------------- - DIMENSION & - XOLD(JTBL),YOLD(JTBL),Y2(JTBL),P(JTBL),Q(JTBL) & - ,XNEW(JTBL),YNEW(JTBL) + DIMENSION & + XOLD(JTBL),YOLD(JTBL),Y2(JTBL),P(JTBL),Q(JTBL) & + ,XNEW(JTBL),YNEW(JTBL) !----------------------------------------------------------------------- - NOLDM1=NOLD-1 -! - DXL=XOLD(2)-XOLD(1) - DXR=XOLD(3)-XOLD(2) - DYDXL=(YOLD(2)-YOLD(1))/DXL - DYDXR=(YOLD(3)-YOLD(2))/DXR - RTDXC=.5/(DXL+DXR) -! - P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) - Q(1)=-RTDXC*DXR -! - IF(NOLD.EQ.3) GO TO 700 + NOLDM1=NOLD-1 +! + DXL=XOLD(2)-XOLD(1) + DXR=XOLD(3)-XOLD(2) + DYDXL=(YOLD(2)-YOLD(1))/DXL + DYDXR=(YOLD(3)-YOLD(2))/DXR + RTDXC=.5/(DXL+DXR) +! + P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) + Q(1)=-RTDXC*DXR +! + IF(NOLD.EQ.3) GO TO 700 !----------------------------------------------------------------------- - K=3 -! - 100 DXL=DXR - DYDXL=DYDXR - DXR=XOLD(K+1)-XOLD(K) - DYDXR=(YOLD(K+1)-YOLD(K))/DXR - DXC=DXL+DXR - DEN=1./(DXL*Q(K-2)+DXC+DXC) -! - P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) - Q(K-1)=-DEN*DXR -! - K=K+1 - IF(K.LT.NOLD) GO TO 100 + K=3 +! + 100 DXL=DXR + DYDXL=DYDXR + DXR=XOLD(K+1)-XOLD(K) + DYDXR=(YOLD(K+1)-YOLD(K))/DXR + DXC=DXL+DXR + DEN=1./(DXL*Q(K-2)+DXC+DXC) +! + P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) + Q(K-1)=-DEN*DXR +! + K=K+1 + IF(K.LT.NOLD) GO TO 100 !----------------------------------------------------------------------- - 700 K=NOLDM1 -! - 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) -! - K=K-1 - IF(K.GT.1) GO TO 200 + 700 K=NOLDM1 +! + 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) +! + K=K-1 + IF(K.GT.1) GO TO 200 !----------------------------------------------------------------------- - K1=1 -! - 300 XK=XNEW(K1) -! - DO 400 K2=2,NOLD - IF(XOLD(K2).LE.XK) GO TO 400 - KOLD=K2-1 - GO TO 450 - 400 CONTINUE - YNEW(K1)=YOLD(NOLD) - GO TO 600 -! - 450 IF(K1.EQ.1) GO TO 500 - IF(K.EQ.KOLD) GO TO 550 -! - 500 K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=.1666667*RDX*(Y2KP1-Y2K) - BK=.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) -! - 550 X=XK-XOLD(K) - XSQ=X*X -! - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - 600 K1=K1+1 - IF(K1.LE.NNEW) GO TO 300 + K1=1 +! + 300 XK=XNEW(K1) +! + DO 400 K2=2,NOLD + IF(XOLD(K2).LE.XK) GO TO 400 + KOLD=K2-1 + GO TO 450 + 400 CONTINUE + YNEW(K1)=YOLD(NOLD) + GO TO 600 +! + 450 IF(K1.EQ.1) GO TO 500 + IF(K.EQ.KOLD) GO TO 550 +! + 500 K=KOLD +! + Y2K=Y2(K) + Y2KP1=Y2(K+1) + DX=XOLD(K+1)-XOLD(K) + RDX=1./DX +! + AK=.1666667*RDX*(Y2KP1-Y2K) + BK=.5*Y2K + CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) +! + 550 X=XK-XOLD(K) + XSQ=X*X +! + YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) +! + 600 K1=K1+1 + IF(K1.LE.NNEW) GO TO 300 !----------------------------------------------------------------------- - ENDSUBROUTINE SPLINE + ENDSUBROUTINE SPLINE !----------------------------------------------------------------------- ! END MODULE MODULE_BL_MYJPBL diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/module_MYJSFC_wrapper.F90 index 219130374..917e22599 100644 --- a/physics/module_MYJSFC_wrapper.F90 +++ b/physics/module_MYJSFC_wrapper.F90 @@ -1,5 +1,5 @@ !> \file module_myjsfc_wrapper.F90 -!! Contains all of the code related to running the MYJ surface layer scheme +!! Contains all of the code related to running the MYJ surface layer scheme MODULE myjsfc_wrapper @@ -13,11 +13,9 @@ end subroutine myjsfc_wrapper_finalize !! !> \brief This scheme (1) performs pre-myjsfc work, (20 runs the myj sfc layer scheme, and (3) performs post-myjsfc work -#if 0 !! \section arg_table_myjsfc_wrapper_run Argument Table !! \htmlinclude myjsfc_wrapper_run.html !! -#endif !###=================================================================== SUBROUTINE myjsfc_wrapper_run( & & restart, & @@ -48,18 +46,19 @@ SUBROUTINE myjsfc_wrapper_run( & & fh2_ocn, fh2_lnd, fh2_ice, & ! intent(inout) & wind, con_cp, con_g, con_rd, & & me, lprnt, errmsg, errflg ) ! intent(inout) -! +! use machine, only : kind_phys use MODULE_SF_JSFC, only: JSFC_INIT,JSFC -!------------------------------------------------------------------- +!------------------------------------------------------------------- implicit none -!------------------------------------------------------------------- +!------------------------------------------------------------------- integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision ! ! --- constant parameters: @@ -82,7 +81,7 @@ SUBROUTINE myjsfc_wrapper_run( & integer, intent(out) :: errflg !MYJ-1D - integer,intent(in) :: im, ix, levs + integer,intent(in) :: im, ix, levs integer,intent(in) :: kdt, iter, me integer,intent(in) :: ntrac,ntke,ntcw,ntiw,ntrw,ntsw,ntgl logical,intent(in) :: restart, lprnt @@ -143,9 +142,9 @@ SUBROUTINE myjsfc_wrapper_run( & & cw, dz_myj, pmid, q2, exner real(kind=kfpt), dimension(im,levs+1) :: pint real(kind=kfpt),dimension(im) :: & - & cm1,ch1,stress1,ffm1,ffh1,wind1,ffm10,ffh2 + & cm1,ch1,stress1,ffm1,ffh1,wind1,ffm10,ffh2 ! real(kind=kind_phys), dimension(im,levs,ntrac) :: & -! & qgrs_myj +! & qgrs_myj ! Initialize CCPP error handling variables errmsg = '' @@ -230,7 +229,7 @@ SUBROUTINE myjsfc_wrapper_run( & dz_myj(i,k) = (phii(i,k1+1)-phii(i,k1)) * g_inv enddo enddo - + if (lprnt1) then if(me==0.and.ntsd.lt.2)then k=63 @@ -302,7 +301,7 @@ SUBROUTINE myjsfc_wrapper_run( & & ,1,im,1,1,1,levs & & ,1,im,1,1,1,levs) end if - + call JSFC(flag_iter,iter,me & & ,ntsd,epsq2,sfcz,dz_myj & & ,pmid,pint,th_myj,t_myj,q_myj,cw & diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 0c79f8de1..76a9d1fa7 100755 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -38,7 +38,8 @@ MODULE MODULE_SF_JSFC integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision ! PRIVATE @@ -92,7 +93,7 @@ MODULE MODULE_SF_JSFC !----------------------------------------------------------------------- INTEGER, PARAMETER :: KZTM=10001,KZTM2=KZTM-2 ! - REAL(kind=kfpt),PRIVATE,SAVE :: & + REAL(kind=kfpt),PRIVATE,SAVE :: & DZETA1,DZETA2,FH01,FH02,ZTMAX1,ZTMAX2,ZTMIN1,ZTMIN2 ! REAL(kind=kfpt),DIMENSION(KZTM),PRIVATE,SAVE :: & @@ -362,7 +363,7 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & ULOW=UK(LMH) VLOW=VK(LMH) ZSL=(ZHK(LMH)-ZHK(LMH+1))*0.5 -! if(me.eq.0)print*,'ZSL,ZHK(LMH),ZHK(LMH+1,LMH=',ZSL,ZHK(LMH),ZHK(LMH+1),LMH +! if(me.eq.0)print*,'ZSL,ZHK(LMH),ZHK(LMH+1,LMH=',ZSL,ZHK(LMH),ZHK(LMH+1),LMH APESFC=(PSFC*1.E-5)**CAPPA if(NTSD==0) then TZ0=TSK(I,J) From dceac20e1b563a7c2615284c4dbe97727b3d42ac Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 18 Sep 2019 13:48:26 -0600 Subject: [PATCH 27/59] physics/module_MYJPBL_wrapper.F90: use double precision floats, remove trailing whitespaces, declare local dkt2 array to account for dimension differences --- physics/module_MYJPBL_wrapper.F90 | 58 ++++++++++++++++++------------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/module_MYJPBL_wrapper.F90 index 8114afea4..aad072e42 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/module_MYJPBL_wrapper.F90 @@ -1,5 +1,5 @@ !> \file module_myjpbl_wrapper.F90 -!! Contains all of the code related to running the MYJ PBL scheme +!! Contains all of the code related to running the MYJ PBL scheme MODULE myjpbl_wrapper @@ -36,26 +36,27 @@ SUBROUTINE myjpbl_wrapper_run( & & garea, ustar, cm, ch, wind, & & snowd, zorl, evap, hflx, & & dudt, dvdt, dtdt, dqdt, & - & dusfc,dvsfc,dtsfc,dqsfc, & + & dusfc,dvsfc,dtsfc,dqsfc, & & dkt,xkzm_m, xkzm_h,xkzm_s, gamt,gamq, & & con_cp,con_g,con_rd, & & me, lprnt, errmsg, errflg ) -! +! use machine, only : kind_phys use MODULE_BL_MYJPBL, only: MYJPBL_INIT,MYJPBL -!------------------------------------------------------------------- +!------------------------------------------------------------------- implicit none integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision -!------------------------------------------------------------------- +!------------------------------------------------------------------- ! --- constant parameters: !For reference ! real , parameter :: karman = 0.4 @@ -63,10 +64,10 @@ SUBROUTINE myjpbl_wrapper_run( & ! real , parameter :: r_d = 287. ! real , parameter :: cp = 7.*r_d/2. ! -! real, parameter :: g = 9.81, r_d=287., cp= 7.*r_d/2. +! real, parameter :: g = 9.81, r_d=287., cp= 7.*r_d/2. ! real, parameter :: rd=r_d, rk=cp/rd ! real, parameter :: elwv=2.501e6, eliv=2.834e6 -! real, parameter :: reliw=eliv/elwv, +! real, parameter :: reliw=eliv/elwv, real, parameter :: xkgdx=25000.,xkzinv=0.15 ! real, parameter :: g_inv=1./con_g, cappa=con_rd/con_cp @@ -104,8 +105,12 @@ SUBROUTINE myjpbl_wrapper_run( & phii, prsi real(kind=kind_phys),dimension(im,levs),intent(in) :: & & ugrs, vgrs, tgrs, prsl +! real(kind=kind_phys),dimension(im,levs),intent(inout) :: & +! dudt, dvdt, dtdt, dkt real(kind=kind_phys),dimension(im,levs),intent(inout) :: & - dudt, dvdt, dtdt, dkt + dudt, dvdt, dtdt + real(kind=kind_phys),dimension(im,levs-1),intent(out) :: & + dkt !MYJ-4D real(kind=kind_phys),dimension(im,levs,ntrac),intent(inout) :: & @@ -135,10 +140,10 @@ SUBROUTINE myjpbl_wrapper_run( & real(kind=kfpt),dimension(im) :: & dusfc1,dvsfc1,dtsfc1,dqsfc1 real(kind=kfpt),dimension(im) :: thlm,qlm - real(kind=kfpt),dimension(im,13) :: phy_f2d_myj + real(kind=kfpt),dimension(im,13) :: phy_f2d_myj real(kind=kfpt), dimension(im,levs) :: xcofh & & ,xkzo,xkzmo - real(kind=kind_phys) :: g, r_d, g_inv, cappa + real(kind=kind_phys) :: g, r_d, g_inv, cappa real(kind=kind_phys) :: thz0, qz0, a1u, a1t, a1q real(kind=kind_phys) :: z0m, aa1u, aa1t, z1uov, z1tox real(kind=kind_phys) :: tmax,tmin,t_myj1 @@ -148,6 +153,7 @@ SUBROUTINE myjpbl_wrapper_run( & & ,rho,qfc1,gdx,xkzm_hx,xkzm_mx,tx1, tx2 ! real(kind=kind_phys), dimension(im,levs,ntrac) :: & ! & qgrs_myj + real(kind=kind_phys),dimension(im,levs) :: dkt2 ! Initialize CCPP error handling variables errmsg = '' @@ -169,11 +175,11 @@ SUBROUTINE myjpbl_wrapper_run( & end if !prep MYJ-only variables - + r_d = con_rd g = con_g - g_inv = 1./con_g - cappa = con_rd/con_cp + g_inv = 1./con_g + cappa = con_rd/con_cp do i=1,im work3(i)=prsik_1(i) / prslk_1(i) @@ -285,20 +291,20 @@ SUBROUTINE myjpbl_wrapper_run( & ! if (xkzo(i,k) .gt. 0.01) then ! epsl(k)=1.0 ! end if - end do + end do epsq2(levs)=epsq2(levs-1) do k = 1, levs k1 = levs-k+1 do i = 1, im - del(i,k) = prsi(i,k1) - prsi (i,k1+1) + del(i,k) = prsi(i,k1) - prsi (i,k1+1) dz_myj(i,k) = (phii(i,k1+1)-phii(i,k1)) * g_inv enddo enddo do i = 1, im wind1(i)=max(wind(i),1.0) - end do + end do if(.not.do_myjsfc)then do i=1,im @@ -433,7 +439,7 @@ SUBROUTINE myjpbl_wrapper_run( & tmax=t_myj(i,k1) i_max=i k_max=k - end if + end if if(tmin.gt.t_myj(i,k1))then tmin=t_myj(i,k1) i_min=i @@ -450,7 +456,7 @@ SUBROUTINE myjpbl_wrapper_run( & ! end if end if - + ct=0. ide=im lm=levs @@ -541,14 +547,14 @@ SUBROUTINE myjpbl_wrapper_run( & ! do k=1,13 ! Tbd%phy_f2d_myj(i,k)=phy_f2d_myj(i,k) ! end do - end do + end do - dkt=0. + dkt2=0. do k=1,levs k1=levs-k+1 do i=1,im -! dkt(i,k)=max(xcofh(i,k1),xkzo(i,k)) - dkt(i,k)=xcofh(i,k1) +! dkt2(i,k)=max(xcofh(i,k1),xkzo(i,k)) + dkt2(i,k)=xcofh(i,k1) end do end do if(ntke.gt.0)then @@ -617,7 +623,7 @@ SUBROUTINE myjpbl_wrapper_run( & (phy_f2d_myj(i,k),k=1,13) print*,'tsk(i),ustar1,z0,pblh_myj,kpbl_myj=', & tsk(i),ustar1(i),z0(i),pblh_myj(i),kpbl_myj(i) - print*,'mixht=',mixht(i) + print*,'mixht=',mixht(i) do k=1,levs print*,'u,v,t=',k,u_myj(i,k),v_myj(i,k), & t_myj(i,k) @@ -634,7 +640,7 @@ SUBROUTINE myjpbl_wrapper_run( & q2(i,k) end do do k=1,levs - print*,'xcofh,el_myj,dkt=',k,xcofh(i,k),el_myj(i,k),dkt(i,k) + print*,'xcofh,el_myj,dkt2=',k,xcofh(i,k),el_myj(i,k),dkt2(i,k) end do end if @@ -777,6 +783,8 @@ SUBROUTINE myjpbl_wrapper_run( & ! print* ! endif + ! External dkt has dimensions (1:im,1:levs-1) + dkt(1:im,1:levs-1) = dkt2(1:im,1:levs-1) END SUBROUTINE myjpbl_wrapper_run From d58c0eadada9ce4edd2c54dd47c9a5d2c97044ad Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 18 Sep 2019 15:55:51 -0600 Subject: [PATCH 28/59] update SCM version of GFS_time_vary_pre.F90 (matches FV3 version except for a comment) --- physics/GFS_time_vary_pre.scm.F90 | 126 ++++++++++++----- physics/GFS_time_vary_pre.scm.meta | 211 ++++++++++++++++++++++++++++- 2 files changed, 297 insertions(+), 40 deletions(-) diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/GFS_time_vary_pre.scm.F90 index 790cf0d1a..2fa352710 100644 --- a/physics/GFS_time_vary_pre.scm.F90 +++ b/physics/GFS_time_vary_pre.scm.F90 @@ -30,7 +30,7 @@ subroutine GFS_time_vary_pre_init (errmsg, errflg) errflg = 0 if (is_initialized) return - + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. call gfuncphys () @@ -65,20 +65,38 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_run Argument Table !! \htmlinclude GFS_time_vary_pre_run.html !! - subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) + subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & + nslwr, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, kdt, & + julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type implicit none - - type(GFS_control_type), intent(inout) :: Model + + integer, intent(in) :: idate(4) + integer, intent(in) :: jdat(1:8), idat(1:8) + integer, intent(in) :: lsm, lsm_noahmp, & + nsswr, nslwr, me, & + master, nscyc + logical, intent(in) :: debug + real(kind=kind_phys), intent(in) :: dtp + + integer, intent(out) :: kdt, yearlen, ipt + logical, intent(out) :: lprnt, lssav, lsswr, & + lslwr + real(kind=kind_phys), intent(out) :: sec, phour, zhour, & + fhour, julian, solhr + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys real(kind=kind_phys) :: rinc(5) + + integer :: iw3jdn + integer :: jd0, jd1 + real :: fjd ! Initialize CCPP error handling variables errmsg = '' @@ -86,47 +104,87 @@ subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) ! Check initialization status if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called before GFS_time_vary_pre_init" + write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called & + &before GFS_time_vary_pre_init" errflg = 1 return end if - !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90 + !--- jdat is being updated directly inside of the time integration + !--- loop of gmtb_scm.F90 !--- update calendars and triggers rinc(1:5) = 0 - call w3difdat(Model%jdat,Model%idat,4,rinc) - Model%sec = rinc(4) - Model%phour = Model%sec/con_hr + call w3difdat(jdat,idat,4,rinc) + sec = rinc(4) + phour = sec/con_hr !--- set current bucket hour - Model%zhour = Model%phour - Model%fhour = (Model%sec + Model%dtp)/con_hr - Model%kdt = nint((Model%sec + Model%dtp)/Model%dtp) - - Model%ipt = 1 - Model%lprnt = .false. - Model%lssav = .true. + zhour = phour + fhour = (sec + dtp)/con_hr + kdt = nint((sec + dtp)/dtp) + + if(lsm == lsm_noahmp) then + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depends + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in + ! a given year). *GJF + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 + endif + endif + endif + endif + + ipt = 1 + lprnt = .false. + lssav = .true. !--- radiation triggers - Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) - Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + lsswr = (mod(kdt, nsswr) == 1) + lslwr = (mod(kdt, nslwr) == 1) !--- allow for radiation to be called on every physics time step, if needed - if (Model%nsswr == 1) Model%lsswr = .true. - if (Model%nslwr == 1) Model%lslwr = .true. + if (nsswr == 1) lsswr = .true. + if (nslwr == 1) lslwr = .true. !--- set the solar hour based on a combination of phour and time initial hour - Model%solhr = mod(Model%phour+Model%idate(1),con_24) - - if ((Model%debug) .and. (Model%me == Model%master)) then - print *,' sec ', Model%sec - print *,' kdt ', Model%kdt - print *,' nsswr ', Model%nsswr - print *,' nslwr ', Model%nslwr - print *,' nscyc ', Model%nscyc - print *,' lsswr ', Model%lsswr - print *,' lslwr ', Model%lslwr - print *,' fhour ', Model%fhour - print *,' phour ', Model%phour - print *,' solhr ', Model%solhr + solhr = mod(phour+idate(1),con_24) + + if ((debug) .and. (me == master)) then + print *,' sec ', sec + print *,' kdt ', kdt + print *,' nsswr ', nsswr + print *,' nslwr ', nslwr + print *,' nscyc ', nscyc + print *,' lsswr ', lsswr + print *,' lslwr ', lslwr + print *,' fhour ', fhour + print *,' phour ', phour + print *,' solhr ', solhr endif end subroutine GFS_time_vary_pre_run diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index c4312790f..3dc91952e 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -45,13 +45,212 @@ [ccpp-arg-table] name = GFS_time_vary_pre_run type = scheme -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[idat] + standard_name = date_and_time_at_model_initialization + long_name = initialization date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s dimensions = () - type = GFS_control_type - intent = inout + type = real + kind = kind_phys + intent = in + optional = F +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noahmp] + standard_name = flag_for_noahmp_land_surface_scheme + long_name = flag for NOAH MP land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[nsswr] + standard_name = number_of_timesteps_between_shortwave_radiation_calls + long_name = number of timesteps between shortwave radiation calls + units = + dimensions = () + type = integer + intent = in + optional = F +[nslwr] + standard_name = number_of_timesteps_between_longwave_radiation_calls + long_name = number of timesteps between longwave radiation calls + units = + dimensions = () + type = integer + intent = in + optional = F +[idate] + standard_name = date_and_time_at_model_initialization_reordered + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in + optional = F +[debug] + standard_name = flag_debug + long_name = control flag for debug + units = flag + dimensions = () + type = logical + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[nscyc] + standard_name = number_of_timesteps_between_surface_cycling_calls + long_name = number of timesteps between surface cycling calls + units = + dimensions = () + type = integer + intent = in + optional = F +[sec] + standard_name = seconds_elapsed_since_model_initialization + long_name = seconds elapsed since model initialization + units = s + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[phour] + standard_name = forecast_time_at_previous_timestep + long_name = forecast time at the previous timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[zhour] + standard_name = time_since_diagnostics_zeroed + long_name = time since diagnostics variables have been zeroed + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = out + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = out + optional = F +[ipt] + standard_name = index_for_diagnostic_printout + long_name = horizontal index for point used for diagnostic printout + units = + dimensions = () + type = integer + intent = out + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lsswr] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lslwr] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[solhr] + standard_name = forecast_hour_of_the_day + long_name = time in hours after 00z at the current timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = out optional = F [errmsg] standard_name = ccpp_error_message From 95b887c29503f25b8014048537dad0292fd4c8f0 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 20 Sep 2019 08:00:20 -0600 Subject: [PATCH 29/59] Remove TRANSITION mode --- CMakeLists.txt | 46 -------------------------------- physics/gfdl_cloud_microphys.F90 | 11 -------- physics/gfdl_fv_sat_adj.F90 | 22 --------------- 3 files changed, 79 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d34b491f8..443d7ea51 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -187,52 +187,6 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Add all of the above files to the list of schemes with special compiler flags list(APPEND SCHEMES_SFX_OPT ./physics/radiation_aerosols.f) - # Force consistent results of math calculations for MG microphysics; - # in Debug/Bitforbit mode; without this flag, the results of the - # intrinsic gamma function are different for the non-CCPP and CCPP - # version (on Theia with Intel 18). Note this is only required for - # the dynamic CCPP build, not for the static CCPP build. - if (TRANSITION) - # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I, -no-prec-div with -prec-div, and - # -no-prec-sqrt with -prec-sqrt for certain files for bit-for-bit reproducibility - # with non-CCPP builds. These may go in the future once the CCPP solution is fully accepted. - set(CMAKE_Fortran_FLAGS_LOPT2 ${CMAKE_Fortran_FLAGS_OPT}) - string(REPLACE "-no-prec-div" "-prec-div" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - string(REPLACE "-no-prec-sqrt" "-prec-sqrt" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - string(REPLACE "-axSSE4.2,AVX,CORE-AVX2" "-axSSE4.2,AVX,CORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 - ./physics/micro_mg3_0.F90 - ./physics/aer_cloud.F - ./physics/cldmacro.F - ./physics/gfdl_fv_sat_adj.F90 - ./physics/module_gfdl_cloud_microphys.F90 - ./physics/sflx.f - ./physics/satmedmfvdif.F - ./physics/cs_conv.F90 - ./physics/gcm_shoc.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT2}") - # Add all of the above files to the list of schemes with special compiler flags - list(APPEND SCHEMES_SFX_OPT ./physics/micro_mg2_0.F90 - ./physics/micro_mg3_0.F90 - ./physics/aer_cloud.F - ./physics/cldmacro.F - ./physics/module_gfdl_cloud_microphys.F90 - ./physics/sflx.f - ./physics/satmedmfvdif.F - ./physics/cs_conv.F90 - ./physics/gcm_shoc.F90 - ./physics/gfdl_fv_sat_adj.F90) - endif (TRANSITION) - # Remove files with special compiler flags from list of files with standard compiler flags list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX_OPT}) # Assign standard compiler flags to all remaining schemes and caps diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index 6d907e40a..fcaaa9b94 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -170,9 +170,6 @@ subroutine gfdl_cloud_microphys_run( & real(kind=kind_phys), dimension(:,:), allocatable :: den real(kind=kind_phys) :: onebg real(kind=kind_phys) :: tem -#ifdef TRANSITION - real(kind=kind_phys), volatile :: volatile_var1, volatile_var2 -#endif ! Initialize CCPP error handling variables errmsg = '' @@ -260,18 +257,10 @@ subroutine gfdl_cloud_microphys_run( & ! calculate fraction of frozen precipitation using unscaled ! values of rain0, ice0, snow0, graupel0 (for bit-for-bit) do i=1,im -#ifdef TRANSITION - volatile_var1 = rain0(i)+snow0(i)+ice0(i)+graupel0(i) - volatile_var2 = snow0(i)+ice0(i)+graupel0(i) - prcp0(i) = volatile_var1 * tem - if ( volatile_var1 * tem > rainmin ) then - sr(i) = volatile_var2 / volatile_var1 -#else prcp0(i) = (rain0(i)+snow0(i)+ice0(i)+graupel0(i)) * tem if ( prcp0(i) > rainmin ) then sr(i) = (snow0(i) + ice0(i) + graupel0(i)) & / (rain0(i) + snow0(i) + ice0(i) + graupel0(i)) -#endif else sr(i) = 0.0 endif diff --git a/physics/gfdl_fv_sat_adj.F90 b/physics/gfdl_fv_sat_adj.F90 index d535ebc91..14b3975f3 100644 --- a/physics/gfdl_fv_sat_adj.F90 +++ b/physics/gfdl_fv_sat_adj.F90 @@ -296,10 +296,6 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, kmp, km, kmdelz, js, je, ! Local variables real(kind=kind_dyn), dimension(is:ie,js:je) :: dpln -#ifdef TRANSITION - ! For bit-for-bit reproducibility - real(kind=kind_dyn), volatile :: volatile_var -#endif integer :: kdelz integer :: k, j, i @@ -317,9 +313,6 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, kmp, km, kmdelz, js, je, !$OMP ql,qv,te0,fast_mp_consv, & !$OMP hydrostatic,ng,zvir,pkz, & !$OMP akap,te0_2d,ngas,qvi) & -#ifdef TRANSITION -!$OMP private(volatile_var) & -#endif !$OMP private(k,j,i,kdelz,dpln) #endif @@ -351,28 +344,13 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, kmp, km, kmdelz, js, je, do j=js,je do i=is,ie #ifdef MOIST_CAPPA -#ifdef TRANSITION - volatile_var = log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) - pkz(i,j,k) = exp(cappa(i,j,k)*volatile_var) -#else pkz(i,j,k) = exp(cappa(i,j,k)*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#endif -#else -#ifdef TRANSITION -#ifdef MULTI_GASES - volatile_var = log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) - pkz(i,j,k) = exp(akap*(virqd(q(i,j,k,1:num_gas))/vicpqd(q(i,j,k,1:num_gas))*volatile_var) -#else - volatile_var = log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) - pkz(i,j,k) = exp(akap*volatile_var) -#endif #else #ifdef MULTI_GASES pkz(i,j,k) = exp(akap*(virqd(q(i,j,k,1:num_gas))/vicpqd(q(i,j,k,1:num_gas))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) #else pkz(i,j,k) = exp(akap*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) #endif -#endif #endif enddo enddo From 3db21442fbdd7ae61779e6768bae8466008bff28 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 20 Sep 2019 09:48:54 -0600 Subject: [PATCH 30/59] add calculation of snow cover in GFS_phys_time_vary.scm.F90 to match FV3 version; this is ifdefed out and may not be necessary for the SCM --- physics/GFS_phys_time_vary.scm.F90 | 35 ++++++++++++++++++++++++++--- physics/GFS_phys_time_vary.scm.meta | 8 +++++++ 2 files changed, 40 insertions(+), 3 deletions(-) diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index 6905b9277..d8ca39ba3 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -15,6 +15,11 @@ module GFS_phys_time_vary use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol +#if 0 + !--- variables needed for calculating 'sncovr' + use namelist_soilveg, only: salp_data, snupx +#endif + implicit none private @@ -220,7 +225,7 @@ end subroutine GFS_phys_time_vary_finalize !> \section arg_table_GFS_phys_time_vary_run Argument Table !! \htmlinclude GFS_phys_time_vary_run.html !! - subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, Diag, errmsg, errflg) + subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, Diag, first_time_step, errmsg, errflg) use mersenne_twister, only: random_setseed, random_number use machine, only: kind_phys @@ -238,6 +243,7 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, type(GFS_sfcprop_type), intent(inout) :: Sfcprop type(GFS_cldprop_type), intent(inout) :: Cldprop type(GFS_diag_type), intent(inout) :: Diag + logical, intent(in) :: first_time_step character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -245,8 +251,8 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys - integer :: i, j, k, iseed, iskip, ix, nb, kdt_rad - real(kind=kind_phys) :: sec_zero + integer :: i, j, k, iseed, iskip, ix, nb, kdt_rad, vegtyp + real(kind=kind_phys) :: sec_zero, rsnow real(kind=kind_phys) :: wrk(1) real(kind=kind_phys) :: rannie(Model%cny) real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) @@ -362,6 +368,29 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED endif endif + +#if 0 + !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) + if (first_time_step) then + if (nint(Sfcprop%sncovr(1)) == -9999) then + !--- compute sncovr from existing variables + !--- code taken directly from read_fix.f + do ix = 1, Model%blksz(nb) + Sfcprop%sncovr(ix) = 0.0 + if (Sfcprop%slmsk(ix) > 0.001) then + vegtyp = Sfcprop%vtype(ix) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*Sfcprop%weasd(ix)/snupx(vegtyp) + if (0.001*Sfcprop%weasd(ix) < snupx(vegtyp)) then + Sfcprop%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + Sfcprop%sncovr(ix) = 1.0 + endif + endif + enddo + endif + endif +#endif end subroutine GFS_phys_time_vary_run diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 4fc643d29..57a82ecb0 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -133,6 +133,14 @@ type = GFS_diag_type intent = inout optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 5d776f6fda3191dd726b200b7307cbc151ae3318 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 20 Sep 2019 19:58:53 -0600 Subject: [PATCH 31/59] physics/machine.*: add kind_LOGICAL, add metadata for kind_LOGICAL and kind_INTEGER --- physics/machine.F | 2 ++ physics/machine.meta | 12 ++++++++++++ 2 files changed, 14 insertions(+) diff --git a/physics/machine.F b/physics/machine.F index f50a950d7..ea6198c33 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -20,6 +20,7 @@ module machine &, kind_phys = 8 ,kind_taum=8 & &, kind_grid = 8 & &, kind_REAL = 8 &! used in cmp_comm + &, kind_LOGICAL = 4 & &, kind_INTEGER = 4 ! -,,- #else @@ -34,6 +35,7 @@ module machine &, kind_phys = 4 ,kind_taum=4 & &, kind_grid = 4 & &, kind_REAL = 4 &! used in cmp_comm + &, kind_LOGICAL = 4 & &, kind_INTEGER = 4 ! -,,- #endif diff --git a/physics/machine.meta b/physics/machine.meta index 43fc8770a..d93f50e09 100644 --- a/physics/machine.meta +++ b/physics/machine.meta @@ -19,3 +19,15 @@ units = none dimensions = () type = integer +[kind_LOGICAL] + standard_name = kind_LOGICAL + long_name = definition of kind_LOGICAL + units = none + dimensions = () + type = integer +[kind_INTEGER] + standard_name = kind_INTEGER + long_name = definition of kind_INTEGER + units = none + dimensions = () + type = integer From f7ca0878f2267a87c55fd8bfeba14bc598a4337e Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 20 Sep 2019 19:59:24 -0600 Subject: [PATCH 32/59] Replace internal kind definitions for MYJ SFC/PBL schemes with imports from machine.F --- physics/module_BL_MYJPBL.F90 | 16 ++++++++++------ physics/module_MYJPBL_wrapper.F90 | 20 ++++++++++---------- physics/module_MYJSFC_wrapper.F90 | 17 ++++++++++------- physics/module_SF_JSFC.F90 | 15 +++++++++------ 4 files changed, 39 insertions(+), 29 deletions(-) diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 index af7967ebf..b23e67cb5 100755 --- a/physics/module_BL_MYJPBL.F90 +++ b/physics/module_BL_MYJPBL.F90 @@ -15,6 +15,10 @@ MODULE MODULE_BL_MYJPBL ! ,G,P608,PI,PQ0,R_D,R_V,RHOWATER & ! ,STBOLT,CAPPA + USE machine, only: kfpt => kind_phys, & + kint => kind_INTEGER, & + klog => kind_LOGICAL + !----------------------------------------------------------------------- ! IMPLICIT NONE @@ -36,12 +40,12 @@ MODULE MODULE_BL_MYJPBL ! real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' ! integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision + ! integer,parameter:: & + ! klog=4 & ! logical variables + ! ,kint=4 & ! integer variables + ! !,kfpt=4 & ! floating point variables + ! ,kfpt=8 & ! floating point variables + ! ,kdbl=8 ! double precision REAL(kind=kfpt),PARAMETER :: A2=17.2693882,A3=273.15,A4=35.86,CP=1004.6 & ,ELIV=2.850e6,ELWV=2.501e6,R_V=461.6 & diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/module_MYJPBL_wrapper.F90 index aad072e42..e28cf5e69 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/module_MYJPBL_wrapper.F90 @@ -3,6 +3,9 @@ MODULE myjpbl_wrapper + USE machine, only: kfpt => kind_phys, & + kind_phys + contains subroutine myjpbl_wrapper_init () @@ -13,11 +16,9 @@ end subroutine myjpbl_wrapper_finalize !! !> \brief This scheme (1) performs pre-myjpbl work, (2) runs the myjpbl, and (3) performs post-myjpbl work -#if 0 !! \section arg_table_myjpbl_wrapper_run Argument Table !! \htmlinclude myjpbl_wrapper_run.html !! -#endif !###=================================================================== SUBROUTINE myjpbl_wrapper_run( & & restart,do_myjsfc, & @@ -42,19 +43,18 @@ SUBROUTINE myjpbl_wrapper_run( & & me, lprnt, errmsg, errflg ) ! - use machine, only : kind_phys use MODULE_BL_MYJPBL, only: MYJPBL_INIT,MYJPBL !------------------------------------------------------------------- implicit none - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision +! integer,parameter:: & +! klog=4 & ! logical variables +! ,kint=4 & ! integer variables +! !,kfpt=4 & ! floating point variables +! ,kfpt=8 & ! floating point variables +! ,kdbl=8 ! double precision !------------------------------------------------------------------- ! --- constant parameters: @@ -121,7 +121,7 @@ SUBROUTINE myjpbl_wrapper_run( & integer :: i_min, i_max, k_min, k_max logical :: lprnt1,lprnt2 - integer (kind=kint) :: ict, ide, lm, me1 + integer :: ict, ide, lm, me1 real(kind=kfpt) :: dt_myj, tem, tem1, tem2, ptem integer,dimension(im) :: kpbl_myj real(kind=kfpt),dimension(1:levs-1):: epsl diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/module_MYJSFC_wrapper.F90 index 917e22599..1406a99be 100644 --- a/physics/module_MYJSFC_wrapper.F90 +++ b/physics/module_MYJSFC_wrapper.F90 @@ -3,6 +3,9 @@ MODULE myjsfc_wrapper + USE machine, only: kfpt => kind_phys, & + kind_phys + contains subroutine myjsfc_wrapper_init () @@ -47,19 +50,19 @@ SUBROUTINE myjsfc_wrapper_run( & & wind, con_cp, con_g, con_rd, & & me, lprnt, errmsg, errflg ) ! intent(inout) ! - use machine, only : kind_phys + use MODULE_SF_JSFC, only: JSFC_INIT,JSFC !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision +! integer,parameter:: & +! klog=4 & ! logical variables +! ,kint=4 & ! integer variables +! !,kfpt=4 & ! floating point variables +! ,kfpt=8 & ! floating point variables +! ,kdbl=8 ! double precision ! ! --- constant parameters: ! real(kind=kind_phys), parameter :: karman = 0.4 diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 76a9d1fa7..8d67a81cd 100755 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -15,6 +15,9 @@ MODULE MODULE_SF_JSFC ! !----------------------------------------------------------------------- ! + + USE machine, only: kfpt => kind_phys + IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -35,12 +38,12 @@ MODULE MODULE_SF_JSFC ! real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' ! integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) ! - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision + ! integer,parameter:: & + ! klog=4 & ! logical variables + ! ,kint=4 & ! integer variables + ! !,kfpt=4 & ! floating point variables + ! ,kfpt=8 & ! floating point variables + ! ,kdbl=8 ! double precision ! PRIVATE ! From 92cc1ef09df83c38b01d4f97936e2ad91ea13398 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Mon, 23 Sep 2019 13:36:41 +0000 Subject: [PATCH 33/59] Adding gsd drag suite to ccpp. --- physics/drag_suite.F90 | 1557 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1557 insertions(+) create mode 100644 physics/drag_suite.F90 diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 new file mode 100644 index 000000000..a8ed0fc1b --- /dev/null +++ b/physics/drag_suite.F90 @@ -0,0 +1,1557 @@ +!> \File drag_suite.F90 +!! This file is the parameterization of orographic gravity wave +!! drag, mountain blocking, and form drag. + +!> This module contains the CCPP-compliant orographic gravity wave +!! drag pre interstitial codes. + module drag_suite_pre + + contains + +!> \section arg_table_drag_suite_pre_init Argument Table +!! + subroutine drag_suite_pre_init() + end subroutine drag_suite_pre_init + +!! \section arg_table_drag_suite_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------------------------------------|------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | +!! | nmtvr | number_of_statistical_measures_of_subgrid_orography | number of statistical measures of subgrid orography | count | 0 | integer | | in | F | +!! | mntvar | statistical_measures_of_subgrid_orography | array of statistical measures of subgrid orography | various | 2 | real | kind_phys | in | F | +!! | hprime | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | out | F | +!! | oc | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | out | F | +!! | clx | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | out | F | +!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with_respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | out | F | +!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine drag_suite_pre_run( & + & im, nmtvr, mntvar, & + & hprime, oc, oa4, clx, theta, & + & sigma, gamma, elvmax, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, nmtvr + real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) + + real(kind=kind_phys), intent(out) :: & + & hprime(im), oc(im), oa4(im,4), clx(im,4), & + & theta(im), sigma(im), gamma(im), elvmax(im) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (nmtvr == 14) then ! current operational - as of 2014 + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = mntvar(:,7) + clx(:,2) = mntvar(:,8) + clx(:,3) = mntvar(:,9) + clx(:,4) = mntvar(:,10) + theta(:) = mntvar(:,11) + gamma(:) = mntvar(:,12) + sigma(:) = mntvar(:,13) + elvmax(:) = mntvar(:,14) + elseif (nmtvr == 10) then + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = mntvar(:,7) + clx(:,2) = mntvar(:,8) + clx(:,3) = mntvar(:,9) + clx(:,4) = mntvar(:,10) + elseif (nmtvr == 6) then + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = 0.0 + clx(:,2) = 0.0 + clx(:,3) = 0.0 + clx(:,4) = 0.0 + else + hprime = 0 + oc = 0 + oa4 = 0 + clx = 0 + theta = 0 + gamma = 0 + sigma = 0 + elvmax = 0 + endif ! end if_nmtvr + + end subroutine drag_suite_pre_run +!> @} + +! \ingroup GFS_ogwd +! \brief Brief description of the subroutine +! +!> \section arg_table_drag_suite_pre_finalize Argument Table +!! + subroutine drag_suite_pre_finalize() + end subroutine drag_suite_pre_finalize + + end module drag_suite_pre + +!> This module contains the CCPP-compliant orographic gravity wave dray scheme. + module drag_suite + + contains + +!> \section arg_table_drag_suite_init Argument Table +!! + subroutine drag_suite_init() + end subroutine drag_suite_init + +! \defgroup GFS_ogwd GFS Orographic Gravity Wave Drag +!> \defgroup gfs_drag_suite GFS drag_suite Main +!! \brief This subroutine includes orographic gravity wave drag, mountain +!! blocking, and form drag. +!! +!> The time tendencies of zonal and meridional wind are altered to +!! include the effect of mountain induced gravity wave drag from +!! subgrid scale orography including convective breaking, shear +!! breaking and the presence of critical levels. +!! +!! \section arg_table_drag_suite_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------------------------------------------|----------------------------------------------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | +!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | +!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | +!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | inout | F | +!! | u1 | x_wind | zonal wind | m s-1 | 2 | real | kind_phys | in | F | +!! | v1 | y_wind | meridional wind | m s-1 | 2 | real | kind_phys | in | F | +!! | t1 | air_temperature | mid-layer temperature | K | 2 | real | kind_phys | in | F | +!! | q1 | water_vapor_specific_humidity | mid-layer specific humidity of water vapor | kg kg-1 | 2 | real | kind_phys | in | F | +!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | vertical index at top atmospheric boundary layer | index | 1 | integer | | in | F | +!! | prsi | air_pressure_at_interface | interface pressure | Pa | 2 | real | kind_phys | in | F | +!! | del | air_pressure_difference_between_midlayers | difference between mid-layer pressures | Pa | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mid-layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prslk | dimensionless_exner_function_at_model_layers | mid-layer Exner function | none | 2 | real | kind_phys | in | F | +!! | phii | geopotential_at_interface | interface geopotential | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | mid-layer geopotential | m2 s-2 | 2 | real | kind_phys | in | F | +!! | deltim | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | +!! | var | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | in | F | +!! | oc1 | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | in | F | +!! | ol4 | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | in | F | +!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | in | F | +!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | inout | F | +!! | dtaux2d_ls | x_momentum_tendency_from_large_scale_gwd | x momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_ls | y_momentum_tendency_from_large_scale_gwd | y momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtaux2d_bl | x_momentum_tendency_from_blocking_drag | x momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_bl | y_momentum_tendency_from_blocking_drag | y momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dtaux2d_ss | x_momentum_tendency_from_small_scale_gwd | x momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_ss | y_momentum_tendency_from_small_scale_gwd | y momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtaux2d_fd | x_momentum_tendency_from_form_drag | x momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_fd | y_momentum_tendency_from_form_drag | y momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dusfc | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | +!! | dusfc_ls | integrated_x_momentum_flux_from_large_scale_gwd | integrated x momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_ls | integrated_y_momentum_flux_from_large_scale_gwd | integrated y momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dusfc_bl | integrated_x_momentum_flux_from_blocking_drag | integrated x momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_bl | integrated_y_momentum_flux_from_blocking_drag | integrated y momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | +!! | dusfc_ss | integrated_x_momentum_flux_from_small_scale_gwd | integrated x momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_ss | integrated_y_momentum_flux_from_small_scale_gwd | integrated y momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dusfc_fd | integrated_x_momentum_flux_from_form_drag | integrated x momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_fd | integrated_y_momentum_flux_from_form_drag | integrated y momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | +!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | +!! | br1 | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | fv | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | +!! | imx | number_of_equatorial_longitude_points | number of longitude points along the equator | count | 0 | integer | | in | F | +!! | cdmbgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag | none | 1 | real | kind_phys | in | F | +!! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | +!! | lprnt | flag_print | flag for debugging printouts | flag | 0 | logical | | in | F | +!! | ipr | horizontal_index_of_printed_column | horizontal index of column used in debugging printouts | index | 0 | integer | | in | F | +!! | rdxzb | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | out | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | gwd_opt | gwd_opt | flag to choose gwd scheme | flag | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!> \section gen_drag_suite GFS Orographic GWD Scheme General Algorithm +!! -# Calculate subgrid mountain blocking +!! -# Calculate orographic wave drag +!! +!! The NWP model gravity wave drag (GWD) scheme in the GFS has two +!! main components: how the surface stress is computed, and then how +!! that stress is distributed over a vertical column where it may +!! interact with the models momentum. Each of these depends on the +!! large scale environmental atmospheric state and assumptions about +!! the sub-grid scale processes. In Alpert GWD (1987) based on linear, +!! two-dimensional non-rotating, stably stratified flow over a mountain ridge, +!! sub-grid scale gravity wave motions are assumed which propagate away +!! from the mountain. Described in Alpert (1987), the flux measured over +!! a "low level" vertically averaged layer, in the atmosphere defines a base +!! level flux. "Low level" was taken to be the first 1/3 of the troposphere +!! in the 1987 implementation. This choice was meant to encompass a thick +!! low layer for vertical averages of the environmental (large scale) flow +!! quantities. The vertical momentum flux or gravity wave stress in a +!! grid box due to a single mountain is given as in Pierrehumbert, (1987) (PH): +!! +!! \f$ \tau = \frac {\rho \: U^{3}\: G(F_{r})} {\Delta X \; N } \f$ +!! +!! emetic \f$ \Delta X \f$ is a grid increment, N is the Brunt Viasala frequency +!! +!! +!! \f$ N(\sigma) = \frac{-g \: \sigma \: +!! \frac{\partial\Theta}{\partial\sigma}}{\Theta \:R \:T} \f$ +!! +!! The environmental variables are calculated from a mass weighted vertical +!! average over a base layer. G(Fr) is a monotonically increasing +!! function of Froude number, +!! +!! \f$ F_{r} = \frac{N h^{'}}{U} \f$ +!! +!! where U is the wind speed calculated as a mass weighted vertical average in +!! the base layer, and h', is the vertical displacement caused by the orography +!! variance. An effective mountain length for the gravity wave processes, +!! +!! \f$ l^{*} = \frac{\Delta X}{m} \f$ +!! +!! where m is the number of mountains in a grid box, can then +!! be defined to obtain the form of the base level stress +!! +!! +!! \f$ \tau = \frac {\rho \: U^{3} \: G(F_{r})} {N \;l^{*}} \f$ +!! +!! giving the stress induced from the surface in a model grid box. +!! PH gives the form for the function G(Fr) as +!! +!! +!! \f$ G(F_{r}) = \bar{G}\frac{F^{2}_{r}}{F^{2}_{r}\: + \:a^{2}} \f$ +!! +!! Where \f$ \bar{G} \f$ is an order unity non-dimensional saturation +!! flux set to 1 and 'a' is a function of the mountain aspect ratio also +!!set to 1 in the 1987 implementation of the GFS GWD. Typical values of +!! U=10m/s, N=0.01 1/s, l*=100km, and a=1, gives a flux of 1 Pascal and +!! if this flux is made to go to zero linearly with height then the +!! decelerations would be about 10/m/s/day which is consistent with +!! observations in PH. +!! +!! +!! In Kim, Moorthi, Alpert's (1998, 2001) GWD currently in GFS operations, +!! the GWD scheme has the same physical basis as in Alpert (1987) with the addition +!! of enhancement factors for the amplitude, G, and mountain shape details +!! in G(Fr) to account for effects from the mountain blocking. A factor, +!! E m’, is an enhancement factor on the stress in the Alpert '87 scheme. +!! The E ranges from no enhancement to an upper limit of 3, E=E(OA)[1-3], +!! and is a function of OA, the Orographic Asymmetry defined in KA (1995) as +!! +!! Orographic Asymmetry (OA) = \f$ \frac{ \bar{x} \; - \; +!! \sum\limits_{j=1}^{N_{b}} x_{j} \; n_{j} }{\sigma_{x}} \f$ +!! +!! where Nb is the total number of bottom blocks in the mountain barrier, +!! \f$ \sigma_{x} \f$ is the standard deviation of the horizontal distance defined by +!! +!! \f$ \sigma_{x} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{b}} +!! \; (x_{j} \; - \; \bar{x} )^2}{N_{x}} } \f$ +!! +!! +!! where Nx is the number of grid intervals for the large scale domain being +!! considered. So the term, E(OA)m’/ \f$ \Delta X \f$ in Kim's scheme represents +!! a multiplier on G shown in Alpert's eq (1), where m’ is the number of mountains +!! in a sub-grid scale box. Kim increased the complexity of m’ making it a +!! function of the fractional area of the sub-grid mountain and the asymmetry +!! and convexity statistics which are found from running a gravity wave +!! model for a large number of cases: +!! +!! \f$ m^{'} = C_{m} \Delta X \left[ \frac{1 \; + \; +!! \sum\limits_{x} L_{h} }{\Delta X} \right]^{OA+1} \f$ +!! +!! Where, according to Kim, \f$ \sum \frac{L_{h}}{\Delta X} \f$ is +!! the fractional area covered by the subgrid-scale orography higher than +!! a critical height \f$ h_{c} = Fr_{c} U_{0}/N_{0} \f$ , over the +!! "low level" vertically averaged layer, for a grid box with the interval +!! \f$ \Delta X \f$. Each \f$ L_{n}\f$ is the width of a segment of +!! orography intersection at the critical height: +!! +!! \f$ Fr_{0} = \frac{N_{0} \; h^{'}}{U_{0}} \f$ +!! +!! \f$ G^{'}(OC,Fr_{0}) = \frac{Fr_{0}^{2}}{Fr_{0}^{2} \; + \; a^{2}} \f$ +!! +!! \f$ a^{2} = \frac{C_{G}}{OC} \f$ +!! +!! \f$ E(OA, Fr_{0}) = (OA \; + \; 2)^{\delta} \f$ and \f$ \delta +!! \; = \; \frac{C_{E} \; Fr_{0}}{Fr_{c}} \f$ where \f$ Fr_{c} \f$ +!! is as in Alpert. +!! +!! +!! This represents a closed scheme, somewhat empirical adjustments +!! to the original scheme to calculate the surface stress. +!! +!! Momentum is deposited by the sub-grid scale gravity waves break due +!! to the presence of convective mixing assumed to occur when the +!! minimum Richardson number: +!! +!! Orographic Convexity (OC) = \f$ \frac{ \sum\limits_{j=1}^{N_{x}} +!! \; (h_{j} \; - \; \bar{h})^4 }{N_{x} \;\sigma_{h}^4} \f$ , +!! and where \f$ \sigma_{h} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{x}} +!! \; (h_{j} \; - \; \bar{h} )^2}{N_{x}} } \f$ +!! +!! This represents a closed scheme, somewhat empirical adjustments +!! to the original scheme to calculate the surface stress. +!! +!! Momentum is deposited by the sub-grid scale gravity waves break due +!! to the presence of convective mixing assumed to occur when +!! the minimum Richardson number: +!! +!! \f$ Ri_{m} = \frac{Ri(1 \; - \; Fr)}{(1 \; + \; \sqrt{Ri}Fr)^2} \f$ +!! +!! Is less than 1/4 Or if critical layers are encountered in a layer +!! the the momentum flux will vanish. The critical layer is defined +!! when the base layer wind becomes perpendicular to the environmental +!! wind. Otherwise, wave breaking occurs at a level where the amplification +!! of the wave causes the local Froude number or similarly a truncated +!! (first term of the) Scorer parameter, to be reduced below a critical +!! value by the saturation hypothesis (Lindzen,). This is done through +!! eq 1 which can be written as +!! +!! \f$ \tau = \rho U N k h^{'2} \f$ +!! +!! For small Froude number this is discretized in the vertical so at each +!! level the stress is reduced by ratio of the Froude or truncated Scorer +!! parameter, \f$ \frac{U^{2}}{N^{2}} = \frac{N \tau_{l-1}}{\rho U^{3} k} \f$ , +!! where the stress is from the layer below beginning with that found near +!! the surface. The respective change in momentum is applied in +!! that layer building up from below. +!! +!! An amplitude factor is part of the calibration of this scheme which is +!! a function of the model resolution and the vertical diffusion. This +!! is because the vertical diffusion and the GWD account encompass +!! similar physical processes. Thus, one needs to run the model over +!! and over for various amplitude factors for GWD and vertical diffusion. +!! +!! In addition, there is also mountain blocking from lift and frictional +!! forces. Improved integration between how the GWD is calculated and +!! the mountain blocking of wind flow around sub-grid scale orography +!! is underway at NCEP. The GFS already has convectively forced GWD +!! an independent process. The next step is to test +!! +!> \section det_drag_suite GFS Orographic GWD Scheme Detailed Algorithm +!> @{ +! subroutine drag_suite_run( & +! & IM,IX,KM,A,B,C,U1,V1,T1,Q1,KPBL, & +! & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DELTIM,KDT, & +! & HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX, & +! & DUSFC,DVSFC,G, CP, RD, RV, IMX, & +! & nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, errmsg, errflg) +! + subroutine drag_suite_run( & + & IM,IX,KM,dvdt,dudt,dtdt,U1,V1,T1,Q1,KPBL, & + & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM,KDT, & + & VAR,oc1,oa4,ol4, & +! & varss,oc1ss,oa4ss,ol4ss, & + & THETA,SIGMA,GAMMA,ELVMAX, & + & dtaux2d_ls,dtauy2d_ls,dtaux2d_bl,dtauy2d_bl, & + & dtaux2d_ss,dtauy2d_ss,dtaux2d_fd,dtauy2d_fd, & + & dusfc,dvsfc, & + & dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & + & slmsk,br1,hpbl, & + & g, cp, rd, rv, fv, pi, imx, cdmbgwd, & + & me, lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) + +! ******************************************************************** +! -----> I M P L E M E N T A T I O N V E R S I O N <---------- +! +! ----- This code ----- +!begin WRF code + +! this code handles the time tendencies of u v due to the effect of mountain +! induced gravity wave drag from sub-grid scale orography. this routine +! not only treats the traditional upper-level wave breaking due to mountain +! variance (alpert 1988), but also the enhanced lower-tropospheric wave +! breaking due to mountain convexity and asymmetry (kim and arakawa 1995). +! thus, in addition to the terrain height data in a model grid box, +! additional 10-2d topographic statistics files are needed, including +! orographic standard deviation (var), convexity (oc1), asymmetry (oa4) +! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography +! hong (1999). the current scheme was implmented as in hong et al.(2008) +! +! Originally coded by song-you hong and young-joon kim and implemented by song-you hong +! +! program history log: +! 2014-10-01 Hyun-Joo Choi (from KIAPS) flow-blocking drag of kim and doyle +! with blocked height by dividing streamline theory +! 2017-04-06 Joseph Olson (from Gert-Jan Steeneveld) added small-scale +! orographic grabity wave drag: +! 2017-09-15 Joseph Olson, with some bug fixes from Michael Toy: added the +! topographic form drag of Beljaars et al. (2004, QJRMS) +! Activation of each component is done by specifying the integer-parameters +! (defined below) to 0: inactive or 1: active +! gwd_opt_ls = 0 or 1: large-scale +! gwd_opt_bl = 0 or 1: blocking drag +! gwd_opt_ss = 0 or 1: small-scale gravity wave drag +! gwd_opt_fd = 0 or 1: topographic form drag +! 2017-09-25 Michael Toy (from NCEP GFS model) added dissipation heating +! gsd_diss_ht_opt = 0: dissipation heating off +! gsd_diss_ht_opt = 1: dissipation heating on +! +! References: +! Hong et al. (2008), wea. and forecasting +! Kim and Doyle (2005), Q. J. R. Meteor. Soc. +! Kim and Arakawa (1995), j. atmos. sci. +! Alpert et al. (1988), NWP conference. +! Hong (1999), NCEP office note 424. +! Steeneveld et al (2008), JAMC +! Tsiringakis et al. (2017), Q. J. R. Meteor. Soc. +! Beljaars et al. (2004), Q. J. R. Meteor. Soc. +! +! notice : comparible or lower resolution orography files than model resolution +! are desirable in preprocess (wps) to prevent weakening of the drag +!------------------------------------------------------------------------------- +! +! input +! dudt (im,km) non-lin tendency for u wind component +! dvdt (im,km) non-lin tendency for v wind component +! u1(im,km) zonal wind / sqrt(rcl) m/sec at t0-dt +! v1(im,km) meridional wind / sqrt(rcl) m/sec at t0-dt +! t1(im,km) temperature deg k at t0-dt +! q1(im,km) specific humidity at t0-dt +! deltim time step secs +! del(km) positive increment of pressure across layer (pa) +! KPBL(IM) is the index of the top layer of the PBL +! ipr & lprnt for diagnostics +! +! output +! dudt, dvdt wind tendency due to gwdo +! dTdt +! +!------------------------------------------------------------------------------- + +!end wrf code +!----------------------------------------------------------------------C +! USE +! ROUTINE IS CALLED FROM CCPP (AFTER CALLING PBL SCHEMES) +! +! PURPOSE +! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- +! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V +! ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED +! GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING +! CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF +! CRITICAL LEVELS +! +! +! ******************************************************************** + USE MACHINE , ONLY : kind_phys + implicit none + + ! Interface variables + integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, gwd_opt + logical, intent(in) :: lprnt + integer, intent(in) :: KPBL(im) + real(kind=kind_phys):: deltim, G, CP, RD, RV, cdmbgwd(2) + + integer :: kpblmax + integer, parameter :: ims=1, kms=1, its=1, kts=1 + real :: fv, pi, rcl, cdmb + real, parameter :: g_inv = 1./9.81 !1./g + + real(kind=kind_phys), intent(out) :: & + & dudt(im,km),dvdt(im,km), & + & dtdt(im,km), rdxzb(im) + real(kind=kind_phys), intent(in) :: & + & u1(im,km),v1(im,km), & + & t1(im,km),q1(im,km), & + & PHII(im,km+1),prsl(im,km), & + & prslk(im,km),PHIL(im,km) + real(kind=kind_phys), intent(in) :: prsi(im,km+1), & + & del(im,km) + real(kind=kind_phys), intent(in) :: var(im),oc1(im), & + & oa4(im,4),ol4(im,4), & + & dx(im) + !real(kind=kind_phys), intent(in) :: varss(im),oc1ss(im), & + real :: varss(im),oc1ss(im), & + & oa4ss(im,4),ol4ss(im,4) + real(kind=kind_phys), intent(in) :: THETA(im),SIGMA(im), & + & GAMMA(im),ELVMAX(im) + +! added for small-scale orographic wave drag + real, dimension(im,km) :: utendwave,vtendwave,thx,thvx + real(kind=kind_phys), intent(in) :: br1(im), & + & hpbl(im), & + & slmsk(im) + real, dimension(im) :: govrth,xland + real, dimension(im,km) :: dz2 + real :: tauwavex0,tauwavey0, & + & XNBV,density,tvcon,hpbl2 + integer :: kpbl2,kvar + real, dimension(im,km+1) :: zq ! = PHII/g + real, dimension(im,km) :: zl ! = PHIL/g + +!SPP + real, dimension(im) :: rstoch + +!Output: + real(kind=kind_phys), intent(out) :: & + & dusfc(im), dvsfc(im) +!Output (optional): + real(kind=kind_phys), intent(out) :: & + & dusfc_ls(:),dvsfc_ls(:), & + & dusfc_bl(:),dvsfc_bl(:), & + & dusfc_ss(:),dvsfc_ss(:), & + & dusfc_fd(:),dvsfc_fd(:) + real(kind=kind_phys), intent(out) :: & + & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & + & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & + & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & + & dtaux2d_fd(:,:),dtauy2d_fd(:,:) + +!Misc arrays + real, dimension(im,km) :: dtaux2d, dtauy2d + +!------------------------------------------------------------------------- +! Flags to regulate the activation of specific components of drag suite: +! Each component is tapered off automatically as a function of dx, so best to +! keep them activated (=1). + integer, parameter :: & + gwd_opt_ls = 1, & ! large-scale gravity wave drag + gwd_opt_bl = 1, & ! blocking drag + gwd_opt_ss = 1, & ! small-scale gravity wave drag (Steeneveld et al. 2008) + gwd_opt_fd = 1, & ! form drag (Beljaars et al. 2004, QJRMS) + gsd_diss_ht_opt = 0 + +! Parameters for bounding the scale-adaptive variability: +! Small-scale GWD + turbulent form drag + real, parameter :: dxmin_ss = 1000., & + & dxmax_ss = 12000. ! min,max range of tapering (m) +! Large-scale GWD + blocking + real, parameter :: dxmin_ls = 3000., & + & dxmax_ls = 13000. ! min,max range of tapering (m) + real :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) +! +! Variables for limiting topographic standard deviation (var) + real, parameter :: varmax_ss = 50., & + varmax_fd = 150., & + beta_ss = 0.1, & + beta_fd = 0.2 + real :: var_temp + +! added Beljaars orographic form drag + real, dimension(im,km) :: utendform,vtendform + real :: a1,a2,wsp + real :: H_efold + +! critical richardson number for wave breaking : ! larger drag with larger value + real,parameter :: ric = 0.25 + real,parameter :: dw2min = 1. + real,parameter :: rimin = -100. + real,parameter :: bnv2min = 1.0e-5 + real,parameter :: efmin = 0.0 + real,parameter :: efmax = 10.0 + real,parameter :: xl = 4.0e4 + real,parameter :: critac = 1.0e-5 + real,parameter :: gmax = 1. + real,parameter :: veleps = 1.0 + real,parameter :: factop = 0.5 + real,parameter :: frc = 1.0 + real,parameter :: ce = 0.8 + real,parameter :: cg = 0.5 + integer,parameter :: kpblmin = 2 + +! +! local variables +! + integer :: i,j,k,lcap,lcapp1,nwd,idir, & + klcap,kp1,ikount,kk +! + real :: rcs,rclcs,csg,fdir,cleff,cleff_ss,cs, & + rcsks,wdir,ti,rdz,temp,tem2,dw2,shr2, & + bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & + rim,temc,tem1,efact,temv,dtaux,dtauy, & + dtauxb,dtauyb,eng0,eng1 +! + logical :: ldrag(im),icrilv(im), & + flag(im),kloop1(im) +! + real :: taub(im),taup(im,km+1), & + xn(im),yn(im), & + ubar(im),vbar(im), & + fr(im),ulow(im), & + rulow(im),bnv(im), & + oa(im),ol(im), & + oass(im),olss(im), & + roll(im),dtfac(im), & + brvf(im),xlinv(im), & + delks(im),delks1(im), & + bnv2(im,km),usqj(im,km), & + taud_ls(im,km),taud_bl(im,km), & + ro(im,km), & + vtk(im,km),vtj(im,km), & + zlowtop(im),velco(im,km-1), & + coefm(im),coefm_ss(im) +! + integer :: kbl(im),klowtop(im) + logical :: iope + integer,parameter :: mdir=8 + integer :: nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ +! +! variables for flow-blocking drag +! + real,parameter :: frmax = 10. + real,parameter :: olmin = 1.0e-5 + real,parameter :: odmin = 0.1 + real,parameter :: odmax = 10. + real,parameter :: erad = 6371.315e+3 + integer :: komax(im) + integer :: kblk + real :: cd + real :: zblk,tautem + real :: pe,ke + real :: delx,dely,dxy4(4),dxy4p(4) + real :: dxy(im),dxyp(im) + real :: ol4p(4),olp(im),od(im) + real :: taufb(im,km+1) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +print*,"Running drag suite" +!-------------------------------------------------------------------- +! SCALE-ADPTIVE PARAMETER FROM GFS GWD SCHEME +!-------------------------------------------------------------------- +! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) +! non-dim sub grid mtn drag Amp (*j*) +! cdmb = 1.0/float(IMX/192) +! cdmb = 192.0/float(IMX) + cdmb = 4.0 * 192.0/float(IMX) + if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + +!>-# Orographic Gravity Wave Drag Section + kpblmax = km / 2 ! maximum pbl height : # of vertical levels / 2 +! +! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 +! + if (imx > 0) then +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192)/float(IMX/192) +! cleff = 1.0E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + cleff = 0.5E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! hmhj for ndsl +! jw cleff = 0.1E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + endif + if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) +!-------------------------------------------------------------------- +! END SCALE-ADPTIVE PARAMETER SECTION +!-------------------------------------------------------------------- +! +!---- constants +! + rcl = 1. + rcs = sqrt(rcl) + cs = 1. / sqrt(rcl) + csg = cs * g + lcap = km + lcapp1 = lcap + 1 + fdir = mdir / (2.0*pi) + + do i=1,im + if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 + xland(i)=1.0 !but land/water = (1/2) in this module + else + xland(i)=2.0 + endif + RDXZB(i) = 0.0 + enddo + +!temporary use of large-scale data: + do i=1,im + varss(i)=var(i) + oc1ss(i)=oc1(i) + do j=1,4 + oa4ss(i,j)=oa4(i,j) + ol4ss(i,j)=ol4(i,j) + enddo + enddo +! +!--- calculate scale-aware tapering factors +!NOTE: if dx(1) is not representative of most/all dx, this needs to change... +if ( dx(1) .ge. dxmax_ls ) then + ls_taper = 1. +else + if ( dx(1) .le. dxmin_ls) then + ls_taper = 0. + else + ls_taper = 0.5 * ( SIN(pi*(dx(1)-0.5*(dxmax_ls+dxmin_ls))/ & + (dxmax_ls-dxmin_ls)) + 1. ) + end if +end if +print*,"in Drag Suite, dx(1:2):",dx(1),dx(2) +if ( dx(1) .ge. dxmax_ss ) then + ss_taper = 1. +else + if ( dx(1) .le. dxmin_ss) then + ss_taper = 0. + else + ss_taper = dxmax_ss * (1. - dxmin_ss/dx(1))/(dxmax_ss-dxmin_ss) + end if +end if +print*,"in Drag Suite, ss_taper:",ss_taper + +!--- calculate length of grid for flow-blocking drag +! + delx = dx(1) + dely = dx(1) + dxy4(1) = delx + dxy4(2) = dely + dxy4(3) = sqrt(delx*delx + dely*dely) + dxy4(4) = dxy4(3) + dxy4p(1) = dxy4(2) + dxy4p(2) = dxy4(1) + dxy4p(3) = dxy4(4) + dxy4p(4) = dxy4(3) +! +!-----initialize arrays +! + dtaux = 0.0 + dtauy = 0.0 + do i = its,im + klowtop(i) = 0 + kbl(i) = 0 + enddo +! + do i = its,im + xn(i) = 0.0 + yn(i) = 0.0 + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + taub (i) = 0.0 + oa(i) = 0.0 + ol(i) = 0.0 + oass(i) = 0.0 + olss(i) = 0.0 + ulow (i) = 0.0 + dtfac(i) = 1.0 + ldrag(i) = .false. + icrilv(i) = .false. + flag(i) = .true. + enddo + + do k = kts,km + do i = its,im + usqj(i,k) = 0.0 + bnv2(i,k) = 0.0 + vtj(i,k) = 0.0 + vtk(i,k) = 0.0 + taup(i,k) = 0.0 + taud_ls(i,k) = 0.0 + taud_bl(i,k) = 0.0 + dtaux2d(i,k) = 0.0 + dtauy2d(i,k) = 0.0 + enddo + enddo +! + if (gwd_opt == 33) then + do i = its,im + dusfc_ls(i) = 0.0 + dvsfc_ls(i) = 0.0 + dusfc_bl(i) = 0.0 + dvsfc_bl(i) = 0.0 + dusfc_ss(i) = 0.0 + dvsfc_ss(i) = 0.0 + dusfc_fd(i) = 0.0 + dvsfc_fd(i) = 0.0 + enddo + do k = kts,km + do i = its,im + dtaux2d_ls(i,k)= 0.0 + dtauy2d_ls(i,k)= 0.0 + dtaux2d_bl(i,k)= 0.0 + dtauy2d_bl(i,k)= 0.0 + dtaux2d_ss(i,k)= 0.0 + dtauy2d_ss(i,k)= 0.0 + dtaux2d_fd(i,k)= 0.0 + dtauy2d_fd(i,k)= 0.0 + enddo + enddo + endif + + do i = its,im + taup(i,km+1) = 0.0 + xlinv(i) = 1.0/xl + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + enddo +! +! initialize array for flow-blocking drag +! + taufb(1:im,1:km+1) = 0.0 + komax(1:im) = 0 +! + do k = kts,km + do i = its,im + vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k)) + vtk(i,k) = vtj(i,k) / prslk(i,k) + ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3 + enddo + enddo +! +! determine reference level: maximum of 2*var and pbl heights +! + do i = its,im + zlowtop(i) = 2. * var(i) + enddo +! + do i = its,im + kloop1(i) = .true. + enddo +! + do k = kts+1,km + do i = its,im + if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then + klowtop(i) = k+1 + kloop1(i) = .false. + endif + enddo + enddo +! + do i = its,im + kbl(i) = max(kpbl(i), klowtop(i)) + kbl(i) = max(min(kbl(i),kpblmax),kpblmin) + enddo +! +! determine the level of maximum orographic height +! + ! komax(:) = kbl(:) + komax(:) = klowtop(:) - 1 ! modification by NOAA/GSD March 2018 +! + do i = its,im + delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) + delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) + enddo +! +! compute low level averages within pbl +! + do k = kts,kpblmax + do i = its,im + if (k.lt.kbl(i)) then + rcsks = rcs * del(i,k) * delks(i) + rdelks = del(i,k) * delks(i) + ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean + vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean + roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean + endif + enddo + enddo +! +! figure out low-level horizontal wind direction +! +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! + do i = its,im + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) + ol(i) = ol4(i,mod(nwd-1,4)+1) + ! Repeat for small-scale gwd + oass(i) = (1-2*int( (nwd-1)/4 )) * oa4ss(i,mod(nwd-1,4)+1) + olss(i) = ol4ss(i,mod(nwd-1,4)+1) + +! +!----- compute orographic width along (ol) and perpendicular (olp) +!----- the direction of wind +! + ol4p(1) = ol4(i,2) + ol4p(2) = ol4(i,1) + ol4p(3) = ol4(i,4) + ol4p(4) = ol4(i,3) + olp(i) = ol4p(mod(nwd-1,4)+1) +! +!----- compute orographic direction (horizontal orographic aspect ratio) +! + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) +! +!----- compute length of grid in the along(dxy) and cross(dxyp) wind directions +! + dxy(i) = dxy4(MOD(nwd-1,4)+1) + dxyp(i) = dxy4p(MOD(nwd-1,4)+1) + enddo +! +! END INITIALIZATION; BEGIN GWD CALCULATIONS: +! +IF ( ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & + (ls_taper .GT. 1.E-02) ) THEN !==== +! +!--- saving richardson number in usqj for migwdi +! + do k = kts,km-1 + do i = its,im + ti = 2.0 / (t1(i,k)+t1(i,k+1)) + rdz = 1./(zl(i,k+1) - zl(i,k)) + tem1 = u1(i,k) - u1(i,k+1) + tem2 = v1(i,k) - v1(i,k+1) + dw2 = rcl*(tem1*tem1 + tem2*tem2) + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti + usqj(i,k) = max(bvf2/shr2,rimin) + bnv2(i,k) = 2.0*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) + bnv2(i,k) = max( bnv2(i,k), bnv2min ) + enddo + enddo +! +!----compute the "low level" or 1/3 wind magnitude (m/s) +! + do i = its,im + ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) + rulow(i) = 1./ulow(i) + enddo +! + do k = kts,km-1 + do i = its,im + velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & + + (v1(i,k)+v1(i,k+1)) * vbar(i)) + velco(i,k) = velco(i,k) * rulow(i) + if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then + velco(i,k) = veleps + endif + enddo + enddo +! +! no drag when critical level in the base layer +! + do i = its,im + ldrag(i) = velco(i,1).le.0. + enddo +! +! no drag when velco.lt.0 +! + do k = kpblmin,kpblmax + do i = its,im + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. + enddo + enddo +! +! no drag when bnv2.lt.0 +! + do k = kts,kpblmax + do i = its,im + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0. + enddo + enddo +! +!-----the low level weighted average ri is stored in usqj(1,1; im) +!-----the low level weighted average n**2 is stored in bnv2(1,1; im) +!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 +!---- rdelks (del(k)/delks) vert ave factor so we can * instead of / +! + do i = its,im + wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) + bnv2(i,1) = wtkbj * bnv2(i,1) + usqj(i,1) = wtkbj * usqj(i,1) + enddo +! + do k = kpblmin,kpblmax + do i = its,im + if (k .lt. kbl(i)) then + rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) + bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks + usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks + endif + enddo + enddo +! + do i = its,im + ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 + ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 + ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 + enddo +! +! set all ri low level values to the low level value +! + do k = kpblmin,kpblmax + do i = its,im + if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) + enddo + enddo +! + do i = its,im + if (.not.ldrag(i)) then + bnv(i) = sqrt( bnv2(i,1) ) + fr(i) = bnv(i) * rulow(i) * 2. * var(i) * od(i) + fr(i) = min(fr(i),frmax) + xn(i) = ubar(i) * rulow(i) + yn(i) = vbar(i) * rulow(i) + endif + enddo +! +! compute the base level stress and store it in taub +! calculate enhancement factor, number of mountains & aspect +! ratio const. use simplified relationship between standard +! deviation & critical hgt + + do i = its,im + if (.not. ldrag(i)) then + efact = (oa(i) + 2.) ** (ce*fr(i)/frc) + efact = min( max(efact,efmin), efmax ) +!!!!!!! cleff (effective grid length) is highly tunable parameter +!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag +!WRF cleff = sqrt(dxy(i)**2. + dxyp(i)**2.) +!WRF cleff = 3. * max(dx(i),cleff) + coefm(i) = (1. + ol(i)) ** (oa(i)+1.) +!WRF xlinv(i) = coefm(i) / cleff + xlinv(i) = coefm(i) * cleff + tem = fr(i) * fr(i) * oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + if ( gwd_opt_ls .NE. 0 ) then + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact + else ! We've gotten what we need for the blocking scheme + taub(i) = 0.0 + end if + else + taub(i) = 0.0 + xn(i) = 0.0 + yn(i) = 0.0 + endif + enddo + +ENDIF ! (gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1) + +!========================================================= +! add small-scale wavedrag for stable boundary layer +!========================================================= + XNBV=0. + tauwavex0=0. + tauwavey0=0. + density=1.2 + utendwave=0. + vtendwave=0. + zq=0. +! + IF ( (gwd_opt_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + print*,"in Drag Suite: Running small-scale gravity wave drag" +! +! declaring potential temperature +! + do k = kts,km + do i = its,im + thx(i,k) = t1(i,k)/prslk(i,k) + enddo + enddo +! + do k = kts,km + do i = its,im + tvcon = (1.+fv*q1(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo + ! Calculate mid-layer height (zl), interface height (zq), and layer depth (dz2). + do k = kts,km + do i = its,im + zq(i,k+1) = PHII(i,k+1)*g_inv + dz2(i,k) = (PHII(i,k+1)-PHII(i,k))*g_inv + zl(i,k) = PHIL(i,k)*g_inv + enddo + enddo + + do i=its,im + hpbl2 = hpbl(i)+10. + kpbl2 = kpbl(i) + !kvar = MIN(kpbl, k-level of var) + kvar = 1 + do k=kts+1,MAX(kpbl(i),kts+1) +! IF (zl(i,k)>2.*var(i) .or. zl(i,k)>2*varmax) then + IF (zl(i,k)>300.) then + kpbl2 = k + IF (k == kpbl(i)) then + hpbl2 = hpbl(i)+10. + ELSE + hpbl2 = zl(i,k)+10. + ENDIF + exit + ENDIF + enddo + if((xland(i)-1.5).le.0. .and. 2.*varss(i).le.hpbl(i))then + if(br1(i).gt.0. .and. thvx(i,kpbl2)-thvx(i,kts) > 0.)then +!WRF cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) +! cleff_ss = 3. * max(dx(i),cleff_ss) +! cleff_ss = 10. * max(dxmax_ss,cleff_ss) +!WRF cleff_ss = 0.1 * max(dxmax_ss,cleff_ss) + cleff_ss = 0.1 * 12000. + coefm_ss(i) = (1. + olss(i)) ** (oass(i)+1.) + xlinv(i) = coefm_ss(i) / cleff_ss + !govrth(i)=g/(0.5*(thvx(i,kpbl(i))+thvx(i,kts))) + govrth(i)=g/(0.5*(thvx(i,kpbl2)+thvx(i,kts))) + !XNBV=sqrt(govrth(i)*(thvx(i,kpbl(i))-thvx(i,kts))/hpbl(i)) + XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) +! + !if(abs(XNBV/u1(i,kpbl(i))).gt.xlinv(i))then + if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then + !tauwavex0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*u1(i,kpbl(i)) + !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,kpbl2) + !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) + var_temp = MIN(varss(i),varmax_ss) + & + MAX(0.,beta_ss*(varss(i)-varmax_ss)) + tauwavex0=0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar)*u1(i,kvar) + tauwavex0=tauwavex0*ss_taper + else + tauwavex0=0. + endif +! + !if(abs(XNBV/v1(i,kpbl(i))).gt.xlinv(i))then + if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then + !tauwavey0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*v1(i,kpbl(i)) + !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,kpbl2) + !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) + var_temp = MIN(varss(i),varmax_ss) + & + MAX(0.,beta_ss*(varss(i)-varmax_ss)) + tauwavey0=0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar)*v1(i,kvar) + tauwavey0=tauwavey0*ss_taper + else + tauwavey0=0. + endif + + do k=kts,kpbl(i) !MIN(kpbl2+1,km-1) +!original + !utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) + !vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) +!new + utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 + vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 +!mod-to be used in HRRRv3/RAPv4 + !utendwave(i,k)=-1.*tauwavex0 * max((1.-zl(i,k)/hpbl2),0.)**2 + !vtendwave(i,k)=-1.*tauwavey0 * max((1.-zl(i,k)/hpbl2),0.)**2 + enddo + endif + endif + enddo ! end i loop + + do k = kts,km + do i = its,im + dudt(i,k) = dudt(i,k) + utendwave(i,k) + dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) + dusfc(i) = dusfc(i) + utendwave(i,k) * del(i,k) + dvsfc(i) = dvsfc(i) + vtendwave(i,k) * del(i,k) + enddo + enddo + if (gwd_opt == 33) then + do k = kts,km + do i = its,im + dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) + dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) + dtaux2d_ss(i,k) = utendwave(i,k) + dtauy2d_ss(i,k) = vtendwave(i,k) + enddo + enddo + endif + +ENDIF ! end if gwd_opt_ss == 1 + +!================================================================ +! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): +!================================================================ +IF ( (gwd_opt_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + print*,"in Drag Suite: Running form drag" + + utendform=0. + vtendform=0. + zq=0. + + IF ( (gwd_opt_ss .NE. 1).and.(ss_taper.GT.1.E-02) ) THEN + ! Defining mid-layer height (zl), interface height (zq), and layer depth (dz2). + ! This is already done above if the small-scale GWD is activated. + do k = kts,km + do i = its,im + zq(i,k+1) = PHII(i,k+1)*g_inv + dz2(i,k) = (PHII(i,k+1)-PHII(i,k))*g_inv + zl(i,k) = PHIL(i,k)*g_inv + enddo + enddo + ENDIF + + DO i=its,im + IF ((xland(i)-1.5) .le. 0.) then + !(IH*kflt**n1)**-1 = (0.00102*0.00035**-1.9)**-1 = 0.00026615161 + var_temp = MIN(varss(i),varmax_fd) + & + MAX(0.,beta_fd*(varss(i)-varmax_fd)) + var_temp = MIN(var_temp, 250.) + a1=0.00026615161*var_temp**2 +! a1=0.00026615161*MIN(varss(i),varmax)**2 +! a1=0.00026615161*(0.5*varss(i))**2 + ! k1**(n1-n2) = 0.003**(-1.9 - -2.8) = 0.003**0.9 = 0.005363 + a2=a1*0.005363 + ! Revise e-folding height based on PBL height and topographic std. dev. -- M. Toy 3/12/2018 + H_efold = max(2*varss(i),hpbl(i)) + H_efold = min(H_efold,1500.) + DO k=kts,km + wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) + ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + utendform(i,k)=-0.0759*wsp*u1(i,k)* & + EXP(-(zl(i,k)/H_efold)**1.5)*a2*zl(i,k)**(-1.2)*ss_taper + vtendform(i,k)=-0.0759*wsp*v1(i,k)* & + EXP(-(zl(i,k)/H_efold)**1.5)*a2*zl(i,k)**(-1.2)*ss_taper + !IF(zl(i,k) > 4000.) exit + ENDDO + ENDIF + ENDDO + + do k = kts,km + do i = its,im + dudt(i,k) = dudt(i,k) + utendform(i,k) + dvdt(i,k) = dvdt(i,k) + vtendform(i,k) + dusfc(i) = dusfc(i) + utendform(i,k) * del(i,k) + dvsfc(i) = dvsfc(i) + vtendform(i,k) * del(i,k) + enddo + enddo + if (gwd_opt == 33) then + do k = kts,km + do i = its,im + dtaux2d_fd(i,k) = utendform(i,k) + dtauy2d_fd(i,k) = vtendform(i,k) + dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) + dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) + enddo + enddo + endif + +ENDIF ! end if gwd_opt_fd == 1 +!======================================================= +! More for the large-scale gwd component +IF ( (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN + print*,"in Drag Suite: Running large-scale gravity wave drag" +! +! now compute vertical structure of the stress. + do k = kts,kpblmax + do i = its,im + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo + enddo +! + do k = kpblmin, km-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,im +! +! unstablelayer if ri < ric +! unstable layer if upper air vel comp along surf vel <=0 (crit lay) +! at (u-c)=0. crit layer exists and bit vector should be set (.le.) +! + if (k .ge. kbl(i)) then + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & + .or. (velco(i,k) .le. 0.0) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo +! + do i = its,im + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then + temv = 1.0 / velco(i,k) + tem1 = coefm(i)/dxy(i)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv +! +! rim is the minimum-richardson number by shutts (1985) + tem2 = sqrt(usqj(i,k)) + tem = 1. + tem2 * fro + rim = usqj(i,k) * (1.-fro) / (tem * tem) +! +! check stability to employ the 'saturation hypothesis' +! of lindzen (1981) except at tropospheric downstream regions +! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then + temc = 2.0 + 1.0 / tem2 + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) + endif + endif + endif + enddo + enddo +! + if(lcap.lt.km) then + do klcap = lcapp1,km + do i = its,im + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + +ENDIF !END LARGE-SCALE TAU CALCULATION +!=============================================================== +!COMPUTE BLOCKING COMPONENT +!=============================================================== +IF ( (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN + print*,"in Drag Suite: Running blocking drag" + + do i = its,im + if(.not.ldrag(i)) then +! +!------- determine the height of flow-blocking layer +! + kblk = 0 + pe = 0.0 + do k = km, kpblmin, -1 + if(kblk.eq.0 .and. k.le.komax(i)) then + pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) + ke = 0.5*((rcs*u1(i,k))**2.+(rcs*v1(i,k))**2.) +! +!---------- apply flow-blocking drag when pe >= ke +! + if(pe.ge.ke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + RDXZB(i) = real(k,kind=kind_phys) + endif + endif + enddo + if(kblk.ne.0) then +! +!--------- compute flow-blocking stress +! + cd = max(2.0-1.0/od(i),0.0) + taufb(i,kts) = 0.5 * roll(i) * coefm(i) / max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) & + * olp(i) * zblk * ulow(i)**2 + tautem = taufb(i,kts)/float(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo +! +!----------sum orographic GW stress and flow-blocking stress +! + ! taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now + endif + endif + enddo + +ENDIF ! end blocking drag +!=========================================================== +IF ( (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +! +! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +! + do k = kts,km + do i = its,im + taud_ls(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) + taud_bl(i,k) = 1. * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) + enddo + enddo +! +! limit de-acceleration (momentum deposition ) at top to 1/2 value +! the idea is some stuff must go out the 'top' + do klcap = lcap,km + do i = its,im + taud_ls(i,klcap) = taud_ls(i,klcap) * factop + taud_bl(i,klcap) = taud_bl(i,klcap) * factop + enddo + enddo +! +! if the gravity wave drag would force a critical line +! in the lower ksmm1 layers during the next deltim timestep, +! then only apply drag until that critical line is reached. +! + do k = kts,kpblmax-1 + do i = its,im + if (k .le. kbl(i)) then + if((taud_ls(i,k)+taud_bl(i,k)).ne.0.) & + dtfac(i) = min(dtfac(i),abs(velco(i,k) & + /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) + endif + enddo + enddo +! + do k = kts,km + do i = its,im + taud_ls(i,k) = taud_ls(i,k) * dtfac(i) * ls_taper *(1.-rstoch(i)) + taud_bl(i,k) = taud_bl(i,k) * dtfac(i) * ls_taper *(1.-rstoch(i)) + + dtaux = taud_ls(i,k) * xn(i) + dtauy = taud_ls(i,k) * yn(i) + dtauxb = taud_bl(i,k) * xn(i) + dtauyb = taud_bl(i,k) * yn(i) + + !add blocking and large-scale contributions to tendencies + dudt(i,k) = dtaux + dtauxb + dudt(i,k) + dvdt(i,k) = dtauy + dtauyb + dvdt(i,k) + + if ( gsd_diss_ht_opt .EQ. 1 ) then + ! Calculate dissipation heating + ! Initial kinetic energy (at t0-dt) + eng0 = 0.5*( (rcs*u1(i,k))**2. + (rcs*v1(i,k))**2. ) + ! Kinetic energy after wave-breaking/flow-blocking + eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux2d_ls(i,k)+dtaux2d_bl(i,k))*deltim))**2 + & + (rcs*(v1(i,k)+(dtauy2d_ls(i,k)+dtauy2d_bl(i,k))*deltim))**2 ) + ! Modify theta tendency + dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim/prslk(i,k) + end if + + dusfc(i) = dusfc(i) + taud_ls(i,k)*xn(i)*del(i,k) + taud_bl(i,k)*xn(i)*del(i,k) + dvsfc(i) = dvsfc(i) + taud_ls(i,k)*yn(i)*del(i,k) + taud_bl(i,k)*yn(i)*del(i,k) + enddo + enddo + + ! Finalize dusfc and dvsfc diagnostics + do i = its,im + dusfc(i) = (-1./g*rcs) * dusfc(i) + dvsfc(i) = (-1./g*rcs) * dvsfc(i) + enddo + + if (gwd_opt == 33) then + do k = kts,km + do i = its,im + dtaux2d_ls(i,k) = taud_ls(i,k) * xn(i) + dtauy2d_ls(i,k) = taud_ls(i,k) * yn(i) + dtaux2d_bl(i,k) = taud_bl(i,k) * xn(i) + dtauy2d_bl(i,k) = taud_bl(i,k) * yn(i) + dusfc_ls(i) = dusfc_ls(i) + dtaux2d_ls(i,k) * del(i,k) + dvsfc_ls(i) = dvsfc_ls(i) + dtauy2d_ls(i,k) * del(i,k) + dusfc_bl(i) = dusfc_bl(i) + dtaux2d_bl(i,k) * del(i,k) + dvsfc_bl(i) = dvsfc_bl(i) + dtauy2d_bl(i,k) * del(i,k) + enddo + enddo + endif + +ENDIF + +if (gwd_opt == 33) then + ! Finalize dusfc and dvsfc diagnostics + do i = its,im + dusfc_ls(i) = (-1./g*rcs) * dusfc_ls(i) + dvsfc_ls(i) = (-1./g*rcs) * dvsfc_ls(i) + dusfc_bl(i) = (-1./g*rcs) * dusfc_bl(i) + dvsfc_bl(i) = (-1./g*rcs) * dvsfc_bl(i) + dusfc_ss(i) = (-1./g*rcs) * dusfc_ss(i) + dvsfc_ss(i) = (-1./g*rcs) * dvsfc_ss(i) + dusfc_fd(i) = (-1./g*rcs) * dusfc_fd(i) + dvsfc_fd(i) = (-1./g*rcs) * dvsfc_fd(i) + enddo +endif +! + return + end subroutine drag_suite_run +!------------------------------------------------------------------- +! +!> \section arg_table_drag_suite_finalize Argument Table +!! + subroutine drag_suite_finalize() + end subroutine drag_suite_finalize + + end module drag_suite + +!> This module contains the CCPP-compliant orographic gravity wave drag post +!! interstitial codes. + module drag_suite_post + + contains + +!! \section arg_table_drag_suite_post_init Argument Table +!! + subroutine drag_suite_post_init() + end subroutine drag_suite_post_init + +!! \section arg_table_drag_suite_post_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------------------------|---------------------------------------------------------------------------|-------|------|-----------|-----------|--------|----------| +!! | lssav | flag_diagnostics | flag for calculating diagnostic fields | flag | 0 | logical | | in | F | +!! | ldiag3d | flag_diagnostics_3D | flag for calculating 3-D diagnostic fields | flag | 0 | logical | | in | F | +!! | dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | +!! | dusfcg | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | +!! | dvsfcg | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | +!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | +!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | +!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | in | F | +!! | dugwd | time_integral_of_x_stress_due_to_gravity_wave_drag | integral over time of zonal stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | +!! | dvgwd | time_integral_of_y_stress_due_to_gravity_wave_drag | integral over time of meridional stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | +!! | du3dt | cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag | cumulative change in zonal wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | dv3dt | cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag | cumulative change in meridional wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | dt3dt | cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag | cumulative change in temperature due to orographic gravity wave drag | K | 2 | real | kind_phys | inout | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine drag_suite_post_run( & + & lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & + & dugwd, dvgwd, du3dt, dv3dt, dt3dt, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + logical, intent(in) :: lssav, ldiag3d + real(kind=kind_phys), intent(in) :: dtf + real(kind=kind_phys), intent(in) :: & + & dusfcg(:), dvsfcg(:), dudt(:,:), dvdt(:,:), dtdt(:,:) + + real(kind=kind_phys), intent(inout) :: & + & dugwd(:), dvgwd(:), du3dt(:,:), dv3dt(:,:), dt3dt(:,:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lssav) then + dugwd(:) = dugwd(:) + dusfcg(:)*dtf + dvgwd(:) = dvgwd(:) + dvsfcg(:)*dtf + + if (ldiag3d) then + du3dt(:,:) = du3dt(:,:) + dudt(:,:) * dtf + dv3dt(:,:) = dv3dt(:,:) + dvdt(:,:) * dtf + dt3dt(:,:) = dt3dt(:,:) + dtdt(:,:) * dtf + endif + endif + + end subroutine drag_suite_post_run + +!> \section arg_table_drag_suite_post_finalize Argument Table +!! + subroutine drag_suite_post_finalize() + end subroutine drag_suite_post_finalize + + end module drag_suite_post From 89fd3704b0efe45f64bb5487548ae8658c78f541 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 24 Sep 2019 21:15:30 +0000 Subject: [PATCH 34/59] Incorporated changes suggested in PR review --- CMakeLists.txt | 1 + physics/drag_suite.F90 | 38 +++++++++++++++++++++++--------------- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bfcceebc6..ad8a8c1f8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -166,6 +166,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNSFC_wrapper.F90 ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 + ./physics/drag_suite.F90 ./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8 -ftz") diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index a8ed0fc1b..627f636eb 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -196,6 +196,7 @@ end subroutine drag_suite_init !! | imx | number_of_equatorial_longitude_points | number of longitude points along the equator | count | 0 | integer | | in | F | !! | cdmbgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag | none | 1 | real | kind_phys | in | F | !! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | +!! | master | mpi_root | master MPI-rank | index | 0 | integer | | in | F | !! | lprnt | flag_print | flag for debugging printouts | flag | 0 | logical | | in | F | !! | ipr | horizontal_index_of_printed_column | horizontal index of column used in debugging printouts | index | 0 | integer | | in | F | !! | rdxzb | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | out | F | @@ -384,8 +385,8 @@ subroutine drag_suite_run( & & dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & & slmsk,br1,hpbl, & - & g, cp, rd, rv, fv, pi, imx, cdmbgwd, & - & me, lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) + & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & + & lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- @@ -474,15 +475,17 @@ subroutine drag_suite_run( & implicit none ! Interface variables - integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, gwd_opt + integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, master + inteter, intent(in) :: gwd_opt logical, intent(in) :: lprnt integer, intent(in) :: KPBL(im) - real(kind=kind_phys):: deltim, G, CP, RD, RV, cdmbgwd(2) + real(kind=kind_phys), intent(in) :: deltim, G, CP, RD, RV, cdmbgwd(2) integer :: kpblmax integer, parameter :: ims=1, kms=1, its=1, kts=1 - real :: fv, pi, rcl, cdmb - real, parameter :: g_inv = 1./9.81 !1./g + real, intent(in) :: fv, pi + real :: rcl, cdmb + real :: g_inv = 1./G real(kind=kind_phys), intent(out) :: & & dudt(im,km),dvdt(im,km), & @@ -644,11 +647,16 @@ subroutine drag_suite_run( & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + + ! Calculate inverse of gravitational acceleration + g_inv = 1./G + + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 -print*,"Running drag suite" +if (me==master) print *,"Running drag suite" !-------------------------------------------------------------------- ! SCALE-ADPTIVE PARAMETER FROM GFS GWD SCHEME !-------------------------------------------------------------------- @@ -722,7 +730,7 @@ subroutine drag_suite_run( & (dxmax_ls-dxmin_ls)) + 1. ) end if end if -print*,"in Drag Suite, dx(1:2):",dx(1),dx(2) +if (me==master) print *,"in Drag Suite, dx(1:2):",dx(1),dx(2) if ( dx(1) .ge. dxmax_ss ) then ss_taper = 1. else @@ -732,7 +740,7 @@ subroutine drag_suite_run( & ss_taper = dxmax_ss * (1. - dxmin_ss/dx(1))/(dxmax_ss-dxmin_ss) end if end if -print*,"in Drag Suite, ss_taper:",ss_taper +if (me==master) print *,"in Drag Suite, ss_taper:",ss_taper !--- calculate length of grid for flow-blocking drag ! @@ -1070,7 +1078,7 @@ subroutine drag_suite_run( & zq=0. ! IF ( (gwd_opt_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN - print*,"in Drag Suite: Running small-scale gravity wave drag" + if (me==master) print *,"in Drag Suite: Running small-scale gravity wave drag" ! ! declaring potential temperature ! @@ -1192,7 +1200,7 @@ subroutine drag_suite_run( & ! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): !================================================================ IF ( (gwd_opt_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN - print*,"in Drag Suite: Running form drag" + if (me==master) print *,"in Drag Suite: Running form drag" utendform=0. vtendform=0. @@ -1259,7 +1267,7 @@ subroutine drag_suite_run( & !======================================================= ! More for the large-scale gwd component IF ( (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN - print*,"in Drag Suite: Running large-scale gravity wave drag" + if (me==master) print *,"in Drag Suite: Running large-scale gravity wave drag" ! ! now compute vertical structure of the stress. do k = kts,kpblmax @@ -1327,7 +1335,7 @@ subroutine drag_suite_run( & !COMPUTE BLOCKING COMPONENT !=============================================================== IF ( (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN - print*,"in Drag Suite: Running blocking drag" + if (me==master) print *,"in Drag Suite: Running blocking drag" do i = its,im if(.not.ldrag(i)) then @@ -1425,8 +1433,8 @@ subroutine drag_suite_run( & ! Initial kinetic energy (at t0-dt) eng0 = 0.5*( (rcs*u1(i,k))**2. + (rcs*v1(i,k))**2. ) ! Kinetic energy after wave-breaking/flow-blocking - eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux2d_ls(i,k)+dtaux2d_bl(i,k))*deltim))**2 + & - (rcs*(v1(i,k)+(dtauy2d_ls(i,k)+dtauy2d_bl(i,k))*deltim))**2 ) + eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux+dtauxb)*deltim))**2 + & + (rcs*(v1(i,k)+(dtauy+dtauyb)*deltim))**2 ) ! Modify theta tendency dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim/prslk(i,k) end if From 5b7201d04806773fd90df2a27250f954f5e150af Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 27 Sep 2019 16:36:29 -0600 Subject: [PATCH 35/59] Revert change to CMakeLists.txt, convert physics/drag_suite.F90 to new metadata format --- CMakeLists.txt | 1 - physics/drag_suite.F90 | 217 +++------- physics/drag_suite.meta | 862 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 923 insertions(+), 157 deletions(-) create mode 100644 physics/drag_suite.meta diff --git a/CMakeLists.txt b/CMakeLists.txt index 2bf559811..443d7ea51 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -166,7 +166,6 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNSFC_wrapper.F90 ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 - ./physics/drag_suite.F90 ./physics/module_mp_thompson_make_number_concentrations.F90 ./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 627f636eb..83a36f206 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -13,22 +13,8 @@ module drag_suite_pre subroutine drag_suite_pre_init() end subroutine drag_suite_pre_init -!! \section arg_table_drag_suite_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------------------------------------|------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | -!! | nmtvr | number_of_statistical_measures_of_subgrid_orography | number of statistical measures of subgrid orography | count | 0 | integer | | in | F | -!! | mntvar | statistical_measures_of_subgrid_orography | array of statistical measures of subgrid orography | various | 2 | real | kind_phys | in | F | -!! | hprime | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | out | F | -!! | oc | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | out | F | -!! | clx | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | out | F | -!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with_respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | out | F | -!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | out | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!> \section arg_table_drag_suite_pre_run Argument Table +!! \htmlinclude drag_suite_pre_run.html !! !! \section general General Algorithm !! \section detailed Detailed Algorithm @@ -136,74 +122,8 @@ end subroutine drag_suite_init !! subgrid scale orography including convective breaking, shear !! breaking and the presence of critical levels. !! -!! \section arg_table_drag_suite_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------------------------------------------|----------------------------------------------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | km | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | -!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | -!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | -!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | inout | F | -!! | u1 | x_wind | zonal wind | m s-1 | 2 | real | kind_phys | in | F | -!! | v1 | y_wind | meridional wind | m s-1 | 2 | real | kind_phys | in | F | -!! | t1 | air_temperature | mid-layer temperature | K | 2 | real | kind_phys | in | F | -!! | q1 | water_vapor_specific_humidity | mid-layer specific humidity of water vapor | kg kg-1 | 2 | real | kind_phys | in | F | -!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | vertical index at top atmospheric boundary layer | index | 1 | integer | | in | F | -!! | prsi | air_pressure_at_interface | interface pressure | Pa | 2 | real | kind_phys | in | F | -!! | del | air_pressure_difference_between_midlayers | difference between mid-layer pressures | Pa | 2 | real | kind_phys | in | F | -!! | prsl | air_pressure | mid-layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prslk | dimensionless_exner_function_at_model_layers | mid-layer Exner function | none | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | interface geopotential | m2 s-2 | 2 | real | kind_phys | in | F | -!! | phil | geopotential | mid-layer geopotential | m2 s-2 | 2 | real | kind_phys | in | F | -!! | deltim | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | var | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | in | F | -!! | oc1 | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | in | F | -!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | in | F | -!! | ol4 | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | in | F | -!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | in | F | -!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | in | F | -!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | in | F | -!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | inout | F | -!! | dtaux2d_ls | x_momentum_tendency_from_large_scale_gwd | x momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_ls | y_momentum_tendency_from_large_scale_gwd | y momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtaux2d_bl | x_momentum_tendency_from_blocking_drag | x momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_bl | y_momentum_tendency_from_blocking_drag | y momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dtaux2d_ss | x_momentum_tendency_from_small_scale_gwd | x momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_ss | y_momentum_tendency_from_small_scale_gwd | y momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtaux2d_fd | x_momentum_tendency_from_form_drag | x momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_fd | y_momentum_tendency_from_form_drag | y momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dusfc | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | -!! | dvsfc | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | -!! | dusfc_ls | integrated_x_momentum_flux_from_large_scale_gwd | integrated x momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_ls | integrated_y_momentum_flux_from_large_scale_gwd | integrated y momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dusfc_bl | integrated_x_momentum_flux_from_blocking_drag | integrated x momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_bl | integrated_y_momentum_flux_from_blocking_drag | integrated y momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | -!! | dusfc_ss | integrated_x_momentum_flux_from_small_scale_gwd | integrated x momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_ss | integrated_y_momentum_flux_from_small_scale_gwd | integrated y momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dusfc_fd | integrated_x_momentum_flux_from_form_drag | integrated x momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_fd | integrated_y_momentum_flux_from_form_drag | integrated y momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | -!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | -!! | br1 | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | -!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | -!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | fv | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | -!! | pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | -!! | imx | number_of_equatorial_longitude_points | number of longitude points along the equator | count | 0 | integer | | in | F | -!! | cdmbgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag | none | 1 | real | kind_phys | in | F | -!! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | -!! | master | mpi_root | master MPI-rank | index | 0 | integer | | in | F | -!! | lprnt | flag_print | flag for debugging printouts | flag | 0 | logical | | in | F | -!! | ipr | horizontal_index_of_printed_column | horizontal index of column used in debugging printouts | index | 0 | integer | | in | F | -!! | rdxzb | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | out | F | -!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | -!! | gwd_opt | gwd_opt | flag to choose gwd scheme | flag | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!> \section arg_table_drag_suite_run Argument Table +!! \htmlinclude drag_suite_run.html !! !> \section gen_drag_suite GFS Orographic GWD Scheme General Algorithm !! -# Calculate subgrid mountain blocking @@ -476,16 +396,16 @@ subroutine drag_suite_run( & ! Interface variables integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, master - inteter, intent(in) :: gwd_opt + integer, intent(in) :: gwd_opt logical, intent(in) :: lprnt integer, intent(in) :: KPBL(im) real(kind=kind_phys), intent(in) :: deltim, G, CP, RD, RV, cdmbgwd(2) - integer :: kpblmax - integer, parameter :: ims=1, kms=1, its=1, kts=1 - real, intent(in) :: fv, pi - real :: rcl, cdmb - real :: g_inv = 1./G + integer :: kpblmax + integer, parameter :: ims=1, kms=1, its=1, kts=1 + real(kind=kind_phys), intent(in) :: fv, pi + real(kind=kind_phys) :: rcl, cdmb + real(kind=kind_phys) :: g_inv = 1./G real(kind=kind_phys), intent(out) :: & & dudt(im,km),dvdt(im,km), & @@ -501,26 +421,26 @@ subroutine drag_suite_run( & & oa4(im,4),ol4(im,4), & & dx(im) !real(kind=kind_phys), intent(in) :: varss(im),oc1ss(im), & - real :: varss(im),oc1ss(im), & + real(kind=kind_phys) :: varss(im),oc1ss(im), & & oa4ss(im,4),ol4ss(im,4) real(kind=kind_phys), intent(in) :: THETA(im),SIGMA(im), & & GAMMA(im),ELVMAX(im) ! added for small-scale orographic wave drag - real, dimension(im,km) :: utendwave,vtendwave,thx,thvx + real(kind=kind_phys), dimension(im,km) :: utendwave,vtendwave,thx,thvx real(kind=kind_phys), intent(in) :: br1(im), & & hpbl(im), & & slmsk(im) - real, dimension(im) :: govrth,xland - real, dimension(im,km) :: dz2 - real :: tauwavex0,tauwavey0, & + real(kind=kind_phys), dimension(im) :: govrth,xland + real(kind=kind_phys), dimension(im,km) :: dz2 + real(kind=kind_phys) :: tauwavex0,tauwavey0, & & XNBV,density,tvcon,hpbl2 integer :: kpbl2,kvar - real, dimension(im,km+1) :: zq ! = PHII/g - real, dimension(im,km) :: zl ! = PHIL/g + real(kind=kind_phys), dimension(im,km+1) :: zq ! = PHII/g + real(kind=kind_phys), dimension(im,km) :: zl ! = PHIL/g !SPP - real, dimension(im) :: rstoch + real(kind=kind_phys), dimension(im) :: rstoch !Output: real(kind=kind_phys), intent(out) :: & @@ -538,7 +458,7 @@ subroutine drag_suite_run( & & dtaux2d_fd(:,:),dtauy2d_fd(:,:) !Misc arrays - real, dimension(im,km) :: dtaux2d, dtauy2d + real(kind=kind_phys), dimension(im,km) :: dtaux2d, dtauy2d !------------------------------------------------------------------------- ! Flags to regulate the activation of specific components of drag suite: @@ -553,40 +473,40 @@ subroutine drag_suite_run( & ! Parameters for bounding the scale-adaptive variability: ! Small-scale GWD + turbulent form drag - real, parameter :: dxmin_ss = 1000., & + real(kind=kind_phys), parameter :: dxmin_ss = 1000., & & dxmax_ss = 12000. ! min,max range of tapering (m) ! Large-scale GWD + blocking - real, parameter :: dxmin_ls = 3000., & + real(kind=kind_phys), parameter :: dxmin_ls = 3000., & & dxmax_ls = 13000. ! min,max range of tapering (m) - real :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) + real(kind=kind_phys) :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) ! ! Variables for limiting topographic standard deviation (var) - real, parameter :: varmax_ss = 50., & + real(kind=kind_phys), parameter :: varmax_ss = 50., & varmax_fd = 150., & beta_ss = 0.1, & beta_fd = 0.2 - real :: var_temp + real(kind=kind_phys) :: var_temp ! added Beljaars orographic form drag - real, dimension(im,km) :: utendform,vtendform - real :: a1,a2,wsp - real :: H_efold + real(kind=kind_phys), dimension(im,km) :: utendform,vtendform + real(kind=kind_phys) :: a1,a2,wsp + real(kind=kind_phys) :: H_efold ! critical richardson number for wave breaking : ! larger drag with larger value - real,parameter :: ric = 0.25 - real,parameter :: dw2min = 1. - real,parameter :: rimin = -100. - real,parameter :: bnv2min = 1.0e-5 - real,parameter :: efmin = 0.0 - real,parameter :: efmax = 10.0 - real,parameter :: xl = 4.0e4 - real,parameter :: critac = 1.0e-5 - real,parameter :: gmax = 1. - real,parameter :: veleps = 1.0 - real,parameter :: factop = 0.5 - real,parameter :: frc = 1.0 - real,parameter :: ce = 0.8 - real,parameter :: cg = 0.5 + real(kind=kind_phys), parameter :: ric = 0.25 + real(kind=kind_phys), parameter :: dw2min = 1. + real(kind=kind_phys), parameter :: rimin = -100. + real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 + real(kind=kind_phys), parameter :: efmin = 0.0 + real(kind=kind_phys), parameter :: efmax = 10.0 + real(kind=kind_phys), parameter :: xl = 4.0e4 + real(kind=kind_phys), parameter :: critac = 1.0e-5 + real(kind=kind_phys), parameter :: gmax = 1. + real(kind=kind_phys), parameter :: veleps = 1.0 + real(kind=kind_phys), parameter :: factop = 0.5 + real(kind=kind_phys), parameter :: frc = 1.0 + real(kind=kind_phys), parameter :: ce = 0.8 + real(kind=kind_phys), parameter :: cg = 0.5 integer,parameter :: kpblmin = 2 ! @@ -595,7 +515,7 @@ subroutine drag_suite_run( & integer :: i,j,k,lcap,lcapp1,nwd,idir, & klcap,kp1,ikount,kk ! - real :: rcs,rclcs,csg,fdir,cleff,cleff_ss,cs, & + real(kind=kind_phys) :: rcs,rclcs,csg,fdir,cleff,cleff_ss,cs, & rcsks,wdir,ti,rdz,temp,tem2,dw2,shr2, & bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & rim,temc,tem1,efact,temv,dtaux,dtauy, & @@ -604,7 +524,7 @@ subroutine drag_suite_run( & logical :: ldrag(im),icrilv(im), & flag(im),kloop1(im) ! - real :: taub(im),taup(im,km+1), & + real(kind=kind_phys) :: taub(im),taup(im,km+1), & xn(im),yn(im), & ubar(im),vbar(im), & fr(im),ulow(im), & @@ -624,25 +544,26 @@ subroutine drag_suite_run( & integer :: kbl(im),klowtop(im) logical :: iope integer,parameter :: mdir=8 - integer :: nwdir(mdir) - data nwdir/6,7,5,8,2,3,1,4/ + !integer :: nwdir(mdir) + !data nwdir/6,7,5,8,2,3,1,4/ + integer, parameter :: nwdir = (/6,7,5,8,2,3,1,4/) ! ! variables for flow-blocking drag ! - real,parameter :: frmax = 10. - real,parameter :: olmin = 1.0e-5 - real,parameter :: odmin = 0.1 - real,parameter :: odmax = 10. - real,parameter :: erad = 6371.315e+3 + real(kind=kind_phys),parameter :: frmax = 10. + real(kind=kind_phys),parameter :: olmin = 1.0e-5 + real(kind=kind_phys),parameter :: odmin = 0.1 + real(kind=kind_phys),parameter :: odmax = 10. + real(kind=kind_phys),parameter :: erad = 6371.315e+3 integer :: komax(im) integer :: kblk - real :: cd - real :: zblk,tautem - real :: pe,ke - real :: delx,dely,dxy4(4),dxy4p(4) - real :: dxy(im),dxyp(im) - real :: ol4p(4),olp(im),od(im) - real :: taufb(im,km+1) + real(kind=kind_phys) :: cd + real(kind=kind_phys) :: zblk,tautem + real(kind=kind_phys) :: pe,ke + real(kind=kind_phys) :: delx,dely,dxy4(4),dxy4p(4) + real(kind=kind_phys) :: dxy(im),dxyp(im) + real(kind=kind_phys) :: ol4p(4),olp(im),od(im) + real(kind=kind_phys) :: taufb(im,km+1) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -1498,29 +1419,13 @@ module drag_suite_post contains -!! \section arg_table_drag_suite_post_init Argument Table +!> \section arg_table_drag_suite_post_init Argument Table !! subroutine drag_suite_post_init() end subroutine drag_suite_post_init -!! \section arg_table_drag_suite_post_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------------------------------------------|---------------------------------------------------------------------------|-------|------|-----------|-----------|--------|----------| -!! | lssav | flag_diagnostics | flag for calculating diagnostic fields | flag | 0 | logical | | in | F | -!! | ldiag3d | flag_diagnostics_3D | flag for calculating 3-D diagnostic fields | flag | 0 | logical | | in | F | -!! | dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | -!! | dusfcg | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | -!! | dvsfcg | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | -!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | -!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | -!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | in | F | -!! | dugwd | time_integral_of_x_stress_due_to_gravity_wave_drag | integral over time of zonal stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | -!! | dvgwd | time_integral_of_y_stress_due_to_gravity_wave_drag | integral over time of meridional stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | -!! | du3dt | cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag | cumulative change in zonal wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | -!! | dv3dt | cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag | cumulative change in meridional wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | -!! | dt3dt | cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag | cumulative change in temperature due to orographic gravity wave drag | K | 2 | real | kind_phys | inout | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!> \section arg_table_drag_suite_post_run Argument Table +!! \htmlinclude drag_suite_post_run.html !! subroutine drag_suite_post_run( & & lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta new file mode 100644 index 000000000..ab84e937f --- /dev/null +++ b/physics/drag_suite.meta @@ -0,0 +1,862 @@ +[ccpp-arg-table] + name = drag_suite_pre_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nmtvr] + standard_name = number_of_statistical_measures_of_subgrid_orography + long_name = number of statistical measures of subgrid orography + units = count + dimensions = () + type = integer + intent = in + optional = F +[mntvar] + standard_name = statistical_measures_of_subgrid_orography + long_name = array of statistical measures of subgrid orography + units = various + dimensions = (horizontal_dimension,number_of_statistical_measures_of_subgrid_orography) + type = real + kind = kind_phys + intent = in + optional = F +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = out + optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = out + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with_respect to east of maximum subgrid orographic variations + units = degrees + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = drag_suite_pre_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[ix] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = vertical_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[u1] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature + long_name = mid-layer temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = interface pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = difference between mid-layer pressures + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mid-layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = mid-layer Exner function + units = none + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = interface geopotential + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phil] + standard_name = geopotential + long_name = mid-layer geopotential + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[deltim] + standard_name = time_step_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current time step index + units = index + dimensions = () + type = integer + intent = in + optional = F +[var] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oc1] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[ol4] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with respect to east of maximum subgrid orographic variations + units = degrees + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtaux2d_ls] + standard_name = x_momentum_tendency_from_large_scale_gwd + long_name = x momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ls] + standard_name = y_momentum_tendency_from_large_scale_gwd + long_name = y momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_bl] + standard_name = x_momentum_tendency_from_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_bl] + standard_name = y_momentum_tendency_from_blocking_drag + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_ss] + standard_name = x_momentum_tendency_from_small_scale_gwd + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ss] + standard_name = y_momentum_tendency_from_small_scale_gwd + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_fd] + standard_name = x_momentum_tendency_from_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_fd] + standard_name = y_momentum_tendency_from_form_drag + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ls] + standard_name = integrated_x_momentum_flux_from_large_scale_gwd + long_name = integrated x momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ls] + standard_name = integrated_y_momentum_flux_from_large_scale_gwd + long_name = integrated y momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_bl] + standard_name = integrated_x_momentum_flux_from_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_bl] + standard_name = integrated_y_momentum_flux_from_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ss] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd + long_name = integrated x momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ss] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd + long_name = integrated y momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_fd] + standard_name = integrated_x_momentum_flux_from_form_drag + long_name = integrated x momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_fd] + standard_name = integrated_y_momentum_flux_from_form_drag + long_name = integrated y momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[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 + optional = F +[rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[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 + optional = F +[fv] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = radians + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[imx] + standard_name = number_of_equatorial_longitude_points + long_name = number of longitude points along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = rank of the current MPI task + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = flag for debugging printouts + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of column used in debugging printouts + units = index + dimensions = () + type = integer + intent = in + optional = F +[rdxzb] + standard_name = level_of_dividing_streamline + long_name = level of the dividing streamline + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dx] + standard_name = cell_size + long_name = size of the grid cell + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = drag_suite_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_post_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_post_run + type = scheme +[lssav] + standard_name = flag_diagnostics + long_name = flag for calculating diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for calculating 3-D diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dugwd] + standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag + long_name = integral over time of zonal stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvgwd] + standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag + long_name = integral over time of meridional stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in zonal wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dv3dt] + standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in meridional wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt] + standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag + long_name = cumulative change in temperature due to orographic gravity wave drag + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = drag_suite_post_finalize + type = scheme From 78c59108c4a900fae5daf7a956104973c70003f9 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Sat, 28 Sep 2019 21:10:31 -0600 Subject: [PATCH 36/59] physics/drag_suite.F90: bugfixes --- physics/drag_suite.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 83a36f206..56902c631 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -405,7 +405,7 @@ subroutine drag_suite_run( & integer, parameter :: ims=1, kms=1, its=1, kts=1 real(kind=kind_phys), intent(in) :: fv, pi real(kind=kind_phys) :: rcl, cdmb - real(kind=kind_phys) :: g_inv = 1./G + real(kind=kind_phys) :: g_inv real(kind=kind_phys), intent(out) :: & & dudt(im,km),dvdt(im,km), & @@ -546,7 +546,7 @@ subroutine drag_suite_run( & integer,parameter :: mdir=8 !integer :: nwdir(mdir) !data nwdir/6,7,5,8,2,3,1,4/ - integer, parameter :: nwdir = (/6,7,5,8,2,3,1,4/) + integer, parameter :: nwdir(8) = (/6,7,5,8,2,3,1,4/) ! ! variables for flow-blocking drag ! @@ -568,11 +568,9 @@ subroutine drag_suite_run( & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! Calculate inverse of gravitational acceleration g_inv = 1./G - ! Initialize CCPP error handling variables errmsg = '' errflg = 0 From 848d2c83f8370f1e02b0940655c8cf19ef9d352d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 18 Sep 2019 15:53:56 +0000 Subject: [PATCH 37/59] three files GFS_debug.F90, rrtmg_lw_pre.F90, and rrtmg_sw_pre.F90 are changed by commenting out print of Sfcprop%hprim and replacing replace Sfcprop%hprim variable by Sfcprop%hprime(:,1) in rrtmg routines --- physics/GFS_debug.F90 | 149 +++++++++++---------------------------- physics/rrtmg_lw_pre.F90 | 14 +++- physics/rrtmg_sw_pre.F90 | 33 ++++++--- 3 files changed, 78 insertions(+), 118 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 600936cce..30a25f93e 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -41,7 +41,23 @@ subroutine GFS_diagtoscreen_finalize () end subroutine GFS_diagtoscreen_finalize !> \section arg_table_GFS_diagtoscreen_run Argument Table -!! \htmlinclude GFS_diagtoscreen_run.html +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| +!! | Model | GFS_control_type_instance | instance of derived type GFS_control_type in FV3 | DDT | 0 | GFS_control_type | | in | F | +!! | Statein | GFS_statein_type_instance | instance of derived type GFS_statein_type in FV3 | DDT | 0 | GFS_statein_type | | in | F | +!! | Stateout | GFS_stateout_type_instance | instance of derived type GFS_stateout_type | DDT | 0 | GFS_stateout_type | | in | F | +!! | Sfcprop | GFS_sfcprop_type_instance | instance of type GFS_sfcprop_type in FV3 | DDT | 0 | GFS_sfcprop_type | | in | F | +!! | Coupling | GFS_coupling_type_instance | instance of type GFS_coupling_type in FV3 | DDT | 0 | GFS_coupling_type | | in | F | +!! | Grid | GFS_grid_type_instance | instance of type GFS_grid_type in FV3 | DDT | 0 | GFS_grid_type | | in | F | +!! | Tbd | GFS_tbd_type_instance | instance of type GFS_tbd_type in FV3 | DDT | 0 | GFS_tbd_type | | in | F | +!! | Cldprop | GFS_cldprop_type_instance | instance of type GFS_cldprop_type in FV3 | DDT | 0 | GFS_cldprop_type | | in | F | +!! | Radtend | GFS_radtend_type_instance | instance of type GFS_radtend_type in FV3 | DDT | 0 | GFS_radtend_type | | in | F | +!! | Diag | GFS_diag_type_instance | instance of type GFS_diag_type in FV3 | DDT | 0 | GFS_diag_type | | in | F | +!! | Interstitial | GFS_interstitial_type_instance | instance of type GFS_interstitial_type in FV3 | DDT | 0 | GFS_interstitial_type | | in | F | +!! | nthreads | omp_threads | number of OpenMP threads or fast physics schemes | count | 0 | integer | | in | F | +!! | blkno | ccpp_block_number | number of block for explicit data blocking in CCPP | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, & Grid, Tbd, Cldprop, Radtend, Diag, Interstitial, & @@ -130,7 +146,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Sfcprop%zorlo' , Sfcprop%zorlo) call print_var(mpirank,omprank, blkno, 'Sfcprop%zorll' , Sfcprop%zorll) call print_var(mpirank,omprank, blkno, 'Sfcprop%fice' , Sfcprop%fice) - call print_var(mpirank,omprank, blkno, 'Sfcprop%hprim' , Sfcprop%hprim) +! call print_var(mpirank,omprank, blkno, 'Sfcprop%hprim' , Sfcprop%hprim) call print_var(mpirank,omprank, blkno, 'Sfcprop%hprime' , Sfcprop%hprime) call print_var(mpirank,omprank, blkno, 'Sfcprop%sncovr' , Sfcprop%sncovr) call print_var(mpirank,omprank, blkno, 'Sfcprop%snoalb' , Sfcprop%snoalb) @@ -756,7 +772,23 @@ subroutine GFS_interstitialtoscreen_finalize () end subroutine GFS_interstitialtoscreen_finalize !> \section arg_table_GFS_interstitialtoscreen_run Argument Table -!! \htmlinclude GFS_interstitialtoscreen_run.html +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| +!! | Model | GFS_control_type_instance | instance of derived type GFS_control_type | DDT | 0 | GFS_control_type | | in | F | +!! | Statein | GFS_statein_type_instance | instance of derived type GFS_statein_type | DDT | 0 | GFS_statein_type | | in | F | +!! | Stateout | GFS_stateout_type_instance | instance of derived type GFS_stateout_type | DDT | 0 | GFS_stateout_type | | in | F | +!! | Sfcprop | GFS_sfcprop_type_instance | instance of derived type GFS_sfcprop_type | DDT | 0 | GFS_sfcprop_type | | in | F | +!! | Coupling | GFS_coupling_type_instance | instance of derived type GFS_coupling_type | DDT | 0 | GFS_coupling_type | | in | F | +!! | Grid | GFS_grid_type_instance | instance of derived type GFS_grid_type | DDT | 0 | GFS_grid_type | | in | F | +!! | Tbd | GFS_tbd_type_instance | instance of derived type GFS_tbd_type | DDT | 0 | GFS_tbd_type | | in | F | +!! | Cldprop | GFS_cldprop_type_instance | instance of derived type GFS_cldprop_type | DDT | 0 | GFS_cldprop_type | | in | F | +!! | Radtend | GFS_radtend_type_instance | instance of derived type GFS_radtend_type | DDT | 0 | GFS_radtend_type | | in | F | +!! | Diag | GFS_diag_type_instance | instance of derived type GFS_diag_type | DDT | 0 | GFS_diag_type | | in | F | +!! | Interstitial | GFS_interstitial_type_instance | instance of derived type GFS_interstitial_type | DDT | 0 | GFS_interstitial_type | | in | F | +!! | nthreads | omp_threads | number of OpenMP threads or fast physics schemes | count | 0 | integer | | in | F | +!! | blkno | ccpp_block_number | number of block for explicit data blocking in CCPP | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, & Grid, Tbd, Cldprop, Radtend, Diag, Interstitial, & @@ -868,7 +900,12 @@ subroutine GFS_abort_finalize () end subroutine GFS_abort_finalize !> \section arg_table_GFS_abort_run Argument Table -!! \htmlinclude GFS_abort_run.html +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| +!! | Model | GFS_control_type_instance | instance of derived type GFS_control_type | DDT | 0 | GFS_control_type | | in | F | +!! | blkno | ccpp_block_number | number of block for explicit data blocking in CCPP | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! subroutine GFS_abort_run (Model, blkno, errmsg, errflg) @@ -896,107 +933,3 @@ subroutine GFS_abort_run (Model, blkno, errmsg, errflg) end subroutine GFS_abort_run end module GFS_abort - - module GFS_checkland - - private - - public GFS_checkland_init, GFS_checkland_run, GFS_checkland_finalize - - contains - - subroutine GFS_checkland_init () - end subroutine GFS_checkland_init - - subroutine GFS_checkland_finalize () - end subroutine GFS_checkland_finalize - -!> \section arg_table_GFS_checkland_run Argument Table -!! \htmlinclude GFS_checkland_run.html -!! - subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_guess, & - flag_init, flag_restart, frac_grid, isot, ivegsrc, stype, vtype, slope, & - soiltyp, vegtype, slopetyp, dry, icy, wet, lake, ocean, & - oceanfrac, landfrac, lakefrac, slmsk, islmsk, errmsg, errflg ) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in ) :: me - integer, intent(in ) :: master - integer, intent(in ) :: blkno - integer, intent(in ) :: im - integer, intent(in ) :: kdt - integer, intent(in ) :: iter - logical, intent(in ) :: flag_iter(im) - logical, intent(in ) :: flag_guess(im) - logical, intent(in ) :: flag_init - logical, intent(in ) :: flag_restart - logical, intent(in ) :: frac_grid - integer, intent(in ) :: isot - integer, intent(in ) :: ivegsrc - real(kind_phys), intent(in ) :: stype(im) - real(kind_phys), intent(in ) :: vtype(im) - real(kind_phys), intent(in ) :: slope(im) - integer, intent(in ) :: soiltyp(im) - integer, intent(in ) :: vegtype(im) - integer, intent(in ) :: slopetyp(im) - logical, intent(in ) :: dry(im) - logical, intent(in ) :: icy(im) - logical, intent(in ) :: wet(im) - logical, intent(in ) :: lake(im) - logical, intent(in ) :: ocean(im) - real(kind_phys), intent(in ) :: oceanfrac(im) - real(kind_phys), intent(in ) :: landfrac(im) - real(kind_phys), intent(in ) :: lakefrac(im) - real(kind_phys), intent(in ) :: slmsk(im) - integer, intent(in ) :: islmsk(im) - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! Local variables - integer :: i - - errflg = 0 - errmsg = '' - - write(0,'(a,i5)') 'YYY: me :', me - write(0,'(a,i5)') 'YYY: master :', master - write(0,'(a,i5)') 'YYY: blkno :', blkno - write(0,'(a,i5)') 'YYY: im :', im - write(0,'(a,i5)') 'YYY: kdt :', kdt - write(0,'(a,i5)') 'YYY: iter :', iter - write(0,'(a,1x,l)') 'YYY: flag_init :', flag_init - write(0,'(a,1x,l)') 'YYY: flag_restart :', flag_restart - write(0,'(a,1x,l)') 'YYY: frac_grid :', frac_grid - write(0,'(a,i5)') 'YYY: isot :', isot - write(0,'(a,i5)') 'YYY: ivegsrc :', ivegsrc - - do i=1,im - !if (vegtype(i)==15) then - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_iter(i) :', i, blkno, flag_iter(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_guess(i) :', i, blkno, flag_guess(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, stype(i) :', i, blkno, stype(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, vtype(i) :', i, blkno, vtype(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slope(i) :', i, blkno, slope(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, soiltyp(i) :', i, blkno, soiltyp(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, vegtype(i) :', i, blkno, vegtype(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, slopetyp(i) :', i, blkno, slopetyp(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, dry(i) :', i, blkno, dry(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, icy(i) :', i, blkno, icy(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, wet(i) :', i, blkno, wet(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, lake(i) :', i, blkno, lake(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, ocean(i) :', i, blkno, ocean(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, oceanfrac(i) :', i, blkno, oceanfrac(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, landfrac(i) :', i, blkno, landfrac(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, lakefrac(i) :', i, blkno, lakefrac(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slmsk(i) :', i, blkno, slmsk(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, islmsk(i) :', i, blkno, islmsk(i) - !end if - end do - - end subroutine GFS_checkland_run - - end module GFS_checkland diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 index 783d65e90..ca0bc408b 100644 --- a/physics/rrtmg_lw_pre.F90 +++ b/physics/rrtmg_lw_pre.F90 @@ -12,7 +12,17 @@ subroutine rrtmg_lw_pre_init () end subroutine rrtmg_lw_pre_init !> \section arg_table_rrtmg_lw_pre_run Argument Table -!! \htmlinclude rrtmg_lw_pre_run.html +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------|--------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | +!! | Grid | GFS_grid_type_instance | Fortran DDT containing FV3-GFS grid and interpolation related data | DDT | 0 | GFS_grid_type | | in | F | +!! | Sfcprop | GFS_sfcprop_type_instance | Fortran DDT containing FV3-GFS surface fields | DDT | 0 | GFS_sfcprop_type | | in | F | +!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | inout | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | tsfg | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | +!! | tsfa | surface_air_temperature_for_radiation | lowest model layer air temperature for radiation | K | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! subroutine rrtmg_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, errmsg, errflg) @@ -43,7 +53,7 @@ subroutine rrtmg_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, errm !! emissivity for LW radiation. call setemis (Grid%xlon, Grid%xlat, Sfcprop%slmsk, & ! --- inputs Sfcprop%snowd, Sfcprop%sncovr, Sfcprop%zorl, & - tsfg, tsfa, Sfcprop%hprim, IM, & + tsfg, tsfa, Sfcprop%hprime(:,1), IM, & Radtend%semis) ! --- outputs endif diff --git a/physics/rrtmg_sw_pre.F90 b/physics/rrtmg_sw_pre.F90 index de994ba79..41919b1a2 100644 --- a/physics/rrtmg_sw_pre.F90 +++ b/physics/rrtmg_sw_pre.F90 @@ -12,7 +12,24 @@ subroutine rrtmg_sw_pre_init () end subroutine rrtmg_sw_pre_init !> \section arg_table_rrtmg_sw_pre_run Argument Table -!! \htmlinclude rrtmg_sw_pre_run.html +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------|--------------------------------------------------------------------|----------|------|------------------|-----------|--------|----------| +!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | +!! | Grid | GFS_grid_type_instance | Fortran DDT containing FV3-GFS grid and interpolation related data | DDT | 0 | GFS_grid_type | | in | F | +!! | Sfcprop | GFS_sfcprop_type_instance | Fortran DDT containing FV3-GFS surface fields | DDT | 0 | GFS_sfcprop_type | | in | F | +!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | inout | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | nday | daytime_points_dimension | daytime points dimension | count | 0 | integer | | out | F | +!! | idxday | daytime_points | daytime points | index | 1 | integer | | out | F | +!! | tsfg | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | +!! | tsfa | surface_air_temperature_for_radiation | lowest model layer air temperature for radiation | K | 1 | real | kind_phys | in | F | +!! | sfcalb1 | surface_albedo_due_to_near_IR_direct | surface albedo due to near IR direct beam | frac | 1 | real | kind_phys | out | F | +!! | sfcalb2 | surface_albedo_due_to_near_IR_diffused | surface albedo due to near IR diffused beam | frac | 1 | real | kind_phys | out | F | +!! | sfcalb3 | surface_albedo_due_to_UV_and_VIS_direct | surface albedo due to UV+VIS direct beam | frac | 1 | real | kind_phys | out | F | +!! | sfcalb4 | surface_albedo_due_to_UV_and_VIS_diffused | surface albedo due to UV+VIS diffused beam | frac | 1 | real | kind_phys | out | F | +!! | alb1d | surface_albedo_perturbation | surface albedo perturbation | frac | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & nday, idxday, tsfg, tsfa, sfcalb1, sfcalb2, sfcalb3, sfcalb4, & @@ -66,13 +83,13 @@ subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & !> - Call module_radiation_surface::setalb() to setup surface albedo. !! for SW radiation. - call setalb (Sfcprop%slmsk, Sfcprop%snowd, Sfcprop%sncovr,& ! --- inputs: - Sfcprop%snoalb, Sfcprop%zorl, Radtend%coszen,& - tsfg, tsfa, Sfcprop%hprim, Sfcprop%alvsf, & - Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, & - Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & - Sfcprop%tisfc, IM, & - alb1d, Model%pertalb, & ! mg, sfc-perts + call setalb (Sfcprop%slmsk, Sfcprop%snowd, Sfcprop%sncovr, & ! --- inputs: + Sfcprop%snoalb, Sfcprop%zorl, Radtend%coszen, & + tsfg, tsfa, Sfcprop%hprime(:,1), Sfcprop%alvsf, & + Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, & + Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & + Sfcprop%tisfc, IM, & + alb1d, Model%pertalb, & ! mg, sfc-perts sfcalb) ! --- outputs !> -# Approximate mean surface albedo from vis- and nir- diffuse values. From 60a8e10b345833309ffd024799e6a2fb6634f0f3 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Mon, 23 Sep 2019 08:12:37 -0600 Subject: [PATCH 38/59] physics/GFS_debug.F90, physics/rrtmg_lw_pre.F90, physics/rrtmg_sw_pre.F90: follow-up commit to ab96404961a9357dea4c7a2bfce19af80545297c to update changes to new metadata format --- physics/GFS_debug.F90 | 155 ++++++++++++++++++++++++++++----------- physics/rrtmg_lw_pre.F90 | 12 +-- physics/rrtmg_sw_pre.F90 | 19 +---- 3 files changed, 113 insertions(+), 73 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 30a25f93e..17d971c7a 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -3,7 +3,7 @@ module GFS_diagtoscreen private - + public GFS_diagtoscreen_init, GFS_diagtoscreen_run, GFS_diagtoscreen_finalize public print_my_stuff, chksum_int, chksum_real @@ -41,23 +41,7 @@ subroutine GFS_diagtoscreen_finalize () end subroutine GFS_diagtoscreen_finalize !> \section arg_table_GFS_diagtoscreen_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | instance of derived type GFS_control_type in FV3 | DDT | 0 | GFS_control_type | | in | F | -!! | Statein | GFS_statein_type_instance | instance of derived type GFS_statein_type in FV3 | DDT | 0 | GFS_statein_type | | in | F | -!! | Stateout | GFS_stateout_type_instance | instance of derived type GFS_stateout_type | DDT | 0 | GFS_stateout_type | | in | F | -!! | Sfcprop | GFS_sfcprop_type_instance | instance of type GFS_sfcprop_type in FV3 | DDT | 0 | GFS_sfcprop_type | | in | F | -!! | Coupling | GFS_coupling_type_instance | instance of type GFS_coupling_type in FV3 | DDT | 0 | GFS_coupling_type | | in | F | -!! | Grid | GFS_grid_type_instance | instance of type GFS_grid_type in FV3 | DDT | 0 | GFS_grid_type | | in | F | -!! | Tbd | GFS_tbd_type_instance | instance of type GFS_tbd_type in FV3 | DDT | 0 | GFS_tbd_type | | in | F | -!! | Cldprop | GFS_cldprop_type_instance | instance of type GFS_cldprop_type in FV3 | DDT | 0 | GFS_cldprop_type | | in | F | -!! | Radtend | GFS_radtend_type_instance | instance of type GFS_radtend_type in FV3 | DDT | 0 | GFS_radtend_type | | in | F | -!! | Diag | GFS_diag_type_instance | instance of type GFS_diag_type in FV3 | DDT | 0 | GFS_diag_type | | in | F | -!! | Interstitial | GFS_interstitial_type_instance | instance of type GFS_interstitial_type in FV3 | DDT | 0 | GFS_interstitial_type | | in | F | -!! | nthreads | omp_threads | number of OpenMP threads or fast physics schemes | count | 0 | integer | | in | F | -!! | blkno | ccpp_block_number | number of block for explicit data blocking in CCPP | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_diagtoscreen_run.html !! subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, & Grid, Tbd, Cldprop, Radtend, Diag, Interstitial, & @@ -633,7 +617,7 @@ subroutine print_real_2d(mpirank,omprank,blkno,name,var) integer, intent(in) :: mpirank, omprank, blkno character(len=*), intent(in) :: name real(kind_phys), intent(in) :: var(:,:) - + integer :: k, i #ifdef PRINT_SUM @@ -760,7 +744,7 @@ end module GFS_diagtoscreen module GFS_interstitialtoscreen private - + public GFS_interstitialtoscreen_init, GFS_interstitialtoscreen_run, GFS_interstitialtoscreen_finalize contains @@ -772,23 +756,7 @@ subroutine GFS_interstitialtoscreen_finalize () end subroutine GFS_interstitialtoscreen_finalize !> \section arg_table_GFS_interstitialtoscreen_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | instance of derived type GFS_control_type | DDT | 0 | GFS_control_type | | in | F | -!! | Statein | GFS_statein_type_instance | instance of derived type GFS_statein_type | DDT | 0 | GFS_statein_type | | in | F | -!! | Stateout | GFS_stateout_type_instance | instance of derived type GFS_stateout_type | DDT | 0 | GFS_stateout_type | | in | F | -!! | Sfcprop | GFS_sfcprop_type_instance | instance of derived type GFS_sfcprop_type | DDT | 0 | GFS_sfcprop_type | | in | F | -!! | Coupling | GFS_coupling_type_instance | instance of derived type GFS_coupling_type | DDT | 0 | GFS_coupling_type | | in | F | -!! | Grid | GFS_grid_type_instance | instance of derived type GFS_grid_type | DDT | 0 | GFS_grid_type | | in | F | -!! | Tbd | GFS_tbd_type_instance | instance of derived type GFS_tbd_type | DDT | 0 | GFS_tbd_type | | in | F | -!! | Cldprop | GFS_cldprop_type_instance | instance of derived type GFS_cldprop_type | DDT | 0 | GFS_cldprop_type | | in | F | -!! | Radtend | GFS_radtend_type_instance | instance of derived type GFS_radtend_type | DDT | 0 | GFS_radtend_type | | in | F | -!! | Diag | GFS_diag_type_instance | instance of derived type GFS_diag_type | DDT | 0 | GFS_diag_type | | in | F | -!! | Interstitial | GFS_interstitial_type_instance | instance of derived type GFS_interstitial_type | DDT | 0 | GFS_interstitial_type | | in | F | -!! | nthreads | omp_threads | number of OpenMP threads or fast physics schemes | count | 0 | integer | | in | F | -!! | blkno | ccpp_block_number | number of block for explicit data blocking in CCPP | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_interstitialtoscreen_run.html !! subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, & Grid, Tbd, Cldprop, Radtend, Diag, Interstitial, & @@ -888,7 +856,7 @@ end module GFS_interstitialtoscreen module GFS_abort private - + public GFS_abort_init, GFS_abort_run, GFS_abort_finalize contains @@ -900,12 +868,7 @@ subroutine GFS_abort_finalize () end subroutine GFS_abort_finalize !> \section arg_table_GFS_abort_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | instance of derived type GFS_control_type | DDT | 0 | GFS_control_type | | in | F | -!! | blkno | ccpp_block_number | number of block for explicit data blocking in CCPP | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_abort_run.html !! subroutine GFS_abort_run (Model, blkno, errmsg, errflg) @@ -933,3 +896,107 @@ subroutine GFS_abort_run (Model, blkno, errmsg, errflg) end subroutine GFS_abort_run end module GFS_abort + + module GFS_checkland + + private + + public GFS_checkland_init, GFS_checkland_run, GFS_checkland_finalize + + contains + + subroutine GFS_checkland_init () + end subroutine GFS_checkland_init + + subroutine GFS_checkland_finalize () + end subroutine GFS_checkland_finalize + +!> \section arg_table_GFS_checkland_run Argument Table +!! \htmlinclude GFS_checkland_run.html +!! + subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_guess, & + flag_init, flag_restart, frac_grid, isot, ivegsrc, stype, vtype, slope, & + soiltyp, vegtype, slopetyp, dry, icy, wet, lake, ocean, & + oceanfrac, landfrac, lakefrac, slmsk, islmsk, errmsg, errflg ) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in ) :: me + integer, intent(in ) :: master + integer, intent(in ) :: blkno + integer, intent(in ) :: im + integer, intent(in ) :: kdt + integer, intent(in ) :: iter + logical, intent(in ) :: flag_iter(im) + logical, intent(in ) :: flag_guess(im) + logical, intent(in ) :: flag_init + logical, intent(in ) :: flag_restart + logical, intent(in ) :: frac_grid + integer, intent(in ) :: isot + integer, intent(in ) :: ivegsrc + real(kind_phys), intent(in ) :: stype(im) + real(kind_phys), intent(in ) :: vtype(im) + real(kind_phys), intent(in ) :: slope(im) + integer, intent(in ) :: soiltyp(im) + integer, intent(in ) :: vegtype(im) + integer, intent(in ) :: slopetyp(im) + logical, intent(in ) :: dry(im) + logical, intent(in ) :: icy(im) + logical, intent(in ) :: wet(im) + logical, intent(in ) :: lake(im) + logical, intent(in ) :: ocean(im) + real(kind_phys), intent(in ) :: oceanfrac(im) + real(kind_phys), intent(in ) :: landfrac(im) + real(kind_phys), intent(in ) :: lakefrac(im) + real(kind_phys), intent(in ) :: slmsk(im) + integer, intent(in ) :: islmsk(im) + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Local variables + integer :: i + + errflg = 0 + errmsg = '' + + write(0,'(a,i5)') 'YYY: me :', me + write(0,'(a,i5)') 'YYY: master :', master + write(0,'(a,i5)') 'YYY: blkno :', blkno + write(0,'(a,i5)') 'YYY: im :', im + write(0,'(a,i5)') 'YYY: kdt :', kdt + write(0,'(a,i5)') 'YYY: iter :', iter + write(0,'(a,1x,l)') 'YYY: flag_init :', flag_init + write(0,'(a,1x,l)') 'YYY: flag_restart :', flag_restart + write(0,'(a,1x,l)') 'YYY: frac_grid :', frac_grid + write(0,'(a,i5)') 'YYY: isot :', isot + write(0,'(a,i5)') 'YYY: ivegsrc :', ivegsrc + + do i=1,im + !if (vegtype(i)==15) then + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_iter(i) :', i, blkno, flag_iter(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_guess(i) :', i, blkno, flag_guess(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, stype(i) :', i, blkno, stype(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, vtype(i) :', i, blkno, vtype(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slope(i) :', i, blkno, slope(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, soiltyp(i) :', i, blkno, soiltyp(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, vegtype(i) :', i, blkno, vegtype(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, slopetyp(i) :', i, blkno, slopetyp(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, dry(i) :', i, blkno, dry(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, icy(i) :', i, blkno, icy(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, wet(i) :', i, blkno, wet(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, lake(i) :', i, blkno, lake(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, ocean(i) :', i, blkno, ocean(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, oceanfrac(i) :', i, blkno, oceanfrac(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, landfrac(i) :', i, blkno, landfrac(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, lakefrac(i) :', i, blkno, lakefrac(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slmsk(i) :', i, blkno, slmsk(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, islmsk(i) :', i, blkno, islmsk(i) + !end if + end do + + end subroutine GFS_checkland_run + + end module GFS_checkland diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 index ca0bc408b..5f128a79a 100644 --- a/physics/rrtmg_lw_pre.F90 +++ b/physics/rrtmg_lw_pre.F90 @@ -12,17 +12,7 @@ subroutine rrtmg_lw_pre_init () end subroutine rrtmg_lw_pre_init !> \section arg_table_rrtmg_lw_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------|--------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | -!! | Grid | GFS_grid_type_instance | Fortran DDT containing FV3-GFS grid and interpolation related data | DDT | 0 | GFS_grid_type | | in | F | -!! | Sfcprop | GFS_sfcprop_type_instance | Fortran DDT containing FV3-GFS surface fields | DDT | 0 | GFS_sfcprop_type | | in | F | -!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | inout | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | tsfg | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | tsfa | surface_air_temperature_for_radiation | lowest model layer air temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude rrtmg_lw_pre_run.html !! subroutine rrtmg_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, errmsg, errflg) diff --git a/physics/rrtmg_sw_pre.F90 b/physics/rrtmg_sw_pre.F90 index 41919b1a2..8eeb16430 100644 --- a/physics/rrtmg_sw_pre.F90 +++ b/physics/rrtmg_sw_pre.F90 @@ -12,24 +12,7 @@ subroutine rrtmg_sw_pre_init () end subroutine rrtmg_sw_pre_init !> \section arg_table_rrtmg_sw_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------|--------------------------------------------------------------------|----------|------|------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | -!! | Grid | GFS_grid_type_instance | Fortran DDT containing FV3-GFS grid and interpolation related data | DDT | 0 | GFS_grid_type | | in | F | -!! | Sfcprop | GFS_sfcprop_type_instance | Fortran DDT containing FV3-GFS surface fields | DDT | 0 | GFS_sfcprop_type | | in | F | -!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | inout | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | nday | daytime_points_dimension | daytime points dimension | count | 0 | integer | | out | F | -!! | idxday | daytime_points | daytime points | index | 1 | integer | | out | F | -!! | tsfg | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | tsfa | surface_air_temperature_for_radiation | lowest model layer air temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | sfcalb1 | surface_albedo_due_to_near_IR_direct | surface albedo due to near IR direct beam | frac | 1 | real | kind_phys | out | F | -!! | sfcalb2 | surface_albedo_due_to_near_IR_diffused | surface albedo due to near IR diffused beam | frac | 1 | real | kind_phys | out | F | -!! | sfcalb3 | surface_albedo_due_to_UV_and_VIS_direct | surface albedo due to UV+VIS direct beam | frac | 1 | real | kind_phys | out | F | -!! | sfcalb4 | surface_albedo_due_to_UV_and_VIS_diffused | surface albedo due to UV+VIS diffused beam | frac | 1 | real | kind_phys | out | F | -!! | alb1d | surface_albedo_perturbation | surface albedo perturbation | frac | 1 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude rrtmg_sw_pre_run.html !! subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & nday, idxday, tsfg, tsfa, sfcalb1, sfcalb2, sfcalb3, sfcalb4, & From 3e38cf6429e0580f7e922221d82d22a3a4331ff1 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 27 Sep 2019 17:04:48 -0600 Subject: [PATCH 39/59] First pass through GFSv16 updates, excluding SHOC and NoahMP --- physics/GFS_DCNV_generic.F90 | 62 +- physics/GFS_DCNV_generic.meta | 67 +- physics/GFS_GWD_generic.F90 | 8 +- physics/GFS_GWD_generic.meta | 9 - physics/GFS_MP_generic.F90 | 3 +- physics/GFS_PBL_generic.F90 | 96 +- physics/GFS_PBL_generic.meta | 8 + physics/GFS_SCNV_generic.F90 | 22 +- physics/GFS_SCNV_generic.meta | 16 - physics/GFS_debug.F90 | 19 +- physics/GFS_rrtmg_post.F90 | 7 - physics/GFS_suite_interstitial.F90 | 104 +- physics/GFS_suite_interstitial.meta | 103 +- physics/GFS_surface_composites.F90 | 259 +++-- physics/GFS_surface_composites.meta | 127 ++- physics/GFS_surface_generic.F90 | 117 +-- physics/GFS_surface_generic.meta | 105 +- physics/GFS_surface_loop_control.F90 | 3 +- physics/cires_ugwp.F90 | 310 ++++-- physics/cires_ugwp.meta | 100 +- physics/cires_ugwp_initialize.F90 | 70 +- physics/cires_ugwp_post.F90 | 28 +- physics/cires_ugwp_post.meta | 62 +- physics/cires_ugwp_triggers.F90 | 107 +- physics/cs_conv.F90 | 14 +- physics/dcyc2.f | 91 +- physics/dcyc2.meta | 96 +- physics/docs/pdftxt/suite_input.nml.txt | 1 - physics/gfdl_cloud_microphys.F90 | 9 +- physics/gfdl_cloud_microphys.meta | 8 + physics/gfdl_fv_sat_adj.F90 | 15 +- physics/gwdc.f | 11 +- physics/gwdc.meta | 8 + physics/gwdps.f | 145 ++- physics/gwdps.meta | 2 +- physics/machine.F | 2 - physics/module_gfdl_cloud_microphys.F90 | 191 ++-- physics/module_nst_water_prop.f90 | 15 +- physics/set_soilveg.f | 5 +- physics/sfc_cice.f | 68 +- physics/sfc_cice.meta | 62 +- physics/sfc_diff.f | 676 ++++++------- physics/sfc_diff.meta | 45 +- physics/sfc_drv.f | 22 +- physics/sfc_drv.meta | 32 +- physics/sfc_nst.f | 247 +++-- physics/sfc_nst.meta | 258 +---- physics/sfc_ocean.F | 28 +- physics/sfc_ocean.meta | 24 +- physics/sfc_sice.f | 33 +- physics/sfc_sice.meta | 50 +- physics/sfcsub.F | 199 ++-- physics/sflx.f | 102 +- .../{ugwp_driver_v0.f => ugwp_driver_v0.F} | 913 ++++++++++-------- 54 files changed, 2957 insertions(+), 2227 deletions(-) rename physics/{ugwp_driver_v0.f => ugwp_driver_v0.F} (74%) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index c2e98e966..0acfbd19e 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -17,9 +17,9 @@ end subroutine GFS_DCNV_generic_pre_finalize !! \htmlinclude GFS_DCNV_generic_pre_run.html !! #endif - subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, cnvgwd, lgocart, do_ca, & - isppt_deep, gu0, gv0, gt0, gq0_water_vapor, & - save_u, save_v, save_t, save_qv, ca_deep, & + subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, do_cnvgwd, do_ca, & + isppt_deep, gu0, gv0, gt0, gq0_water_vapor, & + save_u, save_v, save_t, save_qv, ca_deep, & errmsg, errflg) use machine, only: kind_phys @@ -27,7 +27,7 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, cnvgwd, lgocart, do_ca, implicit none integer, intent(in) :: im, levs - logical, intent(in) :: ldiag3d, cnvgwd, lgocart, do_ca, isppt_deep + logical, intent(in) :: ldiag3d, do_cnvgwd, do_ca, isppt_deep real(kind=kind_phys), dimension(im,levs), intent(in) :: gu0 real(kind=kind_phys), dimension(im,levs), intent(in) :: gv0 real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0 @@ -62,13 +62,21 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, cnvgwd, lgocart, do_ca, save_v(i,k) = gv0(i,k) enddo enddo - elseif (cnvgwd) then - save_t(1:im,:) = gt0(1:im,:) - endif ! end if_ldiag3d/cnvgwd + elseif (do_cnvgwd) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + enddo + enddo + endif - if (ldiag3d .or. lgocart .or. isppt_deep) then - save_qv(1:im,:) = gq0_water_vapor(1:im,:) - endif ! end if_ldiag3d/lgocart + if (ldiag3d .or. isppt_deep) then + do k=1,levs + do i=1,im + save_qv(i,k) = gq0_water_vapor(i,k) + enddo + enddo + endif end subroutine GFS_DCNV_generic_pre_run @@ -87,11 +95,11 @@ end subroutine GFS_DCNV_generic_post_finalize !> \section arg_table_GFS_DCNV_generic_post_run Argument Table !! \htmlinclude GFS_DCNV_generic_post_run.html !! - subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, lgocart, ras, cscnv, do_ca, & + subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, ras, cscnv, do_ca, & isppt_deep, frain, rain1, dtf, cld1d, save_u, save_v, save_t, save_qv, gu0, gv0, gt0, & gq0_water_vapor, ud_mf, dd_mf, dt_mf, con_g, clw_ice, clw_liquid, npdf3d, num_p3d, ncnvcld3d, & - rainc, cldwrk, dt3dt, dq3dt, du3dt, dv3dt, upd_mf, dwn_mf, det_mf, dqdti, & - cnvqci, upd_mfi, dwn_mfi, det_mfi, cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, & + rainc, cldwrk, dt3dt, dq3dt, du3dt, dv3dt, upd_mf, dwn_mf, det_mf, & + cnvw, cnvc, cnvw_phy_f3d, cnvc_phy_f3d, & cape, tconvtend, qconvtend, uconvtend, vconvtend, errmsg, errflg) use machine, only: kind_phys @@ -99,7 +107,7 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, lgocart, ras, cs implicit none integer, intent(in) :: im, levs - logical, intent(in) :: lssav, ldiag3d, lgocart, ras, cscnv, do_ca, isppt_deep + logical, intent(in) :: lssav, ldiag3d, ras, cscnv, do_ca, isppt_deep real(kind=kind_phys), intent(in) :: frain, dtf real(kind=kind_phys), dimension(im), intent(in) :: rain1, cld1d @@ -114,8 +122,6 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, lgocart, ras, cs ! dt3dt, dq3dt, du3dt, dv3dt upd_mf, dwn_mf, det_mf only allocated if ldiag3d == .true. real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt, dq3dt, du3dt, dv3dt real(kind=kind_phys), dimension(:,:), intent(inout) :: upd_mf, dwn_mf, det_mf - ! dqdti, cnvqci, upd_mfi, dwn_mfi, det_mfi only allocated if ldiag3d == .true. or lgocart == .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti, cnvqci, upd_mfi, dwn_mfi, det_mfi real(kind=kind_phys), dimension(im,levs), intent(inout) :: cnvw, cnvc ! The following arrays may not be allocated, depending on certain flags and microphysics schemes. ! Since Intel 15 crashes when passing unallocated arrays to arrays defined with explicit shape, @@ -186,24 +192,16 @@ subroutine GFS_DCNV_generic_post_run (im, levs, lssav, ldiag3d, lgocart, ras, cs endif ! if (lssav) - !update dqdt_v to include moisture tendency due to deep convection -! if (lgocart) then -! do k=1,levs -! do i=1,im -! dqdti (i,k) = (gq0_water_vapor(i,k) - save_qv(i,k)) * frain -! upd_mfi(i,k) = upd_mfi(i,k) + ud_mf(i,k) * frain -! dwn_mfi(i,k) = dwn_mfi(i,k) + dd_mf(i,k) * frain -! det_mfi(i,k) = det_mfi(i,k) + dt_mf(i,k) * frain -! cnvqci (i,k) = cnvqci (i,k) + (clw_ice(i,k)+clw_liquid(i,k))*frain -! enddo -! enddo -! endif ! if (lgocart) if (isppt_deep) then - tconvtend = gt0 - save_t - qconvtend = gq0_water_vapor - save_qv - uconvtend = gu0 - save_u - vconvtend = gv0 - save_v + do k=1,levs + do i=1,im + tconvtend(i,k) = gt0(i,k) - save_t(i,k) + qconvtend(i,k) = gq0_water_vapor(i,k) - save_qv(i,k) + uconvtend(i,k) = gu0(i,k) - save_u(i,k) + vconvtend(i,k) = gv0(i,k) - save_v(i,k) + enddo + enddo endif end subroutine GFS_DCNV_generic_post_run diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 1aee22322..eae53a910 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -25,17 +25,9 @@ type = logical intent = in optional = F -[cnvgwd] - standard_name = flag_convective_gravity_wave_drag - long_name = flag for conv gravity wave drag - units = flag - dimensions = () - type = logical - intent = in - optional = F -[lgocart] - standard_name = flag_gocart - long_name = flag for 3d diagnostic fields for gocart 1 +[do_cnvgwd] + standard_name = flag_for_convective_gravity_wave_drag + long_name = flag for convective gravity wave drag (gwd) units = flag dimensions = () type = logical @@ -192,14 +184,6 @@ type = logical intent = in optional = F -[lgocart] - standard_name = flag_gocart - long_name = flag for 3d diagnostic fields for gocart 1 - units = flag - dimensions = () - type = logical - intent = in - optional = F [ras] standard_name = flag_for_ras_deep_convection long_name = flag for ras convection scheme @@ -499,51 +483,6 @@ kind = kind_phys intent = inout optional = F -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[cnvqci] - standard_name = instantaneous_deep_convective_cloud_condensate_mixing_ratio_on_dynamics_time_step - long_name = instantaneous total convective condensate mixing ratio - units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[upd_mfi] - standard_name = instantaneous_atmosphere_updraft_convective_mass_flux_on_dynamics_timestep - long_name = (updraft mass flux) * delt - units = kg m-2 - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dwn_mfi] - standard_name = instantaneous_atmosphere_downdraft_convective_mass_flux_on_dynamics_timestep - long_name = (downdraft mass flux) * delt - units = kg m-2 - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[det_mfi] - standard_name = instantaneous_atmosphere_detrainment_convective_mass_flux_on_dynamics_timestep - long_name = (detrainment mass flux) * delt - units = kg m-2 - dimensions = (horizontal_dimension,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [cnvw] standard_name = convective_cloud_water_mixing_ratio long_name = moist convective cloud water mixing ratio diff --git a/physics/GFS_GWD_generic.F90 b/physics/GFS_GWD_generic.F90 index 07606c051..60ae1deec 100644 --- a/physics/GFS_GWD_generic.F90 +++ b/physics/GFS_GWD_generic.F90 @@ -19,7 +19,7 @@ end subroutine GFS_GWD_generic_pre_init !! @{ subroutine GFS_GWD_generic_pre_run( & & im, levs, nmtvr, mntvar, & - & hprime, oc, oa4, clx, theta, & + & oc, oa4, clx, theta, & & sigma, gamma, elvmax, lssav, ldiag3d, & & dtdt, dt3dt, dtf, errmsg, errflg) @@ -30,7 +30,7 @@ subroutine GFS_GWD_generic_pre_run( & real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) real(kind=kind_phys), intent(out) :: & - & hprime(im), oc(im), oa4(im,4), clx(im,4), & + & oc(im), oa4(im,4), clx(im,4), & & theta(im), sigma(im), gamma(im), elvmax(im) logical, intent(in) :: lssav, ldiag3d @@ -49,7 +49,6 @@ subroutine GFS_GWD_generic_pre_run( & errflg = 0 if (nmtvr == 14) then ! current operational - as of 2014 - hprime(:) = mntvar(:,1) oc(:) = mntvar(:,2) oa4(:,1) = mntvar(:,3) oa4(:,2) = mntvar(:,4) @@ -64,7 +63,6 @@ subroutine GFS_GWD_generic_pre_run( & sigma(:) = mntvar(:,13) elvmax(:) = mntvar(:,14) elseif (nmtvr == 10) then - hprime(:) = mntvar(:,1) oc(:) = mntvar(:,2) oa4(:,1) = mntvar(:,3) oa4(:,2) = mntvar(:,4) @@ -75,7 +73,6 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,3) = mntvar(:,9) clx(:,4) = mntvar(:,10) elseif (nmtvr == 6) then - hprime(:) = mntvar(:,1) oc(:) = mntvar(:,2) oa4(:,1) = mntvar(:,3) oa4(:,2) = mntvar(:,4) @@ -86,7 +83,6 @@ subroutine GFS_GWD_generic_pre_run( & clx(:,3) = 0.0 clx(:,4) = 0.0 else - hprime = 0 oc = 0 oa4 = 0 clx = 0 diff --git a/physics/GFS_GWD_generic.meta b/physics/GFS_GWD_generic.meta index be493b80b..e3d14c268 100644 --- a/physics/GFS_GWD_generic.meta +++ b/physics/GFS_GWD_generic.meta @@ -39,15 +39,6 @@ kind = kind_phys intent = in optional = F -[hprime] - standard_name = standard_deviation_of_subgrid_orography - long_name = standard deviation of subgrid orography - units = m - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F [oc] standard_name = convexity_of_subgrid_orography long_name = convexity of subgrid orography diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index b83f592f2..66357844f 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -303,6 +303,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt elseif( .not. cal_pre) then if (imp_physics == imp_physics_mg) then ! MG microphysics do i=1,im + tprcp(i) = max(0.0, rain(i) ) ! clu: rain -> tprcp if (rain(i)*tem > rainmin) then srflag(i) = max(zero, min(one, (rain(i)-rainc(i))*sr(i)/rain(i))) else @@ -311,7 +312,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt enddo else do i = 1, im - tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp + tprcp(i) = max(0.0, rain(i) ) ! clu: rain -> tprcp srflag(i) = 0.0 ! clu: default srflag as 'rain' (i.e. 0) if (t850(i) <= 273.16) then srflag(i) = 1.0 ! clu: set srflag to 'snow' (i.e. 1) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 9eb707311..471978d07 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -112,6 +112,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, vdftra(i,k,12) = qgrs(i,k,ntoz) enddo enddo + kk = 12 else ! MG2 do k=1,levs do i=1,im @@ -127,6 +128,17 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, vdftra(i,k,10) = qgrs(i,k,ntoz) enddo enddo + kk = 10 + endif + if (trans_aero) then + do n=ntchs,ntchm+ntchs-1 + kk = kk + 1 + do k=1,levs + do i=1,im + vdftra(i,k,kk) = qgrs(i,k,n) + enddo + enddo + enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP @@ -205,7 +217,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, & dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, dq3dt, & dq3dt_ozone, rd, cp,fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, fice, dusfc_cice, dvsfc_cice, dtsfc_cice, & - dqsfc_cice, dry, icy, wind, stress_ocn, hflx_ocn, evap_ocn, ugrs1, vgrs1, dkt_cpl, dkt, errmsg, errflg) + dqsfc_cice, wet, dry, icy, wind, stress_ocn, hflx_ocn, evap_ocn, ugrs1, vgrs1, dkt_cpl, dkt, errmsg, errflg) use machine, only: kind_phys @@ -239,7 +251,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, real(kind=kind_phys), dimension(:), intent(inout) :: dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, & dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag - logical, dimension(:),intent(in) :: dry, icy + logical, dimension(:),intent(in) :: wet, dry, icy real(kind=kind_phys), dimension(:), intent(out) :: ushfsfci real(kind=kind_phys), dimension(:,:), intent(inout) :: dkt_cpl @@ -325,6 +337,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,12) enddo enddo + kk = 12 else ! MG2 do k=1,levs do i=1,im @@ -340,6 +353,17 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,10) enddo enddo + kk = 10 + endif + if (trans_aero) then + do n=ntchs,ntchm+ntchs-1 + kk = kk + 1 + do k=1,levs + do i=1,im + dqdt(i,k,n) = dvdftra(i,k,kk) + enddo + enddo + enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP do k=1,levs @@ -398,29 +422,32 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if (cplflx) then do i=1,im if (oceanfrac(i) > 0.0) then ! Ocean only, NO LAKES - if (fice(i) == 1.0) then ! use results from CICE - dusfci_cpl(i) = dusfc_cice(i) - dvsfci_cpl(i) = dvsfc_cice(i) - dtsfci_cpl(i) = dtsfc_cice(i) - dqsfci_cpl(i) = dqsfc_cice(i) - elseif (dry(i) .or. icy(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point - tem1 = max(q1(i), 1.e-8) - rho = prsl(i,1) / (rd*t1(i)*(1.0+fvirt*tem1)) - if (wind(i) > 0.0) then - tem = - rho * stress_ocn(i) / wind(i) - dusfci_cpl(i) = tem * ugrs1(i) ! U-momentum flux - dvsfci_cpl(i) = tem * vgrs1(i) ! V-momentum flux - else - dusfci_cpl(i) = 0.0 - dvsfci_cpl(i) = 0.0 +! if (fice(i) == ceanfrac(i)) then ! use results from CICE +! dusfci_cpl(i) = dusfc_cice(i) +! dvsfci_cpl(i) = dvsfc_cice(i) +! dtsfci_cpl(i) = dtsfc_cice(i) +! dqsfci_cpl(i) = dqsfc_cice(i) +! elseif (dry(i) .or. icy(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point + if (wet(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point + if (icy(i) .or. dry(i)) then + tem1 = max(q1(i), 1.e-8) + rho = prsl(i,1) / (rd*t1(i)*(1.0+fvirt*tem1)) + if (wind(i) > 0.0) then + tem = - rho * stress_ocn(i) / wind(i) + dusfci_cpl(i) = tem * ugrs1(i) ! U-momentum flux + dvsfci_cpl(i) = tem * vgrs1(i) ! V-momentum flux + else + dusfci_cpl(i) = 0.0 + dvsfci_cpl(i) = 0.0 + endif + dtsfci_cpl(i) = cp * rho * hflx_ocn(i) ! sensible heat flux over open ocean + dqsfci_cpl(i) = hvap * rho * evap_ocn(i) ! latent heat flux over open ocean + else ! use results from PBL scheme for 100% open ocean + dusfci_cpl(i) = dusfc1(i) + dvsfci_cpl(i) = dvsfc1(i) + dtsfci_cpl(i) = dtsfc1(i) + dqsfci_cpl(i) = dqsfc1(i) endif - dtsfci_cpl(i) = cp * rho * hflx_ocn(i) ! sensible heat flux over open ocean - dqsfci_cpl(i) = hvap * rho * evap_ocn(i) ! latent heat flux over open ocean - else ! use results from PBL scheme for 100% open ocean - dusfci_cpl(i) = dusfc1(i) - dvsfci_cpl(i) = dvsfc1(i) - dtsfci_cpl(i) = dtsfc1(i) - dqsfci_cpl(i) = dqsfc1(i) endif ! dusfc_cpl (i) = dusfc_cpl(i) + dusfci_cpl(i) * dtf @@ -468,27 +495,6 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dv3dt_OGWD(i,k) = dv3dt_OGWD(i,k) - dvdt(i,k) * dtf enddo enddo - ! update dqdt_v to include moisture tendency due to vertical diffusion - ! if (lgocart) then - ! do k=1,levs - ! do i=1,im - ! dqdt_v(i,k) = dqdt(i,k,1) * dtf - ! enddo - ! enddo - ! endif -! do k=1,levs -! do i=1,im -! tem = dqdt(i,k,ntqv) * dtf -! dq3dt(i,k) = dq3dt(i,k) + tem -! enddo -! enddo -! if (ntoz > 0) then -! do k=1,levs -! do i=1,im -! dq3dt_ozone(i,k) = dq3dt_ozone(i,k) + dqdt(i,k,ntoz) * dtf -! enddo -! enddo -! endif endif endif ! end if_lssav diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index ddae5b5bd..25e696add 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -1092,6 +1092,14 @@ kind = kind_phys intent = in optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index f01fdad5f..9e70fda76 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -14,7 +14,7 @@ end subroutine GFS_SCNV_generic_pre_finalize !> \section arg_table_GFS_SCNV_generic_pre_run Argument Table !! \htmlinclude GFS_SCNV_generic_pre_run.html !! - subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, lgocart, gt0, gq0_water_vapor, & + subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, gt0, gq0_water_vapor, & save_t, save_qv, errmsg, errflg) use machine, only: kind_phys @@ -22,7 +22,7 @@ subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, lgocart, gt0, gq0_water_ implicit none integer, intent(in) :: im, levs - logical, intent(in) :: ldiag3d, lgocart + logical, intent(in) :: ldiag3d real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0, gq0_water_vapor real(kind=kind_phys), dimension(im,levs), intent(inout) :: save_t, save_qv @@ -42,7 +42,7 @@ subroutine GFS_SCNV_generic_pre_run (im, levs, ldiag3d, lgocart, gt0, gq0_water_ enddo enddo endif -! if (ldiag3d .or. lgocart) then +! if (ldiag3d) then ! do k=1,levs ! do i=1,im ! save_qv(i,k) = gq0_water_vapor(i,k) @@ -67,7 +67,7 @@ end subroutine GFS_SCNV_generic_post_finalize !> \section arg_table_GFS_SCNV_generic_post_run Argument Table !! \htmlinclude GFS_SCNV_generic_post_run.html !! - subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, lgocart, cplchm, & + subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, cplchm, & frain, gt0, gq0_water_vapor, save_t, save_qv, dqdti, dt3dt, dq3dt, clw, errmsg, errflg) use machine, only: kind_phys @@ -75,14 +75,13 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, lgocart, cpl implicit none integer, intent(in) :: im, levs, nn - logical, intent(in) :: lssav, ldiag3d, lgocart, cplchm + logical, intent(in) :: lssav, ldiag3d, cplchm real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0, gq0_water_vapor real(kind=kind_phys), dimension(im,levs), intent(in) :: save_t, save_qv - ! dqdti only allocated if ldiag3d == .true. or lgocart == .true. + ! dqdti, dt3dt, dq3dt, only allocated if ldiag3d == .true. real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti - ! dt3dt, dq3dt, only allocated if ldiag3d == .true. real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt, dq3dt real(kind=kind_phys), dimension(im,levs,nn), intent(inout) :: clw @@ -97,15 +96,6 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, lgocart, cpl errflg = 0 if (lssav) then -! update dqdt_v to include moisture tendency due to shallow convection - if (lgocart .and. .not.cplchm) then - do k=1,levs - do i=1,im - tem = (gq0_water_vapor(i,k)-save_qv(i,k)) * frain - dqdti(i,k) = dqdti(i,k) + tem - enddo - enddo - endif if (ldiag3d) then do k=1,levs do i=1,im diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 93c4a43df..a2763e4bb 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -25,14 +25,6 @@ type = logical intent = in optional = F -[lgocart] - standard_name = flag_gocart - long_name = flag for 3d diagnostic fields for gocart 1 - units = flag - dimensions = () - type = logical - intent = in - optional = F [gt0] standard_name = air_temperature_updated_by_physics long_name = temperature updated by physics @@ -131,14 +123,6 @@ type = logical intent = in optional = F -[lgocart] - standard_name = flag_gocart - long_name = flag for 3d diagnostic fields for gocart 1 - units = flag - dimensions = () - type = logical - intent = in - optional = F [cplchm] standard_name = flag_for_chemistry_coupling long_name = flag controlling cplchm collection (default off) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 17d971c7a..df56cc069 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -6,7 +6,7 @@ module GFS_diagtoscreen public GFS_diagtoscreen_init, GFS_diagtoscreen_run, GFS_diagtoscreen_finalize - public print_my_stuff, chksum_int, chksum_real + public print_my_stuff, chksum_int, chksum_real, print_var ! Calculating the checksum leads to segmentation faults with gfortran (bug in malloc?), ! thus print the sum of the array instead of the checksum. @@ -130,7 +130,6 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Sfcprop%zorlo' , Sfcprop%zorlo) call print_var(mpirank,omprank, blkno, 'Sfcprop%zorll' , Sfcprop%zorll) call print_var(mpirank,omprank, blkno, 'Sfcprop%fice' , Sfcprop%fice) -! call print_var(mpirank,omprank, blkno, 'Sfcprop%hprim' , Sfcprop%hprim) call print_var(mpirank,omprank, blkno, 'Sfcprop%hprime' , Sfcprop%hprime) call print_var(mpirank,omprank, blkno, 'Sfcprop%sncovr' , Sfcprop%sncovr) call print_var(mpirank,omprank, blkno, 'Sfcprop%snoalb' , Sfcprop%snoalb) @@ -233,7 +232,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Tbd%drain_cpl' , Tbd%drain_cpl) call print_var(mpirank,omprank, blkno, 'Tbd%dsnow_cpl' , Tbd%dsnow_cpl) end if - call print_var(mpirank,omprank, blkno, 'Tbd%phy_fctd' , Tbd%phy_fctd) + if (Model%nctp > 0 .and. Model%cscnv) then + call print_var(mpirank,omprank, blkno, 'Tbd%phy_fctd' , Tbd%phy_fctd) + end if call print_var(mpirank,omprank, blkno, 'Tbd%phy_f2d' , Tbd%phy_f2d) call print_var(mpirank,omprank, blkno, 'Tbd%phy_f3d' , Tbd%phy_f3d) do n=1,size(Tbd%phy_f3d(1,1,:)) @@ -397,7 +398,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Coupling%sfcdsw ', Coupling%sfcdsw ) call print_var(mpirank,omprank, blkno, 'Coupling%sfcnsw ', Coupling%sfcnsw ) call print_var(mpirank,omprank, blkno, 'Coupling%sfcdlw ', Coupling%sfcdlw ) - if (Model%cplflx .or. Model%do_sppt) then + if (Model%cplflx .or. Model%do_sppt .or. Model%cplchm) then call print_var(mpirank,omprank, blkno, 'Coupling%rain_cpl', Coupling%rain_cpl) call print_var(mpirank,omprank, blkno, 'Coupling%snow_cpl', Coupling%snow_cpl) end if @@ -453,10 +454,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Coupling%psurfi_cpl ', Coupling%psurfi_cpl ) end if if (Model%cplchm) then - call print_var(mpirank,omprank, blkno, 'Coupling%rain_cpl ', Coupling%rain_cpl ) call print_var(mpirank,omprank, blkno, 'Coupling%rainc_cpl', Coupling%rainc_cpl) call print_var(mpirank,omprank, blkno, 'Coupling%ushfsfci ', Coupling%ushfsfci ) call print_var(mpirank,omprank, blkno, 'Coupling%dkt ', Coupling%dkt ) + call print_var(mpirank,omprank, blkno, 'Coupling%dqdti ', Coupling%dqdti ) end if if (Model%do_sppt) then call print_var(mpirank,omprank, blkno, 'Coupling%sppt_wts', Coupling%sppt_wts) @@ -471,14 +472,6 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, if (Model%do_sfcperts) then call print_var(mpirank,omprank, blkno, 'Coupling%sfc_wts', Coupling%sfc_wts) end if - if (Model%lgocart .or. Model%ldiag3d) then - call print_var(mpirank,omprank, blkno, 'Coupling%dqdti ', Coupling%dqdti ) - call print_var(mpirank,omprank, blkno, 'Coupling%cnvqci ', Coupling%cnvqci ) - call print_var(mpirank,omprank, blkno, 'Coupling%upd_mfi', Coupling%upd_mfi) - call print_var(mpirank,omprank, blkno, 'Coupling%dwn_mfi', Coupling%dwn_mfi) - call print_var(mpirank,omprank, blkno, 'Coupling%det_mfi', Coupling%det_mfi) - call print_var(mpirank,omprank, blkno, 'Coupling%cldcovi', Coupling%cldcovi) - end if if(Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then call print_var(mpirank,omprank, blkno, 'Coupling%nwfa2d', Coupling%nwfa2d) call print_var(mpirank,omprank, blkno, 'Coupling%nifa2d', Coupling%nifa2d) diff --git a/physics/GFS_rrtmg_post.F90 b/physics/GFS_rrtmg_post.F90 index 14f148aa4..dd9b9191e 100644 --- a/physics/GFS_rrtmg_post.F90 +++ b/physics/GFS_rrtmg_post.F90 @@ -166,13 +166,6 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, & enddo endif -! if (.not. Model%uni_cld) then - if (Model%lgocart .or. Model%ldiag3d) then - do k = 1, LM - k1 = k + kd - Coupling%cldcovi(1:im,k) = clouds1(1:im,k1) - enddo - endif endif ! end_if_lssav ! end subroutine GFS_rrtmg_post_run diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 6ecc5925f..6ec16f8b9 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -84,7 +84,7 @@ end subroutine GFS_suite_interstitial_1_finalize !! \htmlinclude GFS_suite_interstitial_1_run.html !! subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & - frain, islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dtdtc, dqdt, errmsg, errflg) + islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dtdtc, dqdt, errmsg, errflg) use machine, only: kind_phys @@ -95,7 +95,6 @@ subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, real(kind=kind_phys), intent(in) :: dtf, dtp, dxmin, dxinv real(kind=kind_phys), intent(in), dimension(im) :: slmsk, area, pgr - real(kind=kind_phys), intent(out) :: frain integer, intent(out), dimension(im) :: islmsk real(kind=kind_phys), intent(out), dimension(im) :: work1, work2, psurf real(kind=kind_phys), intent(out), dimension(im,levs) :: dudt, dvdt, dtdt, dtdtc @@ -110,8 +109,6 @@ subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, errmsg = '' errflg = 0 - frain = dtf / dtp - do i = 1, im islmsk(i) = nint(slmsk(i)) @@ -144,6 +141,9 @@ end module GFS_suite_interstitial_1 module GFS_suite_interstitial_2 + use machine, only: kind_phys + real(kind=kind_phys), parameter :: one = 1.0d0 + contains subroutine GFS_suite_interstitial_2_init () @@ -156,33 +156,40 @@ end subroutine GFS_suite_interstitial_2_finalize !! \htmlinclude GFS_suite_interstitial_2_run.html !! #endif - subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplflx, flag_cice, shal_cnv, old_monin, mstrat, & - do_shoc, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, work1, work2, & - prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, & - suntim, adjsfculw, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, ctei_rml, & - ctei_r, kinver, errmsg, errflg) - - use machine, only: kind_phys + subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplflx, flag_cice, shal_cnv, old_monin, mstrat, & + do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & + work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & + adjsfculw_ice, adjsfculw_ocn, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, & + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, errmsg, errflg) implicit none ! interface variables - integer, intent(in) :: im, levs, imfshalcnv - logical, intent(in) :: lssav, ldiag3d, lsidea, cplflx, shal_cnv, old_monin, mstrat, do_shoc - real(kind=kind_phys), intent(in) :: dtf, cp, hvap - - logical, intent(in), dimension(im) :: flag_cice - real(kind=kind_phys), intent(in), dimension(2) :: ctei_rm - real(kind=kind_phys), intent(in), dimension(im) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, ulwsfc_cice, work1, work2 - real(kind=kind_phys), intent(in), dimension(im, levs) :: htrsw, htrlw, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk - real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi - real(kind=kind_phys), intent(in), dimension(im, levs, 6) :: lwhd + integer, intent(in ) :: im, levs, imfshalcnv + logical, intent(in ) :: lssav, ldiag3d, lsidea, cplflx, shal_cnv + logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid + real(kind=kind_phys), intent(in ) :: dtf, cp, hvap + + logical, intent(in ), dimension(im) :: flag_cice + real(kind=kind_phys), intent(in ), dimension(2) :: ctei_rm + real(kind=kind_phys), intent(in ), dimension(im) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, ulwsfc_cice, work1, work2 + real(kind=kind_phys), intent(in ), dimension(im) :: cice + real(kind=kind_phys), intent(in ), dimension(im, levs) :: htrsw, htrlw, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk + real(kind=kind_phys), intent(in ), dimension(im, levs+1) :: prsi + real(kind=kind_phys), intent(in ), dimension(im, levs, 6) :: lwhd integer, intent(inout), dimension(im) :: kinver - real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, adjsfculw, ctei_rml, ctei_r + real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r + real(kind=kind_phys), intent(in ), dimension(im) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_ocn + real(kind=kind_phys), intent( out), dimension(im) :: adjsfculw + ! These arrays are only allocated if ldiag3d is .true. real(kind=kind_phys), intent(inout), dimension(:,:) :: dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp + logical, intent(in ), dimension(im) :: dry, icy, wet + real(kind=kind_phys), intent(in ), dimension(im) :: frland + real(kind=kind_phys), intent(in ) :: huge + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -217,11 +224,45 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl enddo ! --- ... sfc lw fluxes used by atmospheric model are saved for output - if (cplflx) then + + if (frac_grid) then do i=1,im - if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i) + tem = one - cice(i) - frland(i) + if (flag_cice(i)) then + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + ulwsfc_cice(i) * cice(i) & + + adjsfculw_ocn(i) * tem + else + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + adjsfculw_ice(i) * cice(i) & + + adjsfculw_ocn(i) * tem + endif + enddo + else + do i=1,im + if (dry(i)) then ! all land + adjsfculw(i) = adjsfculw_lnd(i) + elseif (icy(i)) then ! ice (and water) + tem = one - cice(i) + if (flag_cice(i)) then + if (wet(i) .and. adjsfculw_ocn(i) /= huge) then + adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_ocn(i)*tem + else + adjsfculw(i) = ulwsfc_cice(i) + endif + else + if (wet(i) .and. adjsfculw_ocn(i) /= huge) then + adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_ocn(i)*tem + else + adjsfculw(i) = adjsfculw_ice(i) + endif + endif + else ! all water + adjsfculw(i) = adjsfculw_ocn(i) + endif enddo endif + do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf @@ -253,8 +294,8 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do i=1, im invrsn(i) = .false. - tx1(i) = 0.0 - tx2(i) = 10.0 + tx1(i) = 0.0 + tx2(i) = 10.0 ctei_r(i) = 10.0 end do @@ -393,7 +434,6 @@ subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & errmsg = '' errflg = 0 - ! DH* add gw_dXdt terms here gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp @@ -613,9 +653,9 @@ end subroutine GFS_suite_interstitial_4_finalize !> \section arg_table_GFS_suite_interstitial_4_run Argument Table !! \htmlinclude GFS_suite_interstitial_4_run.html !! - subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, lgocart, cplchm, tracers_total, ntrac, ntcw, ntiw, ntclamt, & - ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, dtf, save_qc, save_qi, con_pi, & + subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_total, ntrac, ntcw, ntiw, ntclamt, & + ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, dtf, save_qc, save_qi, con_pi, & gq0, clw, dqdti, errmsg, errflg) use machine, only: kind_phys @@ -628,7 +668,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, lgocart, cplchm, t ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - logical, intent(in) :: ltaerosol, lgocart, cplchm + logical, intent(in) :: ltaerosol, cplchm real(kind=kind_phys), intent(in) :: con_pi, dtf real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc @@ -724,7 +764,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, lgocart, cplchm, t endif ! end if_ntcw ! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (lgocart .or. cplchm) then + if (cplchm) then do k=1,levs do i=1,im dqdti(i,k) = dqdti(i,k) * (1.0 / dtf) diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 91a2c04a4..c07d9341a 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -156,15 +156,6 @@ kind = kind_phys intent = in optional = F -[frain] - standard_name = dynamics_to_physics_timestep_ratio - long_name = ratio of dynamics timestep to physics timestep - units = none - dimensions = () - type = real - kind = kind_phys - intent = out - optional = F [islmsk] standard_name = sea_land_ice_mask long_name = landmask: sea/land/ice=0/1/2 @@ -355,6 +346,14 @@ type = logical intent = in optional = F +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in + optional = F [imfshalcnv] standard_name = flag_for_mass_flux_shallow_convection_scheme long_name = flag for mass-flux shallow convection scheme @@ -399,6 +398,15 @@ kind = kind_phys intent = in optional = F +[cice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [pgr] standard_name = surface_air_pressure long_name = surface pressure @@ -570,6 +578,33 @@ kind = kind_phys intent = inout optional = F +[adjsfculw_lnd] + standard_name = surface_upwelling_longwave_flux_over_land_interstitial + long_name = surface upwelling longwave flux at current time over land (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfculw_ice] + standard_name = surface_upwelling_longwave_flux_over_ice_interstitial + long_name = surface upwelling longwave flux at current time over ice (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfculw_ocn] + standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial + long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [dlwsfc] standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep long_name = cumulative surface downwelling LW flux multiplied by timestep @@ -677,6 +712,48 @@ type = integer intent = inout optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1385,14 +1462,6 @@ type = logical intent = in optional = F -[lgocart] - standard_name = flag_gocart - long_name = flag for 3d diagnostic fields for gocart 1 - units = flag - dimensions = () - type = logical - intent = in - optional = F [cplchm] standard_name = flag_for_chemistry_coupling long_name = flag controlling cplchm collection (default off) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 2a01ab249..59598913c 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -11,6 +11,9 @@ module GFS_surface_composites_pre public GFS_surface_composites_pre_init, GFS_surface_composites_pre_finalize, GFS_surface_composites_pre_run + real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0d0 + contains subroutine GFS_surface_composites_pre_init () @@ -30,10 +33,10 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, lan tprcp_lnd, tprcp_ice, uustar, uustar_lnd, uustar_ice, weasd, weasd_ocn, & weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_ocn, tsfc_lnd, & tsfc_ice, tisfc, tice, tsurf, tsurf_ocn, tsurf_lnd, tsurf_ice, gflx_ice, & + tgice, islmsk, semis_rad, semis_ocn, semis_lnd, semis_ice, adjsfcdlw, & + gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_ocn, min_lakeice, min_seaice, & errmsg, errflg) - use machine, only: kind_phys - implicit none ! Interface variables @@ -42,7 +45,8 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, lan logical, dimension(im), intent(in ) :: flag_cice logical, dimension(im), intent(inout) :: dry, icy, lake, ocean, wet real(kind=kind_phys), intent(in ) :: cimin - real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, oceanfrac, cice + real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, oceanfrac + real(kind=kind_phys), dimension(im), intent(inout) :: cice real(kind=kind_phys), dimension(im), intent( out) :: frland real(kind=kind_phys), dimension(im), intent(in ) :: zorl, snowd, tprcp, uustar, weasd @@ -51,87 +55,154 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, lan tprcp_lnd, tprcp_ice, zorl_ocn, zorl_lnd, zorl_ice, tsfc_ocn, tsfc_lnd, tsfc_ice, tsurf_ocn, & tsurf_lnd, tsurf_ice, uustar_lnd, uustar_ice, weasd_ocn, weasd_lnd, weasd_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(im), intent( out) :: tice + real(kind=kind_phys), intent(in ) :: tgice + integer, dimension(im), intent(in ) :: islmsk + real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad, adjsfcdlw + real(kind=kind_phys), dimension(im), intent(inout) :: semis_ocn, semis_lnd, semis_ice + real(kind=kind_phys), dimension(im), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_ocn + real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variables - real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys) :: tem integer :: i ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - do i=1,im - frland(i) = landfrac(i) - if (frland(i) > 0.0) dry(i) = .true. - if (cice(i) >= cimin*(1.-frland(i)) .and. frland(i)<1.) icy(i) = .true. - if (frland(i)+cice(i) < 1.0 ) wet(i) = .true. ! there is some open water! - enddo - - if (frac_grid) then + if (frac_grid) then ! here cice is fraction of the whole grid that is ice do i=1,im - tsfc(i) = tsfcl(i) * frland(i) & - + tisfc(i) * cice(i) & - + tsfco(i) * (one-cice(i)-frland(i)) - enddo - elseif (cplflx) then - do i=1,im - if (flag_cice(i)) then - tsfc(i) = tisfc(i) * cice(i) & - + tsfc (i) * (one-cice(i)) - icy(i) = .true. + frland(i) = landfrac(i) + if (frland(i) > zero) dry(i) = .true. + tem = one - frland(i) + if (tem > zero) then + if (flag_cice(i)) then + if (cice(i) >= min_seaice*tem) then + icy(i) = .true. + else + cice(i) = zero + endif + else + if (cice(i) >= min_lakeice*tem) then + icy(i) = .true. + cice(i) = cice(i)/tem ! cice is fraction of ocean/lake + else + cice(i) = zero + endif + endif + if (icy(i)) tsfco(i) = max(tsfco(i), tisfc(i), tgice) + else + cice(i) = zero + endif + + ! ocean/lake area that is not frozen + tem = max(zero, tem - cice(i)) + + if (tem > zero) then + wet(i) = .true. ! there is some open water! +! if (icy(i)) tsfco(i) = max(tsfco(i), tgice) + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + enddo + + else + + do i = 1, IM + frland(i) = zero + if (islmsk(i) == 0) then + ! tsfco(i) = Sfcprop%tsfc(i) + wet(i) = .true. + cice(i) = zero + elseif (islmsk(i) == 1) then + ! Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) + dry(i) = .true. + frland(i) = one + cice(i) = zero + else + icy(i) = .true. + if (cice(i) < one) then + wet(i) = .true. + ! tsfco(i) = tgice + tsfco(i) = max(tisfc(i), tgice) + ! tsfco(i) = max((tsfc(i) - cice(i)*tisfc(i)) & + ! / (one - cice(i)), tgice) + endif endif enddo + endif if (.not. cplflx .or. .not. frac_grid) then do i=1,im zorll(i) = zorl(i) zorlo(i) = zorl(i) - tsfcl(i) = tsfc(i) - tsfco(i) = tsfc(i) !tisfc(i) = tsfc(i) enddo endif do i=1,im + tprcp_ocn(i) = tprcp(i) + tprcp_lnd(i) = tprcp(i) + tprcp_ice(i) = tprcp(i) if (wet(i)) then ! Water - tprcp_ocn(i) = tprcp(i) zorl_ocn(i) = zorlo(i) tsfc_ocn(i) = tsfco(i) tsurf_ocn(i) = tsfco(i) ! weasd_ocn(i) = weasd(i) ! snowd_ocn(i) = snowd(i) - weasd_ocn(i) = 0.0 - snowd_ocn(i) = 0.0 + weasd_ocn(i) = zero + snowd_ocn(i) = zero + semis_ocn(i) = 0.984d0 endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) weasd_lnd(i) = weasd(i) - tprcp_lnd(i) = tprcp(i) zorl_lnd(i) = zorll(i) tsfc_lnd(i) = tsfcl(i) tsurf_lnd(i) = tsfcl(i) snowd_lnd(i) = snowd(i) + semis_lnd(i) = semis_rad(i) end if if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) weasd_ice(i) = weasd(i) - tprcp_ice(i) = tprcp(i) zorl_ice(i) = zorll(i) -! tsfc_ice(i) = tisfc(i) -! tsurf_ice(i) = tisfc(i) - tsfc_ice(i) = tsfc(i) - tsurf_ice(i) = tsfc(i) + tsfc_ice(i) = tisfc(i) + tsurf_ice(i) = tisfc(i) snowd_ice(i) = snowd(i) - ep1d_ice(i) = 0. - gflx_ice(i) = 0. + ep1d_ice(i) = zero + gflx_ice(i) = zero + semis_ice(i) = 0.95d0 end if enddo + ! --- convert lw fluxes for land/ocean/sea-ice models + ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. + ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. + ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. + ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean + ! models as downward flux) is not the same as adjsfcdlw but a value reduced by + ! the factor of emissivity. however, the net effects are the same when seeing + ! it either above the surface interface or below. + ! + ! - flux above the interface used by atmosphere model: + ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + ! - flux below the interface used by lnd/oc/ice models: + ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + + ! --- ... define the downward lw flux absorbed by ground + do i=1,im + if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) + if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) + if (wet(i)) gabsbdlw_ocn(i) = semis_ocn(i) * adjsfcdlw(i) + enddo + ! Assign sea ice temperature to interstitial variable do i = 1, im tice(i) = tisfc(i) @@ -152,6 +223,9 @@ module GFS_surface_composites_post public GFS_surface_composites_post_init, GFS_surface_composites_post_finalize, GFS_surface_composites_post_run + real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0d0 + contains subroutine GFS_surface_composites_post_init () @@ -166,7 +240,8 @@ end subroutine GFS_surface_composites_post_finalize !! #endif subroutine GFS_surface_composites_post_run ( & - im, cplflx, frac_grid, flag_cice, islmsk, dry, wet, icy, landfrac, zorl, zorlo, zorll, zorl_ocn, zorl_lnd, zorl_ice, & + im, cplflx, frac_grid, flag_cice, islmsk, dry, wet, icy, landfrac, lakefrac, oceanfrac, & + zorl, zorlo, zorll, zorl_ocn, zorl_lnd, zorl_ice, & cd, cd_ocn, cd_lnd, cd_ice, cdq, cdq_ocn, cdq_lnd, cdq_ice, rb, rb_ocn, rb_lnd, rb_ice, stress, stress_ocn, stress_lnd, & stress_ice, ffmm, ffmm_ocn, ffmm_lnd, ffmm_ice, ffhh, ffhh_ocn, ffhh_lnd, ffhh_ice, uustar, uustar_ocn, uustar_lnd, & uustar_ice, fm10, fm10_ocn, fm10_lnd, fm10_ice, fh2, fh2_ocn, fh2_lnd, fh2_ice, tsurf, tsurf_ocn, tsurf_lnd, tsurf_ice, & @@ -175,15 +250,13 @@ subroutine GFS_surface_composites_post_run ( tprcp_lnd, tprcp_ice, evap, evap_ocn, evap_lnd, evap_ice, hflx, hflx_ocn, hflx_lnd, hflx_ice, qss, qss_ocn, qss_lnd, & qss_ice, tsfc, tsfco, tsfcl, tsfc_ocn, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, errmsg, errflg) - use machine, only: kind_phys - implicit none integer, intent(in) :: im logical, intent(in) :: cplflx, frac_grid logical, dimension(im), intent(in) :: flag_cice, dry, wet, icy integer, dimension(im), intent(in) :: islmsk - real(kind=kind_phys), dimension(im), intent(in) :: landfrac, & + real(kind=kind_phys), dimension(im), intent(in) :: landfrac, lakefrac, oceanfrac, & zorl_ocn, zorl_lnd, zorl_ice, cd_ocn, cd_lnd, cd_ice, cdq_ocn, cdq_lnd, cdq_ice, rb_ocn, rb_lnd, rb_ice, stress_ocn, & stress_lnd, stress_ice, ffmm_ocn, ffmm_lnd, ffmm_ice, ffhh_ocn, ffhh_lnd, ffhh_ice, uustar_ocn, uustar_lnd, uustar_ice, & fm10_ocn, fm10_lnd, fm10_ice, fh2_ocn, fh2_lnd, fh2_ice, tsurf_ocn, tsurf_lnd, tsurf_ice, cmm_ocn, cmm_lnd, cmm_ice, & @@ -202,7 +275,9 @@ subroutine GFS_surface_composites_post_run ( ! Local variables integer :: i - real(kind=kind_phys) :: txl, txi, txo + real(kind=kind_phys) :: txl, txi, txo, tem + real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0d0 ! Initialize CCPP error handling variables errmsg = '' @@ -217,7 +292,7 @@ subroutine GFS_surface_composites_post_run ( ! Three-way composites (fields from sfc_diff) txl = landfrac(i) txi = cice(i) ! here cice is grid fraction that is ice - txo = 1.0 - txl - txi + txo = one - txl - txi zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_ocn(i) cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_ocn(i) @@ -233,39 +308,58 @@ subroutine GFS_surface_composites_post_run ( !tsurf(i) = txl*tsurf_lnd(i) + txi*tsurf_ice(i) + txo*tsurf_ocn(i) ! not used again! Moorthi cmm(i) = txl*cmm_lnd(i) + txi*cmm_ice(i) + txo*cmm_ocn(i) chh(i) = txl*chh_lnd(i) + txi*chh_ice(i) + txo*chh_ocn(i) - gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_ocn(i) + !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_ocn(i) ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_ocn(i) !weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + txo*weasd_ocn(i) !snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + txo*snowd_ocn(i) weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) - tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_ocn(i) - evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_ocn(i) - hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_ocn(i) - qss(i) = txl*qss_lnd(i) + txi*qss_ice(i) + txo*qss_ocn(i) + !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_ocn(i) + + if (.not. flag_cice(i) .and. islmsk(i) == 2) then + tem = one - txl + evap(i) = txl*evap_lnd(i) + tem*evap_ice(i) + hflx(i) = txl*hflx_lnd(i) + tem*hflx_ice(i) + qss(i) = txl*qss_lnd(i) + tem*qss_ice(i) + gflx(i) = txl*gflx_lnd(i) + tem*gflx_ice(i) + else + evap(i) = txl*evap_lnd(i) + tem*evap_ice(i) + txo*evap_ocn(i) + hflx(i) = txl*hflx_lnd(i) + tem*hflx_ice(i) + txo*hflx_ocn(i) + qss(i) = txl*qss_lnd(i) + tem*qss_ice(i) + txo*qss_ocn(i) + gflx(i) = txl*gflx_lnd(i) + tem*gflx_ice(i) + txo*gflx_ocn(i) + endif tsfc(i) = txl*tsfc_lnd(i) + txi*tice(i) + txo*tsfc_ocn(i) !tsfc(i) = txl*tsfc_lnd(i) + txi*tsfc_ice(i) + txo*tsfc_ocn(i) + ! DH* NOTE THIS IS UNNECESSARY BECAUSE DONE BEFORE? Diag%cmm(i) = txl*cmm3(i,1) + txi*cmm3(i,2) + txo*cmm3(i,3) + ! DH* NOTE THIS IS UNNECESSARY BECAUSE DONE BEFORE? Diag%chh(i) = txl*chh3(i,1) + txi*chh3(i,2) + txo*chh3(i,3) + zorll(i) = zorl_lnd(i) zorlo(i) = zorl_ocn(i) if (dry(i)) tsfcl(i) = tsfc_lnd(i) ! over land if (wet(i)) tsfco(i) = tsfc_ocn(i) ! over lake or ocean when uncoupled - tisfc(i) = tsfc(i) ! assume bitwise identical on non-icy points - if (icy(i)) then - tisfc(i) = tsfc_ice(i) ! over ice when uncoupled -! tisfc(i) = tice(i) ! over ice when uncoupled - else - hice(i) = 0.0 - cice(i) = 0.0 - end if + ! for coupled model ocean will replace this +! if (icy(i)) tisfc(i) = tsfc_ice(i) ! over ice when uncoupled +! if (icy(i)) tisfc(i) = tice(i) ! over ice when uncoupled ! if (wet(i) .and. .not. cplflx) then -! tsfco(i) = tsfc3_ocn(i) ! over lake or ocean when uncoupled -! tisfc(i) = tsfc3_ice(i) ! over ice when uncoupled +! tsfco(i) = tsfc_ocn(i) ! over lake or ocean when uncoupled +! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled ! endif - end do + if (.not. flag_cice(i)) then + if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array + ! DH* NOT NEEDED? Sfcprop%hice(i) = zice(i) + cice(i) = cice(i) * (1.0-landfrac(i)) ! fice is fraction of lake area that is frozen + tisfc(i) = tice(i) + else ! this would be over open ocean or land (no ice fraction) + hice(i) = zero + cice(i) = zero + tisfc(i) = tsfc(i) + endif + endif + enddo else @@ -282,13 +376,14 @@ subroutine GFS_surface_composites_post_run ( fm10(i) = fm10_lnd(i) fh2(i) = fh2_lnd(i) !tsurf(i) = tsurf_lnd(i) + tsfcl(i) = tsurf_lnd(i) cmm(i) = cmm_lnd(i) chh(i) = chh_lnd(i) gflx(i) = gflx_lnd(i) ep1d(i) = ep1d_lnd(i) weasd(i) = weasd_lnd(i) snowd(i) = snowd_lnd(i) - tprcp(i) = tprcp_lnd(i) + !tprcp(i) = tprcp_lnd(i) evap(i) = evap_lnd(i) hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) @@ -307,13 +402,14 @@ subroutine GFS_surface_composites_post_run ( fm10(i) = fm10_ocn(i) fh2(i) = fh2_ocn(i) !tsurf(i) = tsurf_ocn(i) + tsfco(i) = tsurf_ocn(i) cmm(i) = cmm_ocn(i) chh(i) = chh_ocn(i) gflx(i) = gflx_ocn(i) ep1d(i) = ep1d_ocn(i) weasd(i) = weasd_ocn(i) snowd(i) = snowd_ocn(i) - tprcp(i) = tprcp_ocn(i) + !tprcp(i) = tprcp_ocn(i) evap(i) = evap_ocn(i) hflx(i) = hflx_ocn(i) qss(i) = qss_ocn(i) @@ -325,20 +421,23 @@ subroutine GFS_surface_composites_post_run ( cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) rb(i) = rb_ice(i) - stress(i) = stress_ice(i) + stress(i) = cice(i)*stress_ice(i) + (one-cice(i))*stress_ocn(i) ffmm(i) = ffmm_ice(i) ffhh(i) = ffhh_ice(i) uustar(i) = uustar_ice(i) fm10(i) = fm10_ice(i) fh2(i) = fh2_ice(i) !tsurf(i) = tsurf_ice(i) + if (.not. flag_cice(i)) then + tisfc(i) = tice(i) + endif cmm(i) = cmm_ice(i) chh(i) = chh_ice(i) gflx(i) = gflx_ice(i) ep1d(i) = ep1d_ice(i) weasd(i) = weasd_ice(i) snowd(i) = snowd_ice(i) - tprcp(i) = tprcp_ice(i) + !tprcp(i) = cice(i)*tprcp_ice(i) + (one-cice(i))*tprcp_ocn(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) @@ -350,28 +449,24 @@ subroutine GFS_surface_composites_post_run ( zorll(i) = zorl_lnd(i) zorlo(i) = zorl_ocn(i) - if (flag_cice(i)) then - evap(i) = cice(i) * evap_ice(i) + (1.0-cice(i)) * evap_ocn(i) - hflx(i) = cice(i) * hflx_ice(i) + (1.0-cice(i)) * hflx_ocn(i) - tsfc(i) = cice(i) * tsfc_ice(i) + (1.0-cice(i)) * tsfc_ocn(i) + if (flag_cice(i)) then ! this was already done for lake ice in sfc_sice + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_ocn(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_ocn(i) +! tsfc(i) = txi * tice(i) + txo * tsfc_ocn(i) + tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_ocn(i) + else ! return updated lake ice thickness & concentration to global array + if (islmsk(i) == 2) then + ! DH* NOT NEEDED ???? Sfcprop%hice(i) = zice(i) + ! DH* NOT NEEDED ???? cice(i) = fice(i) ! fice is fraction of lake area that is frozen + tisfc(i) = tice(i) + else ! this would be over open ocean or land (no ice fraction) + hice(i) = zero + cice(i) = zero + tisfc(i) = tsfc(i) + endif endif - - if (dry(i)) tsfcl(i) = tsfc_lnd(i) ! over land - if (wet(i)) tsfco(i) = tsfc_ocn(i) ! over lake or ocean when uncoupled - tisfc(i) = tsfc(i) ! assume bitwise identical on non-icy points - if (icy(i)) then -! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled - tisfc(i) = tice(i) ! over ice when uncoupled - else - hice(i) = 0.0 - cice(i) = 0.0 - end if - -! if (wet(i) .and. .not. cplflx) then -! tsfco(i) = tsfc_ocn(i) ! over lake or ocean when uncoupled -! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled -! endif - end do end if ! if (frac_grid) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 4e8609ded..d06cedf90 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -116,7 +116,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys - intent = in + intent = inout optional = F [cimin] standard_name = minimum_sea_ice_concentration @@ -442,6 +442,113 @@ kind = kind_phys intent = inout optional = F +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[semis_rad] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[semis_ocn] + standard_name = surface_longwave_emissivity_over_ocean_interstitial + long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[semis_lnd] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[semis_ice] + standard_name = surface_longwave_emissivity_over_ice_interstitial + long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gabsbdlw_lnd] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[gabsbdlw_ice] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice + long_name = total sky surface downward longwave flux absorbed by the ground over ice + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[gabsbdlw_ocn] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ocean + long_name = total sky surface downward longwave flux absorbed by the ground over ocean + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = ??? + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = ??? + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -537,6 +644,24 @@ kind = kind_phys intent = in optional = F +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [zorl] standard_name = surface_roughness_length long_name = surface roughness length diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index e6c91abd7..0b1e43e5c 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -3,10 +3,17 @@ module GFS_surface_generic_pre + use machine, only: kind_phys + + implicit none + private public GFS_surface_generic_pre_init, GFS_surface_generic_pre_finalize, GFS_surface_generic_pre_run + real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0d0 + contains subroutine GFS_surface_generic_pre_init () @@ -15,22 +22,19 @@ end subroutine GFS_surface_generic_pre_init subroutine GFS_surface_generic_pre_finalize() end subroutine GFS_surface_generic_pre_finalize -#if 0 !> \section arg_table_GFS_surface_generic_pre_run Argument Table !! \htmlinclude GFS_surface_generic_pre_run.html !! -#endif subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & - prsik_1, prslk_1, semis, adjsfcdlw, tsfc, phil, con_g, sigmaf, soiltyp, vegtype, & - slopetyp, work3, gabsbdlw, tsurf, zlvl, do_sppt, dtdtr, & + prsik_1, prslk_1, tsfc, phil, con_g, & + sigmaf, soiltyp, vegtype, slopetyp, work3, tsurf, zlvl, do_sppt, dtdtr, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, do_sfcperts, nsfcpert, sfc_wts, & pertz0, pertzt, pertshc, pertlai, pertvegf, z01d, zt1d, bexp1d, xlai1d, vegf1d, & cplflx, flag_cice, islmsk_cice,slimskin_cpl, dusfcin_cpl, dvsfcin_cpl, & dtsfcin_cpl, dqsfcin_cpl, ulwsfcin_cpl, ulwsfc_cice, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, & - errmsg, errflg) + dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, dry, icy, wet, & + wind, u1, v1, cnvwind, errmsg, errflg) - use machine, only: kind_phys use surface_perturbation, only: cdfnor implicit none @@ -39,14 +43,15 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, integer, intent(in) :: im, levs, isot, ivegsrc integer, dimension(im), intent(in) :: islmsk integer, dimension(im), intent(inout) :: soiltyp, vegtype, slopetyp + logical, dimension(im), intent(in) :: dry, icy, wet real(kind=kind_phys), intent(in) :: con_g - real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1, & - semis, adjsfcdlw + real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1 + real(kind=kind_phys), dimension(im), intent(inout) :: tsfc real(kind=kind_phys), dimension(im,levs), intent(in) :: phil - real(kind=kind_phys), dimension(im), intent(inout) :: sigmaf, work3, gabsbdlw, tsurf, zlvl + real(kind=kind_phys), dimension(im), intent(inout) :: sigmaf, work3, tsurf, zlvl ! Stochastic physics / surface perturbations logical, intent(in) :: do_sppt @@ -79,6 +84,11 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(im), intent(out) ::ulwsfc_cice, & dusfc_cice, dvsfc_cice, dtsfc_cice, dqsfc_cice + real(kind=kind_phys), dimension(im), intent(out) :: wind + real(kind=kind_phys), dimension(im), intent(in ) :: u1, v1 + ! surface wind enhancement due to convection + real(kind=kind_phys), dimension(im), intent(in ) :: cnvwind + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -156,33 +166,22 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, soiltyp(i) = int( stype(i)+0.5 ) vegtype(i) = int( vtype(i)+0.5 ) slopetyp(i) = int( slope(i)+0.5 ) !! clu: slope -> slopetyp + if (soiltyp(i) < 1) soiltyp(i) = 14 + if (vegtype(i) < 1) vegtype(i) = 17 + if (slopetyp(i) < 1) slopetyp(i) = 1 endif work3(i) = prsik_1(i) / prslk_1(i) end do - ! --- convert lw fluxes for land/ocean/sea-ice models - ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. - ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. - ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. - ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean - ! models as downward flux) is not the same as adjsfcdlw but a value reduced by - ! the factor of emissivity. however, the net effects are the same when seeing - ! it either above the surface interface or below. - ! - ! - flux above the interface used by atmosphere model: - ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - ! - flux below the interface used by lnd/oc/ice models: - ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - - ! --- ... define the downward lw flux absorbed by ground - gabsbdlw(:) = semis(:) * adjsfcdlw(:) - do i=1,im - tsurf(i) = tsfc(i) - zlvl(i) = phil(i,1) * onebg + !tsurf(i) = tsfc(i) + zlvl(i) = phil(i,1) * onebg + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + + max(zero, min(cnvwind(i), 30.0)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) end do if(cplflx)then @@ -195,16 +194,15 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, islmsk_cice(i) = int(slimskin_cpl(i)+0.5) if(islmsk_cice(i) == 4)then flag_cice(i) = .true. + ulwsfc_cice(i) = ulwsfcin_cpl(i) + dusfc_cice(i) = dusfcin_cpl(i) + dvsfc_cice(i) = dvsfcin_cpl(i) + dtsfc_cice(i) = dtsfcin_cpl(i) + dqsfc_cice(i) = dqsfcin_cpl(i) endif - ulwsfc_cice(i) = ulwsfcin_cpl(i) - dusfc_cice(i) = dusfcin_cpl(i) - dvsfc_cice(i) = dvsfcin_cpl(i) - dtsfc_cice(i) = dtsfcin_cpl(i) - dqsfc_cice(i) = dqsfcin_cpl(i) enddo endif - end subroutine GFS_surface_generic_pre_run end module GFS_surface_generic_pre @@ -212,10 +210,17 @@ end module GFS_surface_generic_pre module GFS_surface_generic_post + use machine, only: kind_phys + + implicit none + private public GFS_surface_generic_post_init, GFS_surface_generic_post_finalize, GFS_surface_generic_post_run + real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0d0 + contains subroutine GFS_surface_generic_post_init () @@ -223,22 +228,19 @@ end subroutine GFS_surface_generic_post_init subroutine GFS_surface_generic_post_finalize() end subroutine GFS_surface_generic_post_finalize -#if 0 + !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! -#endif subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& - adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - t2m, q2m, u10m, v10m, tsfc, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & + adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_ocn, adjnirbmu, adjnirdfu, & + adjvisbmu, adjvisdfu,t2m, q2m, u10m, v10m, tsfc, tsfc_ocn, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, & v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, & runoff, srunoff, runof, drain, errmsg, errflg) - use machine, only: kind_phys - implicit none integer, intent(in) :: im @@ -247,8 +249,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt real(kind=kind_phys), intent(in) :: dtf real(kind=kind_phys), dimension(im), intent(in) :: ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, & - adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - t2m, q2m, u10m, v10m, tsfc, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_ocn, adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + t2m, q2m, u10m, v10m, tsfc, tsfc_ocn, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf real(kind=kind_phys), dimension(im), intent(inout) :: epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, & dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, & @@ -301,20 +303,25 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt dnirdf_cpl (i) = dnirdf_cpl(i) + adjnirdfd(i)*dtf dvisbm_cpl (i) = dvisbm_cpl(i) + adjvisbmd(i)*dtf dvisdf_cpl (i) = dvisdf_cpl(i) + adjvisdfd(i)*dtf - nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) + nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) + if (wet(i)) then + nlwsfci_cpl(i) = adjsfcdlw(i) - adjsfculw_ocn(i) + endif nlwsfc_cpl (i) = nlwsfc_cpl(i) + nlwsfci_cpl(i)*dtf t2mi_cpl (i) = t2m(i) q2mi_cpl (i) = q2m(i) - tsfci_cpl (i) = tsfc(i) +! tsfci_cpl (i) = tsfc(i) + tsfci_cpl (i) = tsfc_ocn(i) psurfi_cpl (i) = pgr(i) enddo - ! --- estimate mean albedo for ocean point without ice cover and apply - ! them to net SW heat fluxes +! --- estimate mean albedo for ocean point without ice cover and apply +! them to net SW heat fluxes do i=1,im - if (wet(i) .or. icy(i)) then ! not 100% land - ! --- compute open water albedo +! if (Sfcprop%landfrac(i) < one) then ! Not 100% land + if (wet(i)) then ! some open water +! --- compute open water albedo xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) ocalnirdf_cpl = 0.06 ocalnirbm_cpl = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & @@ -323,10 +330,10 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt ocalvisdf_cpl = 0.06 ocalvisbm_cpl = ocalnirbm_cpl - nnirbmi_cpl(i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl - nnirdfi_cpl(i) = adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl - nvisbmi_cpl(i) = adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl - nvisdfi_cpl(i) = adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl + nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) + nnirdfi_cpl(i) = adjnirdfd(i) * (one-ocalnirdf_cpl) + nvisbmi_cpl(i) = adjvisbmd(i) * (one-ocalvisbm_cpl) + nvisdfi_cpl(i) = adjvisdfd(i) * (one-ocalvisdf_cpl) else nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index def8cd1b6..bccfa4e38 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -95,24 +95,6 @@ kind = kind_phys intent = in optional = F -[semis] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction - units = frac - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [tsfc] standard_name = surface_skin_temperature long_name = surface skin temperature @@ -182,15 +164,6 @@ kind = kind_phys intent = inout optional = F -[gabsbdlw] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground - long_name = total sky surface downward longwave flux absorbed by the ground - units = W m-2 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [tsurf] standard_name = surface_skin_temperature_after_iteration long_name = surface skin temperature after iteration @@ -536,6 +509,66 @@ kind = kind_phys intent = in optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[u1] + standard_name = x_wind_at_lowest_model_layer + long_name = zonal wind at lowest model layer + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind_at_lowest_model_layer + long_name = meridional wind at lowest model layer + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[cnvwind] + standard_name = surface_wind_enhancement_due_to_convection + long_name = surface wind enhancement due to convection + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -732,6 +765,15 @@ kind = kind_phys intent = in optional = F +[adjsfculw_ocn] + standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial + long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [adjnirbmu] standard_name = surface_upwelling_direct_near_infrared_shortwave_flux long_name = surface upwelling beam near-infrared shortwave flux at current time @@ -813,6 +855,15 @@ kind = kind_phys intent = in optional = F +[tsfc_ocn] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [pgr] standard_name = surface_air_pressure long_name = surface pressure diff --git a/physics/GFS_surface_loop_control.F90 b/physics/GFS_surface_loop_control.F90 index dd6bc86c0..c701c523e 100644 --- a/physics/GFS_surface_loop_control.F90 +++ b/physics/GFS_surface_loop_control.F90 @@ -111,7 +111,8 @@ subroutine GFS_surface_loop_control_part2_run (im, iter, wind, & flag_guess(i) = .false. if (iter == 1 .and. wind(i) < 2.0) then - if (dry(i) .or. (wet(i) .and. .not.icy(i) .and. nstf_name1 > 0)) then + !if (dry(i) .or. (wet(i) .and. .not.icy(i) .and. nstf_name1 > 0)) then + if (dry(i) .or. (wet(i) .and. nstf_name1 > 0)) then flag_iter(i) = .true. endif endif diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index e1268d13c..b6442aefd 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -16,6 +16,8 @@ module cires_ugwp use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize + use gwdps, only: gwdps_run + implicit none private @@ -30,16 +32,14 @@ module cires_ugwp ! CCPP entry points for CIRES Unified Gravity Wave Physics (UGWP) scheme v0 ! ------------------------------------------------------------------------ !>@brief The subroutine initializes the CIRES UGWP -#if 0 !> \section arg_table_cires_ugwp_init Argument Table !! \htmlinclude cires_ugwp_init.html !! -#endif ! ----------------------------------------------------------------------- ! subroutine cires_ugwp_init (me, master, nlunit, logunit, fn_nml2, & - lonr, latr, levs, ak, bk, dtp, cdmvgwd, cgwf, & - pa_rf_in, tau_rf_in, con_p0, errmsg, errflg) + lonr, latr, levs, ak, bk, dtp, cdmbgwd, cgwf, & + pa_rf_in, tau_rf_in, con_p0, do_ugwp, errmsg, errflg) !---- initialization of cires_ugwp implicit none @@ -53,9 +53,10 @@ subroutine cires_ugwp_init (me, master, nlunit, logunit, fn_nml2, & integer, intent (in) :: latr real(kind=kind_phys), intent (in) :: ak(:), bk(:) real(kind=kind_phys), intent (in) :: dtp - real(kind=kind_phys), intent (in) :: cdmvgwd(2), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes + real(kind=kind_phys), intent (in) :: cdmbgwd(4), cgwf(2) ! "scaling" controls for "old" GFS-GW schemes real(kind=kind_phys), intent (in) :: pa_rf_in, tau_rf_in real(kind=kind_phys), intent (in) :: con_p0 + logical, intent (in) :: do_ugwp character(len=*), intent (in) :: fn_nml2 !character(len=*), parameter :: fn_nml='input.nml' @@ -74,16 +75,27 @@ subroutine cires_ugwp_init (me, master, nlunit, logunit, fn_nml2, & if (is_initialized) return - call cires_ugwp_mod_init (me, master, nlunit, logunit, fn_nml2, & - lonr, latr, levs, ak, bk, con_p0, dtp, & - cdmvgwd, cgwf, pa_rf_in, tau_rf_in) + write(0,*) "DH DEBUG cires_ugwp_init: do_ugwp, (cdmbgwd(3) > 0.0) ?", do_ugwp, " ", (cdmbgwd(3) > 0.0) + + if (do_ugwp .or. cdmbgwd(3) > 0.0) then + write(0,*) "DH DEBUG cires_ugwp_init: cires_ugwp_mod_init" + call cires_ugwp_mod_init (me, master, nlunit, logunit, fn_nml2, & + lonr, latr, levs, ak, bk, con_p0, dtp, & + cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) + else + write(errmsg,'(*(a))') "Logic error: cires_ugwp_init called but do_ugwp is false and cdmbgwd(3) <= 0" + errflg = 1 + return + end if if (.not.knob_ugwp_version==0) then - write(errmsg,'(*(a))') 'Logic error: CCPP only supports version zero of UGWP' - errflg = 1 - return + write(errmsg,'(*(a))') 'Logic error: CCPP only supports version zero of UGWP' + errflg = 1 + return end if + write(0,*) "DH DEBUG cires_ugwp_init: set is_initialized = .true." + is_initialized = .true. end subroutine cires_ugwp_init @@ -128,46 +140,57 @@ end subroutine cires_ugwp_finalize ! order = dry-adj=>conv=mp-aero=>radiation -sfc/land- chem -> vertdiff-> [rf-gws]=> ion-re ! ----------------------------------------------------------------------- !>@brief The subroutine executes the CIRES UGWP -#if 0 !> \section arg_table_cires_ugwp_run Argument Table !! \htmlinclude cires_ugwp_run.html !! -#endif ! subroutines original subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr, & oro, oro_uf, hprime, nmtvr, oc, theta, sigma, gamma, elvmax, clx, oa4, & - do_tofd, cdmbgwd, xlat, xlat_d, sinlat, coslat, area, & + do_tofd, ldiag_ugwp, cdmbgwd, xlat, xlat_d, sinlat, coslat, area, & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, & del, kpbl, dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_tofd, tau_mtb, tau_ogw, tau_ngw, zmtb, zlwb, zogw, & - dudt_mtb,dudt_ogw, dudt_tms, dudt, dvdt, dtdt, rdxzb, & - con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, errmsg, errflg) + dudt_mtb,dudt_ogw, dudt_tms, du3dt_mtb, du3dt_ogw, du3dt_tms, & + dudt, dvdt, dtdt, rdxzb, con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt, & + rain, ntke, q_tke, dqdt_tke, lprnt, ipr, errmsg, errflg) implicit none ! interface variables integer, intent(in) :: me, master, im, levs, ntrac, kdt, lonr, nmtvr integer, intent(in), dimension(im) :: kpbl - real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma, elvmax + real(kind=kind_phys), intent(in), dimension(im) :: oro, oro_uf, hprime, oc, theta, sigma, gamma + ! elvmax is intent(in) for CIRES UGWP, but intent(inout) for GFS GWDPS + real(kind=kind_phys), intent(inout), dimension(im) :: elvmax real(kind=kind_phys), intent(in), dimension(im, 4) :: clx, oa4 real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlat_d, sinlat, coslat, area real(kind=kind_phys), intent(in), dimension(im, levs) :: del, ugrs, vgrs, tgrs, prsl, prslk, phil real(kind=kind_phys), intent(in), dimension(im, levs+1) :: prsi, phii real(kind=kind_phys), intent(in), dimension(im, levs, ntrac):: qgrs - real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(2) - logical, intent(in) :: do_ugwp, do_tofd + real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(4) + logical, intent(in) :: do_ugwp, do_tofd, ldiag_ugwp real(kind=kind_phys), intent(out), dimension(im) :: dusfcg, dvsfcg real(kind=kind_phys), intent(out), dimension(im) :: zmtb, zlwb, zogw, rdxzb real(kind=kind_phys), intent(out), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw real(kind=kind_phys), intent(out), dimension(im, levs):: gw_dudt, gw_dvdt, gw_dtdt, gw_kdis real(kind=kind_phys), intent(out), dimension(im, levs):: dudt_mtb, dudt_ogw, dudt_tms + ! These arrays only allocated if ldiag_ugwp = .true. + real(kind=kind_phys), intent(out), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms real(kind=kind_phys), intent(inout), dimension(im, levs):: dudt, dvdt, dtdt real(kind=kind_phys), intent(in) :: con_g, con_pi, con_cp, con_rd, con_rv, con_fvirt + real(kind=kind_phys), intent(in), dimension(im) :: rain + + integer, intent(in) :: ntke + real(kind=kind_phys), intent(in), dimension(:,:) :: q_tke, dqdt_tke + + logical, intent(in) :: lprnt + integer, intent(in) :: ipr + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -182,87 +205,198 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr ! switches that activate impact of OGWs and NGWs (WL* how to deal with them? *WL) real(kind=kind_phys), parameter :: pogw=1., pngw=1., pked=1. + real(kind=kind_phys), dimension(:,:), allocatable :: tke + real(kind=kind_phys), dimension(:), allocatable :: turb_fac, tem + real(kind=kind_phys) :: rfac, tx1 + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality - if (do_ugwp) then - - ! topo paras - ! w/ orographic effects - if(nmtvr == 14)then - ! calculate sgh30 for TOFD - sgh30 = abs(oro - oro_uf) - ! w/o orographic effects - else - sgh30 = 0. - endif - - zlwb(:) = 0. - - call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & - ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & - dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & - dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd, & - me, master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, dudt_mtb, dudt_ogw, dudt_tms) - - - ! 1) non-stationary GW-scheme with GMAO/MERRA GW-forcing - call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: do_ugwp, nmtvr:", do_ugwp, " ", nmtvr + ! *DH + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: cdmbgwd=", cdmbgwd + ! *DH - ! 2) non-stationary GW-scheme with GEOS-5/MERRA GW-forcing - call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), & - prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - tau_ngw, me, master, kdt) + ! 1) ORO stationary GWs + ! ------------------ + ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality + if (do_ugwp) then ! calling revised old GFS gravity wave drag + + ! topo paras + ! w/ orographic effects + if(nmtvr == 14)then + ! calculate sgh30 for TOFD + sgh30 = abs(oro - oro_uf) + ! w/o orographic effects + else + sgh30 = 0. + endif + + zlwb(:) = 0. + + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: calling GWDPS_V0, cdmbgwd:", cdmbgwd + ! *DH + call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & + ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & + dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & + dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd(1:2), & + me, master, rdxzb, zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, & + dudt_mtb, dudt_ogw, dudt_tms) + + else ! calling old GFS gravity wave drag as is + + do k=1,levs + do i=1,im + Pdvdt(i,k) = 0.0 + Pdudt(i,k) = 0.0 + Pdtdt(i,k) = 0.0 + Pkdis(i,k) = 0.0 + enddo + enddo + + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: calling gwdps_run, cdmbgwd:", cdmbgwd + ! *DH + call gwdps_run(im, im, levs, Pdvdt, Pdudt, Pdtdt, & + ugrs, vgrs, tgrs, qgrs, & + kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & + hprime, oc, oa4, clx, theta, sigma, gamma, & + elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, lonr, & + nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, & + errmsg, errflg) + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: after calling gwdps_run, errflg=", errflg + ! *DH + if (errflg/=0) return + endif + + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + if (ldiag_ugwp) then + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + end if - if(pogw /= 0.)then + endif ! do_ugwp - do k=1,levs - do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) - - ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) - dudt(i,k) = dudt(i,k) +gw_dudt(i,k) - dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) - dtdt(i,k) = dtdt(i,k) +gw_dtdt(i,k) + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: after do_ugwp" + ! *DH + + if (cdmbgwd(3) > 0.0) then + + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: calling slat_geos5_tamp" + ! *DH + + ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing + call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) + + if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then + if (cdmbgwd(4) > 0.0) then + allocate(turb_fac(im)) + do i=1,im + turb_fac(i) = 0.0 + enddo + if (ntke > 0) then + allocate(tke(im,levs)) + allocate(tem(im)) + tke(:,:) = q_tke(:,:) + dqdt_tke(:,:) * dtp + tem(:) = 0.0 + do k=1,(levs+levs)/3 + do i=1,im + turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) + tem(i) = tem(i) + del(i,k) + enddo enddo + do i=1,im + turb_fac(i) = turb_fac(i) / tem(i) enddo - - else - - tau_mtb = 0. ; tau_ogw =0.; tau_tofd =0. - dudt_mtb =0. ; dudt_ogw = 0.; dudt_tms=0. - + deallocate(tke) + deallocate(tem) + endif + rfac = 86400000 / dtp + do i=1,im + tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) + tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) + enddo + deallocate(turb_fac) endif - - return - - - !============================================================================= - ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving - ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" - !============================================================================= - ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies - !------------------------------------------------------------------------------ - ed_dudt(:,:) =0.; ed_dvdt(:,:) = 0. ; ed_dtdt(:,:) = 0. - - call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, qgrs(:,:,1), & - del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) - gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked - gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked - gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked - - - - endif ! do_ugwp + do i=1,im + tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) + enddo + endif + + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: tau_ngw=", sum(tau_ngw) + write(0,*) "DH DEBUG cires_ugwp_run: calling fv3_ugwp_solv2_v0" + ! *DH + + call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), & + prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + tau_ngw, me, master, kdt) + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) + gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) + ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) + !dudt(i,k) = dudt(i,k) +gw_dudt(i,k) + !dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) + !dtdt(i,k) = dtdt(i,k) +gw_dtdt(i,k) + enddo + enddo + + else + + do k=1,levs + do i=1,im + gw_dtdt(i,k) = Pdtdt(i,k) + gw_dudt(i,k) = Pdudt(i,k) + gw_dvdt(i,k) = Pdvdt(i,k) + gw_kdis(i,k) = Pkdis(i,k) + enddo + enddo + + endif + + ! DH* + write(0,*) "DH DEBUG cires_ugwp_run: before final pogw assignment" + ! *DH + + if (pogw == 0.0) then + tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. + dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. + endif + + return + + !============================================================================= + ! make "ugwp eddy-diffusion" update for gw_dtdt/gw_dudt/gw_dvdt by solving + ! vert diffusion equations & update "Statein%tgrs, Statein%ugrs, Statein%vgrs" + !============================================================================= + ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies + !------------------------------------------------------------------------------ + do k=1,levs + do i=1,im + ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 + enddo + enddo + + call edmix_ugwp_v0(im, levs, dtp, tgrs, ugrs, vgrs, qgrs(:,:,1), & + del, prsl, prsi, phil, prslk, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & + ed_dudt, ed_dvdt, ed_dtdt, me, master, kdt) + gw_dtdt = gw_dtdt*(1.-pked) + ed_dtdt*pked + gw_dvdt = gw_dvdt*(1.-pked) + ed_dvdt*pked + gw_dudt = gw_dudt*(1.-pked) + ed_dudt*pked end subroutine cires_ugwp_run - end module cires_ugwp diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index e722b2992..1544035a9 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -93,11 +93,11 @@ kind = kind_phys intent = in optional = F -[cdmvgwd] +[cdmbgwd] standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag long_name = multiplication factors for cdmb and gwd units = none - dimensions = (2) + dimensions = (4) type = real kind = kind_phys intent = in @@ -138,6 +138,14 @@ kind = kind_phys intent = in optional = F +[do_ugwp] + standard_name = do_ugwp + long_name = flag to activate CIRES UGWP + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -361,11 +369,19 @@ type = logical intent = in optional = F +[ldiag_ugwp] + standard_name = diag_ugwp_flag + long_name = flag for CIRES UGWP Diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F [cdmbgwd] standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag long_name = multiplication factors for cdmb and gwd units = none - dimensions = (2) + dimensions = (4) type = real kind = kind_phys intent = in @@ -657,6 +673,33 @@ kind = kind_phys intent = out optional = F +[du3dt_mtb] + standard_name = time_integral_of_change_in_x_wind_due_to_mountain_blocking_drag + long_name = time integral of change in x wind due to mountain blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_ogw] + standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = time integral of change in x wind due to orographic gw drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt_tms] + standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag + long_name = time integral of change in x wind due to TOFD + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [dudt] standard_name = tendency_of_x_wind_due_to_model_physics long_name = zonal wind tendency due to model physics @@ -747,6 +790,57 @@ kind = kind_phys intent = in optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[q_tke] + standard_name = turbulent_kinetic_energy + long_name = turbulent kinetic energy + units = J + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dqdt_tke] + standard_name = tendency_of_turbulent_kinetic_energy_due_to_model_physics + long_name = turbulent kinetic energy tendency due to model physics + units = J s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cires_ugwp_initialize.F90 b/physics/cires_ugwp_initialize.F90 index 6177100b7..fbcc1d205 100644 --- a/physics/cires_ugwp_initialize.F90 +++ b/physics/cires_ugwp_initialize.F90 @@ -37,28 +37,22 @@ module ugwp_common ! + use machine, only: kind_phys + use physcons, only : pi => con_pi, grav => con_g, rd => con_rd, & + rv => con_rv, cpd => con_cp, fv => con_fvirt,& + arad => con_rerth implicit none - real, parameter :: grav =9.80665, cpd = 1004.6, grcp = grav/cpd - real, parameter :: rd = 287.05 , rv =461.5 - real, parameter :: rgrav = 1.0/grav - - real, parameter :: fv = rv/rd - 1.0 - real, parameter :: rdi = 1.0 / rd - real, parameter :: gor = grav/rd - real, parameter :: gr2 = grav*gor - real, parameter :: gocp = grav/cpd - real, parameter :: pi = 4.*atan(1.0), pi2 = 2.*pi -! - real, parameter :: rad_to_deg=180.0/pi, deg_to_rad=pi/180.0 - - real, parameter :: arad = 6370.e3 - real, parameter :: rcpd2 = 0.5/cpd, rcpd = 1./cpd - real, parameter :: dw2min=1.0 - real, parameter :: bnv2min=1.e-6 - real, parameter :: velmin=sqrt(dw2min) - real, parameter :: omega1 = pi2/86400. - real, parameter :: omega2 = 2.*omega1 + real(kind=kind_phys), parameter :: grcp = grav/cpd, rgrav = 1.0d0/grav, & + rdi = 1.0d0/rd, & + gor = grav/rd, gr2 = grav*gor, gocp = grav/cpd, & + rcpd = 1./cpd, rcpd2 = 0.5*rcpd, & + pi2 = pi + pi, omega1 = pi2/86400.0, & + omega2 = omega1+omega1, & + rad_to_deg=180.0/pi, deg_to_rad=pi/180.0, & + dw2min=1.0, bnv2min=1.e-6, velmin=sqrt(dw2min) + + end module ugwp_common ! ! @@ -181,7 +175,7 @@ module ugwp_oro_init real, parameter :: frmax=10., frc =1.0, frmin =0.01 ! - real, parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 + real, parameter :: ce=0.8, ceofrc=ce/frc, cg=0.5 real, parameter :: gmax=1.0, veleps=1.0, factop=0.5 ! real, parameter :: rlolev=50000.0 @@ -212,27 +206,27 @@ module ugwp_oro_init data nwdir/6,7,5,8,2,3,1,4/ save nwdir - real, parameter :: odmin = 0.1, odmax = 10.0 + real, parameter :: odmin = 0.1, odmax = 10.0 !------------------------------------------------------------------------------ ! small-scale orography parameters for TOFD of Beljaars et al., 2004, QJRMS !------------------------------------------------------------------------------ - integer, parameter :: n_tofd=2 ! depth of SSO for TOFD compared with Zpbl - real, parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - real, parameter :: ze_tofd =1500.0 ! BJ's z-decay in meters - real, parameter :: a12_tofd =0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] - real, parameter :: ztop_tofd =10.*ze_tofd ! no TOFD > this height too higher 15 km + integer, parameter :: n_tofd = 2 ! depth of SSO for TOFD compared with Zpbl + real, parameter :: const_tofd = 0.0759 ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + real, parameter :: ze_tofd = 1500.0 ! BJ's z-decay in meters + real, parameter :: a12_tofd = 0.0002662*0.005363 ! BJ's k-spect const for sigf2 * a1*a2*exp(-[z/zdec]**1.5] + real, parameter :: ztop_tofd = 10.*ze_tofd ! no TOFD > this height too higher 15 km !------------------------------------------------------------------------------ ! real, parameter :: fcrit_sm = 0.7, fcrit_sm2 = fcrit_sm * fcrit_sm real, parameter :: fcrit_gfs = 0.7 real, parameter :: fcrit_mtb = 0.7 - real, parameter :: lzmax = 18.e3 ! 18 km - real, parameter :: mkzmin = 6.28/lzmax + real, parameter :: lzmax = 18.e3 ! 18 km + real, parameter :: mkzmin = 6.28/lzmax real, parameter :: mkz2min = mkzmin*mkzmin - real, parameter :: zbr_pi = 3./2.*4.*atan(1.0) ! 3pi/2 - real, parameter :: zbr_ifs = 2.*atan(1.0) ! pi/2 + real, parameter :: zbr_pi = (3.0/2.0)*pi + real, parameter :: zbr_ifs = 0.5*pi contains ! @@ -521,6 +515,7 @@ end module ugwp_lsatdis_init ! module ugwp_wmsdis_init + use ugwp_common, only : pi, pi2 implicit none real, parameter :: maxdudt = 250.e-5 @@ -554,7 +549,7 @@ module ugwp_wmsdis_init real , parameter :: zcimin = ucrit2 real , parameter :: zcimax = 125.0 real , parameter :: zgam = 0.25 - real , parameter :: zms_l = 2000.0 + real , parameter :: zms_l = 2000.0, zms = pi2 / zms_l, zmsi = 1.0 / zms integer :: ilaunch real :: gw_eff @@ -563,7 +558,7 @@ module ugwp_wmsdis_init integer :: nwav, nazd, nst real :: eff - real :: zaz_fct , zms + real :: zaz_fct real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) real, allocatable :: zcosang(:), zsinang(:) contains @@ -573,7 +568,6 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, ! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & ! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) ! - use ugwp_common, only : pi, pi2 implicit none ! !input -control for solvers: @@ -626,7 +620,7 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, ! set up azimuth directions and some trig factors ! ! - zang=pi2/float(nazd) + zang = pi2 / float(nazd) ! get normalization factor to ensure that the same amount of momentum ! flux is directed (n,s,e,w) no mater how many azimuths are selected. @@ -638,8 +632,8 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, zsinang(iazi) = sin(zang1) znorm = znorm + abs(zcosang(iazi)) enddo - zaz_fct = 1.0 - zaz_fct = 2.0 / znorm ! correction factot for azimuthal sums +! zaz_fct = 1.0 + zaz_fct = 2.0 / znorm ! correction factor for azimuthal sums ! define coordinate transform for "Ch" ....x = 1/c stretching transform ! ----------------------------------------------- @@ -660,7 +654,7 @@ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, ! if(lgacalc) zgam=(zxmax-zxmin)/log(zxmax/zxmin) ! zx1=zxran/(exp(zxran/zgam)-1.0_jprb) ! zx2=zxmin-zx1 - zms = 2.*pi/zms_l +! zms = pi2 / zms_l do inc=1, nwav ztx = real(inc-1)*zdx+zxmin zx = zx1*exp((ztx-zxmin)/zgam)+zx2 !eq. 29 of scinocca 2003 diff --git a/physics/cires_ugwp_post.F90 b/physics/cires_ugwp_post.F90 index 18acfa341..20be1fe74 100755 --- a/physics/cires_ugwp_post.F90 +++ b/physics/cires_ugwp_post.F90 @@ -20,12 +20,12 @@ end subroutine cires_ugwp_post_init subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & - gw_dudt, tau_tofd, tau_mtb, tau_ogw, tau_ngw, & - zmtb, zlwb, zogw, dudt_mtb, dudt_ogw, dudt_tms, & + gw_dtdt, gw_dudt, gw_dvdt, tau_tofd, tau_mtb, tau_ogw, & + tau_ngw, zmtb, zlwb, zogw, dudt_mtb, dudt_ogw, dudt_tms, & tot_zmtb, tot_zlwb, tot_zogw, & tot_tofd, tot_mtb, tot_ogw, tot_ngw, & - du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, & - cnvgwd, errmsg, errflg) + du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw, & + dtdt, dudt, dvdt, errmsg, errflg) use machine, only: kind_phys @@ -35,26 +35,22 @@ subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & integer, intent(in) :: im, levs real(kind=kind_phys), intent(in) :: dtf logical, intent(in) :: ldiag_ugwp !< flag for CIRES UGWP Diagnostics - logical, intent(inout) :: cnvgwd !< flag to turn on/off convective gwd real(kind=kind_phys), intent(in), dimension(im) :: zmtb, zlwb, zogw real(kind=kind_phys), intent(in), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw real(kind=kind_phys), intent(inout), dimension(im) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw real(kind=kind_phys), intent(inout), dimension(im) :: tot_zmtb, tot_zlwb, tot_zogw - real(kind=kind_phys), intent(in), dimension(im, levs) :: gw_dudt, dudt_mtb, dudt_ogw, dudt_tms - real(kind=kind_phys), intent(inout), dimension(im, levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw + real(kind=kind_phys), intent(in), dimension(im, levs) :: gw_dtdt, gw_dudt, gw_dvdt, dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(inout), dimension(im, levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + real(kind=kind_phys), intent(inout), dimension(im, levs) :: dtdt, dudt, dvdt character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - if (.not. (ldiag_ugwp)) return - - if (ldiag_ugwp) then tot_zmtb = tot_zmtb + dtf *zmtb tot_zlwb = tot_zlwb + dtf *zlwb @@ -68,11 +64,13 @@ subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & du3dt_mtb = du3dt_mtb + dtf *dudt_mtb du3dt_tms = du3dt_tms + dtf *dudt_tms du3dt_ogw = du3dt_ogw + dtf *dudt_ogw - du3dt_ngw = du3dt_ngw + dtf *gw_dudt - endif - + du3dt_ngw = du3dt_ngw + dtf *gw_dudt + dv3dt_ngw = dv3dt_ngw + dtf *gw_dvdt + endif - cnvgwd = .false. + dtdt = dtdt + gw_dtdt + dudt = dudt + gw_dudt + dvdt = dvdt + gw_dvdt end subroutine cires_ugwp_post_run diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 4414115d8..1f98aa8a4 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -39,6 +39,15 @@ type = integer intent = in optional = F +[gw_dtdt] + standard_name = tendency_of_air_temperature_due_to_ugwp + long_name = air temperature tendency due to UGWP + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F [gw_dudt] standard_name = tendency_of_x_wind_due_to_ugwp long_name = zonal wind tendency due to UGWP @@ -48,6 +57,15 @@ kind = kind_phys intent = in optional = F +[gw_dvdt] + standard_name = tendency_of_y_wind_due_to_ugwp + long_name = meridional wind tendency due to UGWP + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F [tau_tofd] standard_name = instantaneous_momentum_flux_due_to_turbulent_orographic_form_drag long_name = momentum flux or stress due to TOFD @@ -138,14 +156,6 @@ kind = kind_phys intent = in optional = F -[cnvgwd] - standard_name = flag_convective_gravity_wave_drag - long_name = flag for conv gravity wave drag - units = flag - dimensions = () - type = logical - intent = inout - optional = F [tot_zmtb] standard_name = time_integral_of_height_of_mountain_blocking long_name = time integral of height of mountain blocking drag @@ -245,6 +255,42 @@ kind = kind_phys intent = inout optional = F +[dv3dt_ngw] + standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave + long_name = time integral of change in y wind due to NGW + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 index 07782e44d..bb135b857 100644 --- a/physics/cires_ugwp_triggers.F90 +++ b/physics/cires_ugwp_triggers.F90 @@ -20,49 +20,45 @@ SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & ! geometric factors to compute deriv-es etc ... ! coriolis coslat tan etc... ! - earth_r = 6370.e3 - ra1 = 1.0 / earth_r - ra2 = ra1*ra1 + earth_r = 6370.e3 + ra1 = 1.0 / earth_r + ra2 = ra1*ra1 ! - rlat = lat*deg_to_rad - rlon = lon*deg_to_rad - tanlat = atan(rlat) - cosv = cos(rlat) - dy = rlat(2)-rlat(1) - dx = rlon(2)-rlon(1) + rlat = lat*deg_to_rad + rlon = lon*deg_to_rad + tanlat = atan(rlat) + cosv = cos(rlat) + dy = rlat(2)-rlat(1) + dx = rlon(2)-rlon(1) ! - - do j=1, ny-1 - rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) - enddo - - + do j=1, ny-1 + rlatc(j) = 0.5 * (rlat(j)+rlat(j+1)) + enddo ! - - do j=2, ny-1 - brcos(j) = 1.0 / cos(rlat(j))*ra1 - enddo + do j=2, ny-1 + brcos(j) = 1.0 / cos(rlat(j))*ra1 + enddo - brcos(1) = brcos(2) - brcos(ny) = brcos(ny-1) - brcos2 = brcos*brcos + brcos(1) = brcos(2) + brcos(ny) = brcos(ny-1) + brcos2 = brcos*brcos ! - dlam1 = brcos / (dx+dx) - dlam2 = brcos2 / (dx*dx) + dlam1 = brcos / (dx+dx) + dlam2 = brcos2 / (dx*dx) - dlat = ra1 / (dy+dy) + dlat = ra1 / (dy+dy) - divJp = dlat*cosv - divJM = dlat*cosv + divJp = dlat*cosv + divJM = dlat*cosv ! - do j=2, ny-1 - divJp(j) = dlat*cosv(j+1)/cosv(j) - divJM(j) = dlat*cosv(j-1)/cosv(j) - enddo - divJp(1) = divjp(2) !*divjp(1)/divjp(2) - divJp(ny) = divjp(1) - divJM(1) = divjM(2) !*divjM(1)/divjM(2) - divJM(ny) = divjM(1) + do j=2, ny-1 + divJp(j) = dlat*cosv(j+1)/cosv(j) + divJM(j) = dlat*cosv(j-1)/cosv(j) + enddo + divJp(1) = divjp(2) !*divjp(1)/divjp(2) + divJp(ny) = divjp(1) + divJM(1) = divjM(2) !*divjM(1)/divjM(2) + divJM(ny) = divjM(1) ! return end SUBROUTINE subs_diag_geo @@ -456,7 +452,7 @@ subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, t enddo ! if (dmax >= tlim_okw) then - nf_src = nf_src +1 + nf_src = nf_src + 1 if_src(i) = 1 taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) endif @@ -473,36 +469,29 @@ subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) !================= implicit none integer :: im - real :: xlatdeg(im), tau_amp - real :: tau_gw(im) - real :: latdeg -! real, parameter :: tau_amp = 100.e-3 - real :: trop_gw, flat_gw + real :: tau_amp, xlatdeg(im), tau_gw(im) + real :: latdeg, flat_gw, tem integer :: i ! ! if-lat ! - trop_gw = 0.75 do i=1, im - latdeg = xlatdeg(i) - if (-15.3 < latdeg .and. latdeg < 15.3) then - flat_gw = trop_gw*exp(-( (abs(latdeg)-3.)/8.0)**2) - if (flat_gw < 1.2 .and. abs(latdeg) <= 3.) flat_gw = trop_gw - else if (latdeg > -31. .and. latdeg <= -15.3) then - flat_gw = 0.10 - else if (latdeg < 31. .and. latdeg >= 15.3) then + latdeg = abs(xlatdeg(i)) + if (latdeg < 15.3) then + tem = (latdeg-3.0) / 8.0 + flat_gw = 0.75 * exp(-tem * tem) + if (flat_gw < 1.2 .and. latdeg <= 3.0) flat_gw = 0.75 + elseif (latdeg < 31.0 .and. latdeg >= 15.3) then flat_gw = 0.10 - else if (latdeg > -60. .and. latdeg <= -31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg < 60. .and. latdeg >= 31.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/23.)**2) - else if (latdeg <= -60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - else if (latdeg >= 60.) then - flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) - end if - tau_gw(i) = tau_amp*flat_gw + elseif (latdeg < 60.0 .and. latdeg >= 31.0) then + tem = (latdeg-60.0) / 23.0 + flat_gw = 0.50 * exp(- tem * tem) + elseif (latdeg >= 60.0) then + tem = (latdeg-60.0) / 70.0 + flat_gw = 0.50 * exp(- tem * tem) + endif + tau_gw(i) = tau_amp*flat_gw enddo ! end subroutine slat_geos5_tamp diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index a955f6247..956d5a1d0 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -181,9 +181,9 @@ module cs_conv ! spblcrit=0.03, & !< minimum cloudbase height in p/ps ! spblcrit=0.035,& !< minimum cloudbase height in p/ps ! spblcrit=0.025,& !< minimum cloudbase height in p/ps - cincrit= 150.0 -! cincrit= 120.0 -! cincrit= 100.0 + cincrit= -150.0 +! cincrit= -120.0 +! cincrit= -100.0 !DD precz0 and preczh control partitioning of water between detrainment !DD and precipitation. Decrease for more precip @@ -326,7 +326,7 @@ subroutine cs_conv_run(IM , IJSDIM , KMAX , ntracp1 , NN, & ! added for cs_convr real(r8), intent(inout) :: u(IM,KMAX) ! zonal wind at mid-layer (m/s) real(r8), intent(inout) :: v(IM,KMAX) ! meridional wind at mid-layer (m/s) - + real(r8), intent(in) :: DELTA ! physics time step real(r8), intent(in) :: DELTI ! dynamics time step (model time increment in seconds) logical, intent(in) :: do_aw, do_awdd, flx_form @@ -1089,19 +1089,19 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ELSE BUOY = (GDS(I,1)-GDS(I,K)) / (CP*GDT(I,K)) END IF - IF (BUOY > zero .AND. JBUOY(I) /= 0) THEN + IF (BUOY > zero .AND. JBUOY(I) >= -1) THEN CAPE(I) = CAPE(I) + BUOY * GRAV * (GDZM(I,K+1) - GDZM(I,K)) JBUOY(I) = 2 ELSEIF (BUOY < zero .AND. JBUOY(I) /= 2) THEN CIN(I) = CIN(I) - BUOY * GRAV * (GDZM(I,K+1) - GDZM(I,K)) - JBUOY(I) = 1 + JBUOY(I) = -1 ENDIF endif ENDDO ENDDO DO I=ISTS,IENS IF (JBUOY(I) /= 2) CIN(I) = -999.D0 - if (cin(i) > cincrit) kb(i) = -1 + if (cin(i) < cincrit) kb(i) = -1 ENDDO !DDsigma some initialization before summing over cloud type diff --git a/physics/dcyc2.f b/physics/dcyc2.f index dfcff8adc..92369d712 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -47,15 +47,18 @@ end subroutine dcyc2t3_finalize ! call dcyc2t3 ! ! inputs: ! ! ( solhr,slag,sdec,cdec,sinlat,coslat, ! -! xlon,coszen,tsea,tf,tsflw,sfcemis, ! +! xlon,coszen,tsfc_lnd,tsfc_ice,tsfc_ocn, ! +! tf,tsflw,sfcemis_lnd,sfcemis_ice,sfcemis_ocn, ! ! sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, ! ! sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, ! ! sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, ! ! ix, im, levs, deltim, fhswr, ! +! dry, icy, wet ! ! input/output: ! ! dtdt,dtdtc, ! ! outputs: ! -! adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, ! +! adjsfcdsw,adjsfcnsw,adjsfcdlw, ! +! adjsfculw_lnd,adjsfculw_ice,adjsfculw_ocn,xmu,xcosz, ! ! adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, ! ! adjdnnbmd,adjdnndfd,adjdnvbmd,adjdnvdfd) ! ! ! @@ -69,9 +72,13 @@ end subroutine dcyc2t3_finalize ! - real, sin and cos of latitude ! ! xlon (im) - real, longitude in radians ! ! coszen (im) - real, avg of cosz over daytime sw call interval ! -! tsea (im) - real, ground surface temperature (k) ! +! tsfc_lnd (im) - real, bottom surface temperature over land (k) ! +! tsfc_ice (im) - real, bottom surface temperature over ice (k) ! +! tsfc_ocn (im) - real, bottom surface temperature over ocean (k) ! ! tf (im) - real, surface air (layer 1) temperature (k) ! -! sfcemis(im) - real, surface emissivity (fraction) ! +! sfcemis_lnd(im) - real, surface emissivity (fraction) o. land (k) ! +! sfcemis_ice(im) - real, surface emissivity (fraction) o. ice (k) ! +! sfcemis_ocn(im) - real, surface emissivity (fraction) o. ocean (k)! ! tsflw (im) - real, sfc air (layer 1) temp in k saved in lw call ! ! sfcdsw (im) - real, total sky sfc downward sw flux ( w/m**2 ) ! ! sfcnsw (im) - real, total sky sfc net sw into ground (w/m**2) ! @@ -92,6 +99,9 @@ end subroutine dcyc2t3_finalize ! levs - integer, vertical layer dimension ! ! deltim - real, physics time step in seconds ! ! fhswr - real, Short wave radiation time step in seconds ! +! dry - logical, true over land ! +! icy - logical, true over ice ! +! wet - logical, true over water ! ! ! ! input/output: ! ! dtdt(im,levs)- real, model time step adjusted total radiation ! @@ -103,7 +113,9 @@ end subroutine dcyc2t3_finalize ! adjsfcdsw(im)- real, time step adjusted sfc dn sw flux (w/m**2) ! ! adjsfcnsw(im)- real, time step adj sfc net sw into ground (w/m**2)! ! adjsfcdlw(im)- real, time step adjusted sfc dn lw flux (w/m**2) ! -! adjsfculw(im)- real, sfc upward lw flux at current time (w/m**2) ! +! adjsfculw_lnd(im)- real, sfc upw. lw flux at current time (w/m**2)! +! adjsfculw_ice(im)- real, sfc upw. lw flux at current time (w/m**2)! +! adjsfculw_ocn(im)- real, sfc upw. lw flux at current time (w/m**2)! ! adjnirbmu(im)- real, t adj sfc nir-beam sw upward flux (w/m2) ! ! adjnirdfu(im)- real, t adj sfc nir-diff sw upward flux (w/m2) ! ! adjvisbmu(im)- real, t adj sfc uv+vis-beam sw upward flux (w/m2) ! @@ -165,14 +177,21 @@ end subroutine dcyc2t3_finalize !!\section dcyc2t3_general RRTMG dcyc2t3 General Algorithm !> @{ subroutine dcyc2t3_run & - & ( solhr,slag,sdec,cdec,sinlat,coslat, & ! --- inputs: - & xlon,coszen,tsea,tf,tsflw,sfcemis, & +! --- inputs: + & ( solhr,slag,sdec,cdec,sinlat,coslat, & + & xlon,coszen,tsfc_lnd,tsfc_ice,tsfc_ocn,tf,tsflw, & + & sfcemis_lnd, sfcemis_ice, sfcemis_ocn, & & sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, & & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & ix, im, levs, deltim, fhswr, & - & dtdt,dtdtc, & ! --- input/output: - & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, & ! --- outputs: + & dry, icy, wet, & +! & dry, icy, wet, lprnt, ipr, & +! --- input/output: + & dtdt,dtdtc, & +! --- outputs: + & adjsfcdsw,adjsfcnsw,adjsfcdlw, & + & adjsfculw_lnd,adjsfculw_ice,adjsfculw_ocn,xmu,xcosz, & & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, & & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd, & & errmsg,errflg & @@ -185,21 +204,30 @@ subroutine dcyc2t3_run & ! ! --- constant parameters: real(kind=kind_phys), parameter :: f_eps = 0.0001_kind_phys, & + & zero = 0.0d0, one = 1.0d0, & & hour12 = 12.0_kind_phys, & - & f3600 = 1.0/3600.0_kind_phys, & - & f7200 = 1.0/7200.0_kind_phys, & + & f3600 = one/3600.0_kind_phys, & + & f7200 = one/7200.0_kind_phys, & & czlimt = 0.0001_kind_phys, & ! ~ cos(89.99427) & pid12 = con_pi / hour12 ! --- inputs: integer, intent(in) :: ix, im, levs - real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr +! integer, intent(in) :: ipr +! logical lprnt + logical, dimension(im), intent(in) :: dry, icy, wet + real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & + & deltim, fhswr real(kind=kind_phys), dimension(im), intent(in) :: & - & sinlat, coslat, xlon, coszen, tsea, tf, tsflw, sfcdlw, & - & sfcdsw, sfcnsw, sfcemis + & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & + & sfcdsw, sfcnsw + + real(kind=kind_phys), dimension(im), intent(in) :: & + & tsfc_lnd, tsfc_ice, tsfc_ocn, & + & sfcemis_lnd, sfcemis_ice, sfcemis_ocn + real(kind=kind_phys), dimension(im), intent(in) :: & & sfcnirbmu, sfcnirdfu, sfcvisbmu, sfcvisdfu, & & sfcnirbmd, sfcnirdfd, sfcvisbmd, sfcvisdfd @@ -213,9 +241,13 @@ subroutine dcyc2t3_run & ! --- outputs: real(kind=kind_phys), dimension(im), intent(out) :: & - & adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + & adjsfcdsw, adjsfcnsw, adjsfcdlw, xmu, xcosz, & & adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & & adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd + + real(kind=kind_phys), dimension(im), intent(out) :: & + & adjsfculw_lnd, adjsfculw_ice, adjsfculw_ocn + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -246,12 +278,12 @@ subroutine dcyc2t3_run & xcosz(i) = coszen(i) enddo else - rstl = 1.0 / float(nstl) + rstl = one / float(nstl) solang = pid12 * (solhr - hour12) anginc = pid12 * deltim * f3600 * rstl do i = 1, im - xcosz(i) = 0.0 - istsun(i) = 0.0 + xcosz(i) = zero + istsun(i) = zero enddo do it=1,nstl cns = solang + (float(it)-0.5)*anginc + slag @@ -278,9 +310,24 @@ subroutine dcyc2t3_run & !! - compute \a sfc upward LW flux from current \a sfc temperature. ! note: sfc emiss effect is not appied here, and will be dealt in other place - tem2 = tsea(i) * tsea(i) - adjsfculw(i) = sfcemis(i) * con_sbc * tem2 * tem2 - & + (1.0 - sfcemis(i)) * adjsfcdlw(i) + if (dry(i)) then + tem2 = tsfc_lnd(i) * tsfc_lnd(i) + adjsfculw_lnd(i) = sfcemis_lnd(i) * con_sbc * tem2 * tem2 + & + (one - sfcemis_lnd(i)) * adjsfcdlw(i) + endif + if (icy(i)) then + tem2 = tsfc_ice(i) * tsfc_ice(i) + adjsfculw_ice(i) = sfcemis_ice(i) * con_sbc * tem2 * tem2 + & + (one - sfcemis_ice(i)) * adjsfcdlw(i) + endif + if (wet(i)) then + tem2 = tsfc_ocn(i) * tsfc_ocn(i) + adjsfculw_ocn(i) = sfcemis_ocn(i) * con_sbc * tem2 * tem2 + & + (one - sfcemis_ocn(i)) * adjsfcdlw(i) + endif +! if (lprnt .and. i == ipr) write(0,*)' in dcyc3: dry==',dry(i) +! &,' wet=',wet(i),' icy=',icy(i),' tsfc3=',tsfc3(i,:) +! &,' sfcemis=',sfcemis(i,:),' adjsfculw=',adjsfculw(i,:) ! !> - normalize by average value over radiation period for daytime. diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 2dc538e26..c4a8d9051 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -83,9 +83,27 @@ kind = kind_phys intent = in optional = F -[tsea] - standard_name = surface_skin_temperature - long_name = surface skin temperature +[tsfc_lnd] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc_ocn] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc_ice] + standard_name = surface_skin_temperature_over_ice_interstitial + long_name = surface skin temperature over ice (temporary use as interstitial) units = K dimensions = (horizontal_dimension) type = real @@ -110,9 +128,27 @@ kind = kind_phys intent = in optional = F -[sfcemis] - standard_name = surface_longwave_emissivity - long_name = surface emissivity +[sfcemis_lnd] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfcemis_ice] + standard_name = surface_longwave_emissivity_over_ice_interstitial + long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfcemis_ocn] + standard_name = surface_longwave_emissivity_over_ocean_interstitial + long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) units = frac dimensions = (horizontal_dimension) type = real @@ -296,6 +332,30 @@ kind = kind_phys intent = in optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F [dtdt] standard_name = tendency_of_air_temperature_due_to_model_physics long_name = total radiative heating rate at current time @@ -341,9 +401,27 @@ kind = kind_phys intent = out optional = F -[adjsfculw] - standard_name = surface_upwelling_longwave_flux - long_name = surface upwelling longwave flux at current time +[adjsfculw_lnd] + standard_name = surface_upwelling_longwave_flux_over_land_interstitial + long_name = surface upwelling longwave flux at current time over land (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[adjsfculw_ice] + standard_name = surface_upwelling_longwave_flux_over_ice_interstitial + long_name = surface upwelling longwave flux at current time over ice (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[adjsfculw_ocn] + standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial + long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) units = W m-2 dimensions = (horizontal_dimension) type = real diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index b6cd62c0c..fcb55d84f 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -23,7 +23,6 @@ and how stochastic perturbations are used in the Noah Land Surface Model. h2o_phys gfs_control_type flag for stratosphere h2o scheme .false. ldiag3d gfs_control_type flag for 3D diagnostic fields .false. lssav gfs_control_type logical flag for storing diagnostics .false. -lgocart gfs_control_type logical flag for 3D diagnostic fields for gocart 1 .false. cplflx gfs_control_type logical flag for cplflx collection .false. cplwav gfs_control_type logical flag for cplwav collection .false. cplchm gfs_control_type logical flag for chemistry collection .false. diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index fcaaa9b94..1ccedb956 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -113,7 +113,7 @@ end subroutine gfdl_cloud_microphys_finalize !! \htmlinclude gfdl_cloud_microphys_run.html !! subroutine gfdl_cloud_microphys_run( & - levs, im, con_g, con_fvirt, con_rd, frland, garea, & + levs, im, con_g, con_fvirt, con_rd, frland, garea, islmsk, & gq0, gq0_ntcw, gq0_ntrw, gq0_ntiw, gq0_ntsw, gq0_ntgl, gq0_ntclamt, & gt0, gu0, gv0, vvl, prsl, phii, del, & rain0, ice0, snow0, graupel0, prcp0, sr, & @@ -136,6 +136,7 @@ subroutine gfdl_cloud_microphys_run( & integer, intent(in ) :: levs, im real(kind=kind_phys), intent(in ) :: con_g, con_fvirt, con_rd real(kind=kind_phys), intent(in ), dimension(1:im) :: frland, garea + integer, intent(in ), dimension(1:im) :: islmsk real(kind=kind_phys), intent(inout), dimension(1:im,1:levs) :: gq0, gq0_ntcw, gq0_ntrw, gq0_ntiw, & gq0_ntsw, gq0_ntgl, gq0_ntclamt real(kind=kind_phys), intent(inout), dimension(1:im,1:levs) :: gt0, gu0, gv0 @@ -298,9 +299,11 @@ subroutine gfdl_cloud_microphys_run( & enddo enddo call cloud_diagnosis (1, im, 1, levs, den(1:im,1:levs), & + del(1:im,1:levs), islmsk(1:im), & gq0_ntcw(1:im,1:levs), gq0_ntiw(1:im,1:levs), & - gq0_ntrw(1:im,1:levs), gq0_ntsw(1:im,1:levs), & - gq0_ntgl(1:im,1:levs), gt0(1:im,1:levs), & + gq0_ntrw(1:im,1:levs), & + gq0_ntsw(1:im,1:levs) + gq0_ntgl(1:im,1:levs), & + gq0_ntgl(1:im,1:levs)*0.0, gt0(1:im,1:levs), & rew(1:im,1:levs), rei(1:im,1:levs), rer(1:im,1:levs),& res(1:im,1:levs), reg(1:im,1:levs)) deallocate(den) diff --git a/physics/gfdl_cloud_microphys.meta b/physics/gfdl_cloud_microphys.meta index c2ce3f8f5..7f31637bf 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/gfdl_cloud_microphys.meta @@ -180,6 +180,14 @@ kind = kind_phys intent = in optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F [gq0] standard_name = water_vapor_specific_humidity_updated_by_physics long_name = water vapor specific humidity updated by physics diff --git a/physics/gfdl_fv_sat_adj.F90 b/physics/gfdl_fv_sat_adj.F90 index 14b3975f3..f5c84cd99 100644 --- a/physics/gfdl_fv_sat_adj.F90 +++ b/physics/gfdl_fv_sat_adj.F90 @@ -49,7 +49,7 @@ module fv_sat_adj ! gfdl_cloud_microphys_mod ! ql_gen, qi_gen, qi0_max, ql_mlt, ql0_max, qi_lim, qs_mlt, ! tau_r2g, tau_smlt, tau_i2s, tau_v2l, tau_l2v, tau_imlt, tau_l2r, -! rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land +! rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land, tintqs ! ! ! DH* TODO - MAKE THIS INPUT ARGUMENTS *DH @@ -64,8 +64,7 @@ module fv_sat_adj use gfdl_cloud_microphys_mod, only: ql_gen, qi_gen, qi0_max, ql_mlt, ql0_max, qi_lim, qs_mlt use gfdl_cloud_microphys_mod, only: icloud_f, sat_adj0, t_sub, cld_min use gfdl_cloud_microphys_mod, only: tau_r2g, tau_smlt, tau_i2s, tau_v2l, tau_l2v, tau_imlt, tau_l2r - use gfdl_cloud_microphys_mod, only: rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land - + use gfdl_cloud_microphys_mod, only: rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land, tintqs #ifdef MULTI_GASES use ccpp_multi_gases_mod, only: multi_gases_init, & multi_gases_finalize, & @@ -1030,9 +1029,13 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, do i = is, ie + if(tintqs) then + tin = pt1(i) + else tin = pt1 (i) - (lcp2 (i) * q_cond (i) + icp2 (i) * q_sol (i)) ! minimum temperature ! tin = pt1 (i) - ((lv00 + d0_vap * pt1 (i)) * q_cond (i) + & ! (li00 + dc_ice * pt1 (i)) * q_sol (i)) / (mc_air (i) + qpz (i) * c_vap) + endif ! ----------------------------------------------------------------------- ! determine saturated specific humidity @@ -1075,14 +1078,14 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, ! icloud_f = 2: binary cloud scheme (0 / 1) ! ----------------------------------------------------------------------- - if (rh > 0.75 .and. qpz (i) > 1.e-6) then + if (rh > 0.75 .and. qpz (i) > 1.e-8) then dq = hvar (i) * qpz (i) q_plus = qpz (i) + dq q_minus = qpz (i) - dq if (icloud_f == 2) then if (qpz (i) > qstar (i)) then qa (i, j) = 1. - elseif (qstar (i) < q_plus .and. q_cond (i) > 1.e-6) then + elseif (qstar (i) < q_plus .and. q_cond (i) > 1.e-8) then qa (i, j) = ((q_plus - qstar (i)) / dq) ** 2 qa (i, j) = min (1., qa (i, j)) else @@ -1102,7 +1105,7 @@ subroutine fv_sat_adj_work(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, qa (i, j) = 0. endif ! impose minimum cloudiness if substantial q_cond (i) exist - if (q_cond (i) > 1.e-6) then + if (q_cond (i) > 1.e-8) then qa (i, j) = max (cld_min, qa (i, j)) endif qa (i, j) = min (1., qa (i, j)) diff --git a/physics/gwdc.f b/physics/gwdc.f index 80898c47b..9909a3100 100644 --- a/physics/gwdc.f +++ b/physics/gwdc.f @@ -22,7 +22,7 @@ end subroutine gwdc_pre_init subroutine gwdc_pre_run ( & & im, cgwf, dx, work1, work2, dlength, cldf, & & levs, kbot, ktop, dtp, gt0, gt0_init, del, cumabs, & - & errmsg, errflg ) + & do_cnvgwd, errmsg, errflg ) use machine, only : kind_phys implicit none @@ -38,6 +38,7 @@ subroutine gwdc_pre_run ( & real(kind=kind_phys), intent(out) :: & & dlength(:), cldf(:), cumabs(:) + logical, intent(in) :: do_cnvgwd character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -49,6 +50,14 @@ subroutine gwdc_pre_run ( & errmsg = '' errflg = 0 + ! DH* + if (.not. do_cnvgwd) then + write(0,*) "ERROR: , GWDC_PRE CALLED BUT DO_CNVGWD FALSE" + call sleep(5) + stop + end if + ! *DH + do i = 1, im tem1 = dx(i) tem2 = tem1 diff --git a/physics/gwdc.meta b/physics/gwdc.meta index b87529aec..2151cc5f7 100644 --- a/physics/gwdc.meta +++ b/physics/gwdc.meta @@ -137,6 +137,14 @@ kind = kind_phys intent = out optional = F +[do_cnvgwd] + standard_name = flag_for_convective_gravity_wave_drag + long_name = flag for convective gravity wave drag (gwd) + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/gwdps.f b/physics/gwdps.f index 366a8b974..a29c89218 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -294,6 +294,9 @@ subroutine gwdps_run( & ! ! ******************************************************************** USE MACHINE , ONLY : kind_phys + ! DH* + use GFS_diagtoscreen + ! *DH implicit none ! ! Interface variables @@ -303,7 +306,7 @@ subroutine gwdps_run( & ! changes the results on Theia/Intel - skip for bit-for-bit results *DH ! real(kind=kind_phys), intent(in) :: & ! & deltim, G, CP, RD, RV, cdmbgwd(2) - real(kind=kind_phys) deltim, G, CP, RD, RV, cdmbgwd(2) + real(kind=kind_phys) deltim, G, CP, RD, RV, cdmbgwd(4) ! *DH real(kind=kind_phys), intent(inout) :: & & A(IX,KM), B(IX,KM), C(IX,KM) @@ -382,7 +385,8 @@ subroutine gwdps_run( & real(kind=kind_phys) TAUB(IM), XN(IM), YN(IM), UBAR(IM) & &, VBAR(IM), ULOW(IM), OA(IM), CLX(IM) & &, ROLL(IM), ULOI(IM) & - &, DTFAC(IM), XLINV(IM), DELKS(IM), DELKS1(IM) + &, DTFAC(IM), XLINV(IM), DELKS(IM) +! &, DTFAC(IM), XLINV(IM), DELKS(IM), DELKS1(IM) ! real(kind=kind_phys) BNV2(IM,KM), TAUP(IM,KM+1), ri_n(IM,KM) & &, TAUD(IM,KM), RO(IM,KM), VTK(IM,KM) & @@ -392,7 +396,8 @@ subroutine gwdps_run( & ! real(kind=kind_phys) VELKO(KM-1) integer kref(IM), kint(im), iwk(im), ipt(im) ! for lm mtn blocking - integer kreflm(IM), iwklm(im) + integer iwklm(im) +! integer kreflm(IM), iwklm(im) integer idxzb(im), ktrial, klevm1 ! real(kind=kind_phys) gor, gocp, fv, gr2, bnv, fr & @@ -410,6 +415,48 @@ subroutine gwdps_run( & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + + call print_var(-999, -999, -999, "IM :", IM ) + call print_var(-999, -999, -999, "IX :", IX ) + call print_var(-999, -999, -999, "KM :", KM ) + call print_var(-999, -999, -999, "A :", A ) + call print_var(-999, -999, -999, "B :", B ) + call print_var(-999, -999, -999, "C :", C ) + call print_var(-999, -999, -999, "U1 :", U1 ) + call print_var(-999, -999, -999, "V1 :", V1 ) + call print_var(-999, -999, -999, "T1 :", T1 ) + call print_var(-999, -999, -999, "Q1 :", Q1 ) + call print_var(-999, -999, -999, "KPBL :", KPBL ) + call print_var(-999, -999, -999, "PRSI :", PRSI ) + call print_var(-999, -999, -999, "DEL :", DEL ) + call print_var(-999, -999, -999, "PRSL :", PRSL ) + call print_var(-999, -999, -999, "PRSLK :", PRSLK ) + call print_var(-999, -999, -999, "PHII :", PHII ) + call print_var(-999, -999, -999, "PHIL :", PHIL ) + call print_var(-999, -999, -999, "DELTIM :", DELTIM ) + call print_var(-999, -999, -999, "KDT :", KDT ) + call print_var(-999, -999, -999, "HPRIME :", HPRIME ) + call print_var(-999, -999, -999, "OC :", OC ) + call print_var(-999, -999, -999, "OA4 :", OA4 ) + call print_var(-999, -999, -999, "CLX4 :", CLX4 ) + call print_var(-999, -999, -999, "THETA :", THETA ) + call print_var(-999, -999, -999, "SIGMA :", SIGMA ) + call print_var(-999, -999, -999, "GAMMA :", GAMMA ) + call print_var(-999, -999, -999, "ELVMAX :", ELVMAX ) + call print_var(-999, -999, -999, "DUSFC :", DUSFC ) + call print_var(-999, -999, -999, "DVSFC :", DVSFC ) + call print_var(-999, -999, -999, "G :", G ) + call print_var(-999, -999, -999, "CP :", CP ) + call print_var(-999, -999, -999, "RD :", RD ) + call print_var(-999, -999, -999, "RV :", RV ) + call print_var(-999, -999, -999, "IMX :", IMX ) + call print_var(-999, -999, -999, "nmtvr :", nmtvr ) + !call print_var(-999, -999, -999, "cdmbgwd :", cdmbgwd) + call print_var(-999, -999, -999, "me :", me ) + call print_var(-999, -999, -999, "lprnt :", lprnt ) + call print_var(-999, -999, -999, "ipr :", ipr ) + call print_var(-999, -999, -999, "rdxzb :", rdxzb ) + ! ! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) ! non-dim sub grid mtn drag Amp (*j*) @@ -470,7 +517,7 @@ subroutine gwdps_run( & do i=1,npt iwklm(i) = 2 IDXZB(i) = 0 - kreflm(i) = 0 +! kreflm(i) = 0 enddo ! if (lprnt) ! & print *,' in gwdps_lm.f npt,IM,IX,IY,km,me=',npt,IM,IX,IY,km,me @@ -552,14 +599,14 @@ subroutine gwdps_run( & ! DO I = 1, npt J = ipt(i) - DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,iwklm(i))) - DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,iwklm(i))) - UBAR (I) = 0.0 - VBAR (I) = 0.0 - ROLL (I) = 0.0 - PE (I) = 0.0 - EK (I) = 0.0 - BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2LM(I,1) + DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,iwklm(i))) +! DELKS1(I) = 1.0 / (PRSI(J,1) - PRSL(J,iwklm(i))) + UBAR (I) = 0.0 + VBAR (I) = 0.0 + ROLL (I) = 0.0 + PE (I) = 0.0 + EK (I) = 0.0 + BNV2bar(I) = (PRSI(J,1)-PRSL(J,1)) * DELKS(I) * BNV2LM(I,1) ENDDO ! --- find the dividing stream line height @@ -567,13 +614,13 @@ subroutine gwdps_run( & ! --- iwklm(i) is the k-index of mtn elvmax elevation !> - Find the dividing streamline height starting from the level above !! the maximum mountain height and processing downward. - DO Ktrial = KMLL, 1, -1 - DO I = 1, npt - IF ( Ktrial < iwklm(I) .and. kreflm(I) == 0 ) then - kreflm(I) = Ktrial - ENDIF - ENDDO - ENDDO +! DO Ktrial = KMLL, 1, -1 +! DO I = 1, npt +! IF ( Ktrial < iwklm(I) .and. kreflm(I) == 0 ) then +! kreflm(I) = Ktrial +! ENDIF +! ENDDO +! ENDDO ! print *,' in gwdps_lm.f 4 npt=',npt,kreflm(npt),me ! ! --- in the layer kreflm(I) to 1 find PE (which needs N, ELVMAX) @@ -582,13 +629,17 @@ subroutine gwdps_run( & ! --- is the vert ave of quantities from the surface to mtn top. ! DO I = 1, npt - DO K = 1, Kreflm(I) + DO K = 1, iwklm(i)-1 J = ipt(i) RDELKS = DEL(J,K) * DELKS(I) UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) + if (k < iwklm(I)-1) then + RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) + else + RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) + endif BNV2bar(I) = BNV2bar(I) + BNV2lm(I,K) * RDELKS ! --- these vert ave are for diags, testing and GWD to follow (*j*). ENDDO @@ -862,14 +913,14 @@ subroutine gwdps_run( & J = ipt(i) kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,kref(I))) - DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,kref(I))) +! DELKS1(I) = 1.0 / (PRSI(J,1) - PRSL(J,kref(I))) UBAR (I) = 0.0 VBAR (I) = 0.0 ROLL (I) = 0.0 KBPS = MAX(KBPS, kref(I)) KMPS = MIN(KMPS, kref(I)) ! - BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2(I,1) + BNV2bar(I) = (PRSI(J,1)-PRSL(J,1)) * DELKS(I) * BNV2(I,1) ENDDO ! print *,' in gwdps_lm.f GWD:15 =',KBPS,KMPS KBPSP1 = KBPS + 1 @@ -883,7 +934,11 @@ subroutine gwdps_run( & VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! Mean V below kref ! ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! Mean RO below kref - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) + if (k < kref(i)-1) then + RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) + else + RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) + endif BNV2bar(I) = BNV2bar(I) + BNV2(I,K) * RDELKS ENDIF ENDDO @@ -1299,6 +1354,48 @@ subroutine gwdps_run( & ! ! print *,' in gwdps_lm.f 18 =',A(ipt(1),idxzb(1)) ! &, B(ipt(1),idxzb(1)),me + + call print_var(-777, -777, -777, "IM :", IM ) + call print_var(-777, -777, -777, "IX :", IX ) + call print_var(-777, -777, -777, "KM :", KM ) + call print_var(-777, -777, -777, "A :", A ) + call print_var(-777, -777, -777, "B :", B ) + call print_var(-777, -777, -777, "C :", C ) + call print_var(-777, -777, -777, "U1 :", U1 ) + call print_var(-777, -777, -777, "V1 :", V1 ) + call print_var(-777, -777, -777, "T1 :", T1 ) + call print_var(-777, -777, -777, "Q1 :", Q1 ) + call print_var(-777, -777, -777, "KPBL :", KPBL ) + call print_var(-777, -777, -777, "PRSI :", PRSI ) + call print_var(-777, -777, -777, "DEL :", DEL ) + call print_var(-777, -777, -777, "PRSL :", PRSL ) + call print_var(-777, -777, -777, "PRSLK :", PRSLK ) + call print_var(-777, -777, -777, "PHII :", PHII ) + call print_var(-777, -777, -777, "PHIL :", PHIL ) + call print_var(-777, -777, -777, "DELTIM :", DELTIM ) + call print_var(-777, -777, -777, "KDT :", KDT ) + call print_var(-777, -777, -777, "HPRIME :", HPRIME ) + call print_var(-777, -777, -777, "OC :", OC ) + call print_var(-777, -777, -777, "OA4 :", OA4 ) + call print_var(-777, -777, -777, "CLX4 :", CLX4 ) + call print_var(-777, -777, -777, "THETA :", THETA ) + call print_var(-777, -777, -777, "SIGMA :", SIGMA ) + call print_var(-777, -777, -777, "GAMMA :", GAMMA ) + call print_var(-777, -777, -777, "ELVMAX :", ELVMAX ) + call print_var(-777, -777, -777, "DUSFC :", DUSFC ) + call print_var(-777, -777, -777, "DVSFC :", DVSFC ) + call print_var(-777, -777, -777, "G :", G ) + call print_var(-777, -777, -777, "CP :", CP ) + call print_var(-777, -777, -777, "RD :", RD ) + call print_var(-777, -777, -777, "RV :", RV ) + call print_var(-777, -777, -777, "IMX :", IMX ) + call print_var(-777, -777, -777, "nmtvr :", nmtvr ) + !call print_var(-777, -777, -777, "cdmbgwd :", cdmbgwd) + call print_var(-777, -777, -777, "me :", me ) + call print_var(-777, -777, -777, "lprnt :", lprnt ) + call print_var(-777, -777, -777, "ipr :", ipr ) + call print_var(-777, -777, -777, "rdxzb :", rdxzb ) + RETURN end subroutine gwdps_run !> @} diff --git a/physics/gwdps.meta b/physics/gwdps.meta index 97b6abae3..0a141b208 100644 --- a/physics/gwdps.meta +++ b/physics/gwdps.meta @@ -318,7 +318,7 @@ standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag long_name = multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag units = none - dimensions = (2) + dimensions = (4) type = real kind = kind_phys intent = in diff --git a/physics/machine.F b/physics/machine.F index ea6198c33..896b665da 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -1,10 +1,8 @@ module machine -#if 0 !! \section arg_table_machine !! \htmlinclude machine.html !! -#endif implicit none diff --git a/physics/module_gfdl_cloud_microphys.F90 b/physics/module_gfdl_cloud_microphys.F90 index ac3795566..2f6e5ec1a 100644 --- a/physics/module_gfdl_cloud_microphys.F90 +++ b/physics/module_gfdl_cloud_microphys.F90 @@ -1,6 +1,9 @@ !> \file gfdl_cloud_microphys.F90 -!! This file contains the column GFDL cloud microphysics ( Chen and Lin (2013) -!! \cite chen_and_lin_2013 ). +!! This file contains the full GFDL cloud microphysics (Chen and Lin (2013) +!! \cite chen_and_lin_2013 and Zhou et al. 2019 \cite zhou2019toward). +!! The module is paired with 'gfdl_fv_sat_adj', which performs the "fast" +!! processes +!>author Shian-Jiann Lin, Linjiong Zhou !*********************************************************************** !* GNU Lesser General Public License !* @@ -285,6 +288,18 @@ module gfdl_cloud_microphys_mod real :: log_10, tice0, t_wfr + integer :: reiflag = 1 + ! 1: Heymsfield and Mcfarquhar, 1996 + ! 2: Wyser, 1998 + + logical :: tintqs = .false. !< use temperature in the saturation mixing in PDF + + real :: rewmin = 5.0, rewmax = 10.0 + real :: reimin = 10.0, reimax = 150.0 + real :: rermin = 10.0, rermax = 10000.0 + real :: resmin = 150.0, resmax = 10000.0 + real :: regmin = 300.0, regmax = 10000.0 + ! ----------------------------------------------------------------------- ! namelist ! ----------------------------------------------------------------------- @@ -299,7 +314,9 @@ module gfdl_cloud_microphys_mod tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & + mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & + resmin, resmax, regmin, regmax, tintqs public & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & @@ -311,7 +328,9 @@ module gfdl_cloud_microphys_mod tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print + do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & + mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & + resmin, resmax, regmin, regmax, tintqs contains @@ -3301,7 +3320,7 @@ subroutine fall_speed (ktop, kbot, den, qs, qi, qg, ql, tk, vts, vti, vtg) else tc (k) = tk (k) - tice vti (k) = (3. + log10 (qi (k) * den (k))) * (tc (k) * (aa * tc (k) + bb) + cc) + dd * tc (k) + ee - vti (k) = vi0 * exp (log_10 * vti (k)) + vti (k) = vi0 * exp (log_10 * vti (k)) * 0.8 vti (k) = min (vi_max, max (vf_min, vti (k))) endif enddo @@ -4683,127 +4702,141 @@ end subroutine interpolate_z !> \ingroup mod_gfdl_cloud_mp !! The subroutine 'cloud_diagnosis' diagnoses the radius of cloud !! species. -subroutine cloud_diagnosis (is, ie, js, je, den, qw, qi, qr, qs, qg, t, & +!>author Linjiong Zhoum, Shian-Jiann Lin +! ======================================================================= +subroutine cloud_diagnosis (is, ie, ks, ke, den, delp, lsm, qmw, qmi, qmr, qms, qmg, t, & rew, rei, rer, res, reg) -! qcw, qci, qcr, qcs, qcg, rew, rei, rer, res, reg) implicit none - integer, intent (in) :: is, ie, js, je + integer, intent (in) :: is, ie, ks, ke + integer, intent (in), dimension (is:ie) :: lsm ! land sea mask, 0: ocean, 1: land, 2: sea ice - real, intent (in), dimension (is:ie, js:je) :: den, t - real, intent (in), dimension (is:ie, js:je) :: qw, qi, qr, qs, qg ! units: kg / kg + real, intent (in), dimension (is:ie, ks:ke) :: den, delp, t + real, intent (in), dimension (is:ie, ks:ke) :: qmw, qmi, qmr, qms, qmg !< units: kg / kg -! real, intent (out), dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg ! units: kg / m^3 - real, dimension (is:ie, js:je) :: qcw, qci, qcr, qcs, qcg ! units: kg / m^3 - real, intent (out), dimension (is:ie, js:je) :: rew, rei, rer, res, reg ! units: micron + real, intent (out), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg !< units: micron - integer :: i, j + real, dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg !< units: g / m^2 + + integer :: i, k real :: lambdar, lambdas, lambdag + real :: dpg, rei_fac, mask, ccn, bw + real, parameter :: rho_0 = 50.e-3 real :: rhow = 1.0e3, rhor = 1.0e3, rhos = 1.0e2, rhog = 4.0e2 real :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 real :: alphar = 0.8, alphas = 0.25, alphag = 0.5 real :: gammar = 17.837789, gammas = 8.2850630, gammag = 11.631769 -! real :: qmin = 1.0e-5, ccn = 1.0e8, beta = 1.22 -! real :: qmin = 5.0e-6, ccn = 1.0e8, beta = 1.22 - real :: qmin = 9.0e-6, ccn = 1.0e8, beta = 1.22 -! real :: qmin = 1.0e-6, ccn = 1.0e8, beta = 1.22 -! real :: qmin = 1.0e-8, ccn = 1.0e8, beta = 1.22 -! real :: qmin = 1.0e-12, ccn = 1.0e8, beta = 1.22 - - ! real :: rewmin = 1.0, rewmax = 25.0 - ! real :: reimin = 10.0, reimax = 300.0 - ! real :: rermin = 25.0, rermax = 225.0 - ! real :: resmin = 300, resmax = 1000.0 - ! real :: regmin = 1000.0, regmax = 1.0e5 - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 -! real :: rermin = 0.0, rermax = 10000.0 -! real :: resmin = 0.0, resmax = 10000.0 -! real :: regmin = 0.0, regmax = 10000.0 - real :: rermin = 50.0, rermax = 10000.0 - real :: resmin = 100.0, resmax = 10000.0 - real :: regmin = 300.0, regmax = 10000.0 + real :: qmin = 1.0e-12, beta = 1.22 - do j = js, je + do k = ks, ke do i = is, ie + + dpg = abs (delp (i, k)) / grav + mask = min (max (real(lsm (i)), 0.0), 2.0) ! ----------------------------------------------------------------------- - ! cloud water (martin et al., 1994) + ! cloud water (Martin et al., 1994) ! ----------------------------------------------------------------------- - if (qw (i, j) .gt. qmin) then - qcw (i, j) = den (i, j) * qw (i, j) - rew (i, j) = exp (1.0 / 3.0 * log ((3 * qcw (i, j)) / (4 * pi * rhow * ccn))) * 1.0e6 - rew (i, j) = max (rewmin, min (rewmax, rew (i, j))) + ccn = 0.80 * (- 1.15e-3 * (ccn_o ** 2) + 0.963 * ccn_o + 5.30) * abs (mask - 1.0) + & + 0.67 * (- 2.10e-4 * (ccn_l ** 2) + 0.568 * ccn_l - 27.9) * (1.0 - abs (mask - 1.0)) + + if (qmw (i, k) .gt. qmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * den (i, k) * qmw (i, k)) / (4.0 * pi * rhow * ccn))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) else - qcw (i, j) = 0.0 - rew (i, j) = rewmin + qcw (i, k) = 0.0 + rew (i, k) = rewmin endif + + if (reiflag .eq. 1) then ! ----------------------------------------------------------------------- - ! cloud ice (heymsfield and mcfarquhar, 1996) + ! cloud ice (Heymsfield and Mcfarquhar, 1996) ! ----------------------------------------------------------------------- - if (qi (i, j) .gt. qmin) then - qci (i, j) = den (i, j) * qi (i, j) - if (t (i, j) - tice .lt. - 50) then - rei (i, j) = beta / 9.917 * exp ((1 - 0.891) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 40) then - rei (i, j) = beta / 9.337 * exp ((1 - 0.920) * log (1.0e3 * qci (i, j))) * 1.0e3 - elseif (t (i, j) - tice .lt. - 30) then - rei (i, j) = beta / 9.208 * exp ((1 - 0.945) * log (1.0e3 * qci (i, j))) * 1.0e3 + if (qmi (i, k) .gt. qmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei_fac = log (1.0e3 * qmi (i, k) * den (i, k)) + if (t (i, k) - tice .lt. - 50) then + rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3 + elseif (t (i, k) - tice .lt. - 40) then + rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3 + elseif (t (i, k) - tice .lt. - 30) then + rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3 else - rei (i, j) = beta / 9.387 * exp ((1 - 0.969) * log (1.0e3 * qci (i, j))) * 1.0e3 + rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3 endif - rei (i, j) = max (reimin, min (reimax, rei (i, j))) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) else - qci (i, j) = 0.0 - rei (i, j) = reimin + qci (i, k) = 0.0 + rei (i, k) = reimin endif + endif + + if (reiflag .eq. 2) then + ! ----------------------------------------------------------------------- - ! rain (lin et al., 1983) + ! cloud ice (Wyser, 1998) ! ----------------------------------------------------------------------- - if (qr (i, j) .gt. qmin) then - qcr (i, j) = den (i, j) * qr (i, j) - lambdar = exp (0.25 * log (pi * rhor * n0r / qcr (i, j))) - rer (i, j) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 - rer (i, j) = max (rermin, min (rermax, rer (i, j))) + if (qmi (i, k) .gt. qmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + bw = - 2. + 1.e-3 * log10 (den (i, k) * qmi (i, k) / rho_0) * max (0.0, tice - t (i, k)) ** 1.5 + rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw)) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) else - qcr (i, j) = 0.0 - rer (i, j) = rermin + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + endif ! ----------------------------------------------------------------------- - ! snow (lin et al., 1983) + ! rain (Lin et al., 1983) ! ----------------------------------------------------------------------- - if (qs (i, j) .gt. qmin) then - qcs (i, j) = den (i, j) * qs (i, j) - lambdas = exp (0.25 * log (pi * rhos * n0s / qcs (i, j))) - res (i, j) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 - res (i, j) = max (resmin, min (resmax, res (i, j))) + if (qmr (i, k) .gt. qmin) then + qcr (i, k) = dpg * qmr (i, k) * 1.0e3 + lambdar = exp (0.25 * log (pi * rhor * n0r / qmr (i, k) / den (i, k))) + rer (i, k) = 0.5 * exp (log (gammar / 6) / alphar) / lambdar * 1.0e6 + rer (i, k) = max (rermin, min (rermax, rer (i, k))) else - qcs (i, j) = 0.0 - res (i, j) = resmin + qcr (i, k) = 0.0 + rer (i, k) = rermin endif ! ----------------------------------------------------------------------- - ! graupel (lin et al., 1983) + ! snow (Lin et al., 1983) ! ----------------------------------------------------------------------- - if (qg (i, j) .gt. qmin) then - qcg (i, j) = den (i, j) * qg (i, j) - lambdag = exp (0.25 * log (pi * rhog * n0g / qcg (i, j))) - reg (i, j) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 - reg (i, j) = max (regmin, min (regmax, reg (i, j))) + if (qms (i, k) .gt. qmin) then + qcs (i, k) = dpg * qms (i, k) * 1.0e3 + lambdas = exp (0.25 * log (pi * rhos * n0s / qms (i, k) / den (i, k))) + res (i, k) = 0.5 * exp (log (gammas / 6) / alphas) / lambdas * 1.0e6 + res (i, k) = max (resmin, min (resmax, res (i, k))) + else + qcs (i, k) = 0.0 + res (i, k) = resmin + endif + + ! ----------------------------------------------------------------------- + ! graupel (Lin et al., 1983) + ! ----------------------------------------------------------------------- + + if (qmg (i, k) .gt. qmin) then + qcg (i, k) = dpg * qmg (i, k) * 1.0e3 + lambdag = exp (0.25 * log (pi * rhog * n0g / qmg (i, k) / den (i, k))) + reg (i, k) = 0.5 * exp (log (gammag / 6) / alphag) / lambdag * 1.0e6 + reg (i, k) = max (regmin, min (regmax, reg (i, k))) else - qcg (i, j) = 0.0 - reg (i, j) = regmin + qcg (i, k) = 0.0 + reg (i, k) = regmin endif enddo diff --git a/physics/module_nst_water_prop.f90 b/physics/module_nst_water_prop.f90 index 20c4dff88..3f3916396 100644 --- a/physics/module_nst_water_prop.f90 +++ b/physics/module_nst_water_prop.f90 @@ -657,7 +657,8 @@ subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) end subroutine get_dtzm_point !>\ingroup waterprop - subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) + subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) +!subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) ! ===================================================================== ! ! ! ! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! @@ -695,7 +696,8 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) integer, intent(in) :: nx,ny real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc - logical, dimension(nx,ny), intent(in) :: wet,icy + logical, dimension(nx,ny), intent(in) :: wet +! logical, dimension(nx,ny), intent(in) :: wet,icy real (kind=kind_phys), intent(in) :: z1,z2 real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm ! Local variables @@ -712,7 +714,8 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) ! dtw(i,j) = 0.0 dtc(i,j) = 0.0 - if ( wet(i,j) .and. .not.icy(i,j) ) then +! if ( wet(i,j) .and. .not.icy(i,j) ) then + if ( wet(i,j) ) then ! ! get the mean warming in the range of z=z1 to z=z2 ! @@ -746,16 +749,18 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) endif endif endif - endif ! if wet(i,j) .and. .not.icy(i,j) + endif ! if ( wet(i,j) .and. .not.icy(i,j) ) then enddo enddo ! ! get the mean T departure from Tf in the range of z=z1 to z=z2 +! DH* NEED NTHREADS HERE! TODO !$omp parallel do private(j,i) do j = 1, ny do i= 1, nx - if ( wet(i,j) .and. .not.icy(i,j)) then +! if ( wet(i,j) .and. .not.icy(i,j)) then + if ( wet(i,j) ) then dtm(i,j) = dtw(i,j) - dtc(i,j) endif enddo diff --git a/physics/set_soilveg.f b/physics/set_soilveg.f index 60a6395b8..efef0f24b 100644 --- a/physics/set_soilveg.f +++ b/physics/set_soilveg.f @@ -136,8 +136,9 @@ subroutine set_soilveg(me,isot,ivet,nlunit) ! ---------------------------------------------------------------------- defined_veg=20 - NROOT_DATA =(/4,4,4,4,4,3,3,3,3,3,3,3,1,3,2, - & 3,0,3,3,2,0,0,0,0,0,0,0,0,0,0/) + NROOT_DATA =(/4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 1, 3, 2, + & 3, 1, 3, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/) +! & 3, 0, 3, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/) ! Moorthi ! ---------------------------------------------------------------------- ! VEGETATION CLASS-RELATED ARRAYS ! ---------------------------------------------------------------------- diff --git a/physics/sfc_cice.f b/physics/sfc_cice.f index 562d00bee..0a1a49c77 100644 --- a/physics/sfc_cice.f +++ b/physics/sfc_cice.f @@ -35,15 +35,18 @@ end subroutine sfc_cice_finalize !! @{ -!! use physcons, only : hvap => con_hvap, cp => con_cp, & +!! use physcons, only : hvap => con_hvap, cp => con_cp, & !! & rvrdm1 => con_fvirt, rd => con_rd ! !----------------------------------- subroutine sfc_cice_run & - & ( im, cplflx, cplchm, hvap, cp, rvrdm1, rd, & ! --- inputs: - & u1, v1, t1, q1, cm, ch, prsl1, prslki, & - & flag_cice, ddvel, flag_iter, dqsfc, dtsfc, & - & qsurf, cmm, chh, evap, hflx, & ! --- outputs: +! --- inputs: + & ( im, cplflx, cplchm, hvap, cp, rvrdm1, rd, & + & t1, q1, cm, ch, prsl1, & + & wind, flag_cice, flag_iter, dqsfc, dtsfc, & + & dusfc, dvsfc, & +! --- outputs: + & qsurf, cmm, chh, evap, hflx, stress, & & errmsg, errflg & ) @@ -55,40 +58,42 @@ subroutine sfc_cice_run & ! ! ! call sfc_cice ! ! inputs: ! -! ( im, u1, v1, t1, q1, cm, ch, prsl1, prslki, ! -! islimsk, ddvel, flag_iter, dqsfc, dtsfc, ! +! ( im, cplflx, cplchm, hvap, cp, rvrdm1, rd, ! +! t1, q1, cm, ch, prsl1, ! +! wind, flag_cice, flag_iter, dqsfc, dtsfc, ! +! dusfc, dvsfc, ! ! outputs: ! -! qsurf, cmm, chh, evap, hflx) ! +! qsurf, cmm, chh, evap, hflx, stress) ! ! ! ! ==================== defination of variables ==================== ! ! ! ! inputs: ! im, - integer, horiz dimension -! u1, v1 - real, u/v component of surface layer wind +!! u1, v1 - real, u/v component of surface layer wind ! t1 - real, surface layer mean temperature ( k ) ! q1 - real, surface layer mean specific humidity ! cm - real, surface exchange coeff for momentum (m/s) ! ch - real, surface exchange coeff heat & moisture(m/s) ! prsl1 - real, surface layer mean pressure -! prslki - real, ? -! islimsk - integer, sea/land/ice mask -! ddvel - real, ? +! wind - real, wind speed (m/s) ! flag_iter- logical ! dqsfc - real, latent heat flux ! dtsfc - real, sensible heat flux +! dusfc - real, zonal momentum stress +! dvsfc - real, meridional momentum stress ! outputs: ! qsurf - real, specific humidity at sfc ! cmm - real, ? ! chh - real, ? ! evap - real, evaperation from latent heat ! hflx - real, sensible heat +! stress - real, surface stress ! ==================== end of description ===================== ! ! ! use machine , only : kind_phys implicit none - real (kind=kind_phys), intent(in) :: hvap, cp, rvrdm1, rd ! --- inputs: @@ -96,24 +101,22 @@ subroutine sfc_cice_run & logical, intent(in) :: cplflx logical, intent(in) :: cplchm - real (kind=kind_phys), dimension(im), intent(in) :: u1, v1, & - & t1, q1, cm, ch, prsl1, prslki, ddvel, dqsfc, dtsfc +! real (kind=kind_phys), dimension(im), intent(in) :: u1, v1, & + real (kind=kind_phys), dimension(im), intent(in) :: & + & t1, q1, cm, ch, prsl1, wind, dqsfc, dtsfc, dusfc, dvsfc - logical, dimension(im), intent(in) :: flag_cice - - logical, intent(in) :: flag_iter(im) + logical, intent(in) :: flag_cice(im), flag_iter(im) ! --- outputs: real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & - & cmm, chh, evap, hflx + & cmm, chh, evap, hflx, stress ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! --- locals: - real (kind=kind_phys), dimension(im) :: q0, rch, rho, tv1, wind - real (kind=kind_phys) :: tem + real (kind=kind_phys) :: rho, tem real(kind=kind_phys) :: cpinv, hvapi, elocp @@ -134,22 +137,17 @@ subroutine sfc_cice_run & do i = 1, im if (flag_cice(i) .and. flag_iter(i)) then - wind(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - & + max(0.0, min(ddvel(i), 30.0)) - wind(i) = max(wind(i), 1.0) - - q0(i) = max(q1(i), 1.0e-8) - tv1(i) = t1(i) * (1.0 + rvrdm1*q0(i)) - rho(i) = prsl1(i) / (rd*tv1(i)) + rho = prsl1(i) & + & / (rd * t1(i) * (1.0 + rvrdm1*max(q1(i), 1.0e-8))) - cmm(i) = cm(i) * wind(i) - chh(i) = rho(i) * ch(i) * wind(i) - rch(i) = chh(i) * cp + cmm(i) = wind(i) * cm(i) + chh(i) = wind(i) * ch(i) * rho - qsurf(i) = q1(i) + dqsfc(i) / (elocp*rch(i)) - tem = 1.0 / rho(i) - hflx(i) = dtsfc(i) * tem * cpinv - evap(i) = dqsfc(i) * tem * hvapi + qsurf(i) = q1(i) + dqsfc(i) / (hvap*chh(i)) + tem = 1.0 / rho + hflx(i) = dtsfc(i) * tem * cpinv + evap(i) = dqsfc(i) * tem * hvapi + stress(i) = sqrt(dusfc(i)*dusfc(i) + dvsfc(i)*dvsfc(i)) * tem endif enddo diff --git a/physics/sfc_cice.meta b/physics/sfc_cice.meta index 756c760a4..48aa1f4c8 100644 --- a/physics/sfc_cice.meta +++ b/physics/sfc_cice.meta @@ -61,24 +61,6 @@ kind = kind_phys intent = in optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer - long_name = u component of surface layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer - long_name = v component of surface layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [t1] standard_name = air_temperature_at_lowest_model_layer long_name = surface layer mean temperature @@ -124,10 +106,10 @@ kind = kind_phys intent = in optional = F -[prslki] - standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer - long_name = Exner function ratio bt midlayer and interface at 1st layer - units = ratio +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -141,15 +123,6 @@ type = logical intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = wind enhancement due to convection - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [flag_iter] standard_name = flag_for_iteration long_name = flag for iteration @@ -176,6 +149,24 @@ kind = kind_phys intent = in optional = F +[dusfc] + standard_name = surface_x_momentum_flux_for_coupling_interstitial + long_name = sfc x momentum flux for coupling interstitial + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvsfc] + standard_name = surface_y_momentum_flux_for_coupling_interstitial + long_name = sfc y momentum flux for coupling interstitial + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [qsurf] standard_name = surface_specific_humidity_over_ice long_name = surface air saturation specific humidity over ice @@ -221,6 +212,15 @@ kind = kind_phys intent = inout optional = F +[stress] + standard_name = surface_wind_stress_over_ice + long_name = surface wind stress over ice + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 5ada7288c..4cbf94245 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -61,8 +61,8 @@ end subroutine sfc_diff_finalize !! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and \f$stress\f$ as inputs of other \a sfc schemes. !! subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) - & ps,u1,v1,t1,q1,z1, & !intent(in) - & prsl1,prslki,prsik1,prslk1,ddvel, & !intent(in) + & ps,t1,q1,z1,wind, & !intent(in) + & prsl1,prslki,prsik1,prslk1, & !intent(in) & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) @@ -81,27 +81,23 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fh_ocn, fh_lnd, fh_ice, & !intent(inout) & fm10_ocn, fm10_lnd, fm10_ice, & !intent(inout) & fh2_ocn, fh2_lnd, fh2_ice, & !intent(inout) - & wind , & !intent(inout) & errmsg, errflg) !intent(out) ! -! DH* 20190718: prslki can be removed if GSD_SURFACE_FLUXES_BUGFIX is adopted - use funcphys, only : fpvs - implicit none ! integer, intent(in) :: im, ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean - integer, dimension(im), intent(in) :: vegtype + integer, dimension(im), intent(in) :: vegtype logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) - logical, dimension(im), intent(in) :: flag_iter, wet, dry, icy ! added by s.lu + logical, dimension(im), intent(in) :: flag_iter, wet, dry, icy real(kind=kind_phys), dimension(im), intent(in) :: u10m,v10m real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav real(kind=kind_phys), dimension(im), intent(in) :: & - & ps,u1,v1,t1,q1,z1,prsl1,prslki,prsik1,prslk1, & - & ddvel, sigmaf,shdmax, & + & ps,t1,q1,z1,prsl1,prslki,prsik1,prslk1, & + & wind,sigmaf,shdmax, & & z0pert,ztpert ! mg, sfc-perts real(kind=kind_phys), dimension(im), intent(in) :: & & tskin_ocn, tskin_lnd, tskin_ice, & @@ -118,24 +114,18 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fm_ocn, fm_lnd, fm_ice, & & fh_ocn, fh_lnd, fh_ice, & & fm10_ocn, fm10_lnd, fm10_ice, & - & fh2_ocn, fh2_lnd, fh2_ice, & - & wind + & fh2_ocn, fh2_lnd, fh2_ice character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! ! locals ! - real(kind=kind_phys), dimension(im) :: wind10m - integer i ! - real(kind=kind_phys) :: qs1, rat, thv1, restar, - & czilc, tem1, tem2 + real(kind=kind_phys) :: rat, thv1, restar, wind10m, + & czilc, tem1, tem2, virtfac - real(kind=kind_phys) :: tvs_ocn, tvs_lnd, tvs_ice, & - & z0_ocn, z0_lnd, z0_ice, & - & z0max_ocn,z0max_lnd,z0max_ice, & - & ztmax_ocn,ztmax_lnd,ztmax_ice + real(kind=kind_phys) :: tvs, z0, z0max, ztmax ! real(kind=kind_phys), parameter :: & charnock=.014, z0s_max=.317e-2 &! a limiting value at high winds over sea @@ -170,73 +160,21 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type do i=1,im - - ztmax_ocn = 0.0 ; ztmax_lnd = 0.0 ; ztmax_ice = 0.0 - - wind10m(i) = max(sqrt( u10m(i)*u10m(i) + v10m(i)*v10m(i)), - & 1.0) - if(flag_iter(i)) then - wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) - & + max(0.0, min(ddvel(i), 30.0)), 1.0) - tem1 = 1.0 + rvrdm1 * max(q1(i),1.e-8) -#ifdef GSD_SURFACE_FLUXES_BUGFIX - thv1 = t1(i) / prslk1(i) * tem1 - tvs_lnd = 0.5 * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) * tem1 - tvs_ice = 0.5 * (tsurf_ice(i)+tskin_ice(i))/prsik1(i) * tem1 - tvs_ocn = 0.5 * (tsurf_ocn(i)+tskin_ocn(i))/prsik1(i) * tem1 -#else - thv1 = t1(i) * prslki(i) * tem1 - tvs_lnd = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) * tem1 - tvs_ice = 0.5 * (tsurf_ice(i)+tskin_ice(i)) * tem1 - tvs_ocn = 0.5 * (tsurf_ocn(i)+tskin_ocn(i)) * tem1 -#endif - qs1 = fpvs(t1(i)) - qs1 = max(1.0e-8, eps * qs1 / (prsl1(i) + epsm1 * qs1)) - - z0_lnd = 0.01 * z0rl_lnd(i) - z0max_lnd = max(1.0e-6, min(z0_lnd,z1(i))) - z0_ice = 0.01 * z0rl_ice(i) - z0max_ice = max(1.0e-6, min(z0_ice,z1(i))) - z0_ocn = 0.01 * z0rl_ocn(i) - z0max_ocn = max(1.0e-6, min(z0_ocn,z1(i))) + virtfac = 1.0 + rvrdm1 * max(q1(i),1.e-8) + thv1 = t1(i) * prslki(i) * virtfac ! compute stability dependent exchange coefficients ! this portion of the code is presently suppressed ! - - if (wet(i)) then ! some open ocean - ustar_ocn(i) = sqrt(grav * z0_ocn / charnock) - -!** test xubin's new z0 - -! ztmax = z0max - - restar = max(ustar_ocn(i)*z0max_ocn*visi, 0.000001) - -! restar = log(restar) -! restar = min(restar,5.) -! restar = max(restar,-5.) -! rat = aa1 + (bb1 + cc1*restar) * restar -! rat = rat / (1. + (bb2 + cc2*restar) * restar)) -! rat taken from zeng, zhao and dickinson 1997 - - rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) - ztmax_ocn = z0max_ocn * exp(-rat) - - if (sfc_z0_type == 6) then - call znot_t_v6(wind10m(i),ztmax_ocn) ! 10-m wind,m/s, ztmax(m) - else if (sfc_z0_type == 7) then - call znot_t_v7(wind10m(i),ztmax_ocn) ! 10-m wind,m/s, ztmax(m) - else if (sfc_z0_type .ne. 0) then - write(0,*)'no option for sfc_z0_type=',sfc_z0_type - stop - endif - - endif ! Open ocean - - if (dry(i) .or. icy(i)) then ! over land or sea ice -!** xubin's new z0 over land and sea ice + if (dry(i)) then ! Some land +#ifdef GSD_SURFACE_FLUXES_BUGFIX + tvs = 0.5 * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) * virtfac +#else + tvs = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac +#endif + z0max = max(1.0e-6, min(0.01 * z0rl_lnd(i), z1(i))) +!** xubin's new z0 over land tem1 = 1.0 - shdmax(i) tem2 = tem1 * tem1 tem1 = 1.0 - tem2 @@ -244,134 +182,175 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) if( ivegsrc == 1 ) then if (vegtype(i) == 10) then - z0max_lnd = exp( tem2*log01 + tem1*log07 ) + z0max = exp( tem2*log01 + tem1*log07 ) elseif (vegtype(i) == 6) then - z0max_lnd = exp( tem2*log01 + tem1*log05 ) + z0max = exp( tem2*log01 + tem1*log05 ) elseif (vegtype(i) == 7) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max_lnd = 0.01 + z0max = 0.01 elseif (vegtype(i) == 16) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max_lnd = 0.01 + z0max = 0.01 else - z0max_lnd = exp( tem2*log01 + tem1*log(z0max_lnd) ) + z0max = exp( tem2*log01 + tem1*log(z0max) ) endif elseif (ivegsrc == 2 ) then - if (vegtype(i) == 7) then - z0max_lnd = exp( tem2*log01 + tem1*log07 ) - elseif (vegtype(i) == 8) then - z0max_lnd = exp( tem2*log01 + tem1*log05 ) - elseif (vegtype(i) == 9) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max_lnd = 0.01 - elseif (vegtype(i) == 11) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max_lnd = 0.01 - else - z0max_lnd = exp( tem2*log01 + tem1*log(z0max_lnd) ) - endif - - endif ! over land or sea ice - - z0max_ice = z0max_lnd + if (vegtype(i) == 7) then + z0max = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 8) then + z0max = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 9) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + elseif (vegtype(i) == 11) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + else + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + endif ! mg, sfc-perts: add surface perturbations to z0max over land - if (dry(i) .and. z0pert(i) /= 0.0 ) then - z0max_lnd = z0max_lnd * (10.**z0pert(i)) + if (z0pert(i) /= 0.0 ) then + z0max = z0max * (10.**z0pert(i)) endif - z0max_lnd = max(z0max_lnd,1.0e-6) - z0max_ice = max(z0max_ice,1.0e-6) + z0max = max(z0max, 1.0e-6) ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil czilc = 0.8 - tem1 = 1.0 - sigmaf(i) - ztmax_lnd = z0max_lnd*exp( - tem1*tem1 + tem1 = 1.0 - sigmaf(i) + ztmax = z0max*exp( - tem1*tem1 & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) - ztmax_ice = z0max_ice*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) ! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land - if (dry(i) .and. ztpert(i) /= 0.0) then - ztmax_lnd = ztmax_lnd * (10.**ztpert(i)) + if (ztpert(i) /= 0.0) then + ztmax = ztmax * (10.**ztpert(i)) endif + ztmax = max(ztmax, 1.0e-6) +! + call stability +! --- inputs: + & (z1(i), snwdph_lnd(i), thv1, wind(i), + & z0max, ztmax, tvs, grav, +! --- outputs: + & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), + & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) + endif ! Dry points + if (icy(i)) then ! Some ice + tvs = 0.5 * (tsurf_ice(i)+tskin_ice(i)) * virtfac + z0max = max(1.0e-6, min(0.01 * z0rl_ice(i), z1(i))) +!** xubin's new z0 over land and sea ice + tem1 = 1.0 - shdmax(i) + tem2 = tem1 * tem1 + tem1 = 1.0 - tem2 - endif ! end of if(sfctype flags) then + if( ivegsrc == 1 ) then - ztmax_ocn = max(ztmax_ocn,1.0e-6) - ztmax_lnd = max(ztmax_lnd,1.0e-6) - ztmax_ice = max(ztmax_ice,1.0e-6) + z0max = exp( tem2*log01 + tem1*log(z0max) ) + elseif (ivegsrc == 2 ) then + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif -! BWG begin "stability" block, 2019-03-23 - if (wet(i)) then ! Some open ocean - call stability -! --- inputs: - & (z1(i),snwdph_ocn(i),thv1,wind(i), - & z0max_ocn,ztmax_ocn,tvs_ocn,grav, -! --- outputs: - & rb_ocn(i),fm_ocn(i),fh_ocn(i),fm10_ocn(i),fh2_ocn(i), - & cm_ocn(i),ch_ocn(i),stress_ocn(i),ustar_ocn(i)) - endif ! Open ocean points + z0max = max(z0max, 1.0e-6) - if (dry(i)) then ! Some land - call stability -! --- inputs: - & (z1(i),snwdph_lnd(i),thv1,wind(i), - & z0max_lnd,ztmax_lnd,tvs_lnd,grav, -! --- outputs: - & rb_lnd(i),fm_lnd(i),fh_lnd(i),fm10_lnd(i),fh2_lnd(i), - & cm_lnd(i),ch_lnd(i),stress_lnd(i),ustar_lnd(i)) - endif ! Dry points +! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height +! dependance of czil + czilc = 0.8 - if (icy(i)) then ! Some ice - call stability + tem1 = 1.0 - sigmaf(i) + ztmax = z0max*exp( - tem1*tem1 + & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) + ztmax = max(ztmax, 1.0e-6) +! + call stability ! --- inputs: - & (z1(i),snwdph_ice(i),thv1,wind(i), - & z0max_ice,ztmax_ice,tvs_ice,grav, + & (z1(i), snwdph_ice(i), thv1, wind(i), + & z0max, ztmax, tvs, grav, ! --- outputs: - & rb_ice(i),fm_ice(i),fh_ice(i),fm10_ice(i),fh2_ice(i), - & cm_ice(i),ch_ice(i),stress_ice(i),ustar_ice(i)) + & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), + & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) endif ! Icy points ! BWG: Everything from here to end of subroutine was after ! the stuff now put into "stability" + if (wet(i)) then ! Some open ocean + tvs = 0.5 * (tsurf_ocn(i)+tskin_ocn(i)) * virtfac + z0 = 0.01 * z0rl_ocn(i) + z0max = max(1.0e-6, min(z0,z1(i))) + ustar_ocn(i) = sqrt(grav * z0 / charnock) + wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) + +!** test xubin's new z0 + +! ztmax = z0max + + restar = max(ustar_ocn(i)*z0max*visi, 0.000001) + +! restar = log(restar) +! restar = min(restar,5.) +! restar = max(restar,-5.) +! rat = aa1 + (bb1 + cc1*restar) * restar +! rat = rat / (1. + (bb2 + cc2*restar) * restar)) +! rat taken from zeng, zhao and dickinson 1997 + + rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) + ztmax = max(z0max * exp(-rat), 1.0e-6) +! + if (sfc_z0_type == 6) then + call znot_t_v6(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) + else if (sfc_z0_type == 7) then + call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) + else if (sfc_z0_type /= 0) then + write(0,*)'no option for sfc_z0_type=',sfc_z0_type + stop + endif +! + call stability +! --- inputs: + & (z1(i), snwdph_ocn(i), thv1, wind(i), + & z0max, ztmax, tvs, grav, +! --- outputs: + & rb_ocn(i), fm_ocn(i), fh_ocn(i), fm10_ocn(i), fh2_ocn(i), + & cm_ocn(i), ch_ocn(i), stress_ocn(i), ustar_ocn(i)) ! ! update z0 over ocean ! - if (wet(i)) then - z0_ocn = (charnock / grav) * ustar_ocn(i) * ustar_ocn(i) + if (sfc_z0_type == 0) then + z0 = (charnock / grav) * ustar_ocn(i) * ustar_ocn(i) ! mbek -- toga-coare flux algorithm -! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) +! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) ! new implementation of z0 -! cc = ustar(i) * z0 / rnu -! pp = cc / (1. + cc) -! ff = grav * arnu / (charnock * ustar(i) ** 3) -! z0 = arnu / (ustar(i) * ff ** pp) +! cc = ustar(i) * z0 / rnu +! pp = cc / (1. + cc) +! ff = grav * arnu / (charnock * ustar(i) ** 3) +! z0 = arnu / (ustar(i) * ff ** pp) + + if (redrag) then + z0rl_ocn(i) = 100.0 * max(min(z0, z0s_max), 1.e-7) + else + z0rl_ocn(i) = 100.0 * max(min(z0,.1), 1.e-7) + endif - if (redrag) then - z0rl_ocn(i) = 100.0 * max(min(z0_ocn, z0s_max), 1.e-7) + elseif (sfc_z0_type == 6) then ! wang + call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m + z0rl_ocn(i) = 100.0 * z0 ! cm + elseif (sfc_z0_type == 7) then ! wang + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + z0rl_ocn(i) = 100.0 * z0 ! cm else - z0rl_ocn(i) = 100.0 * max(min(z0_ocn,.1), 1.e-7) + z0rl_ocn(i) = 1.0e-4 endif - if (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m(i),z0_ocn) ! wind, m/s, z0, m - z0rl_ocn(i) = 100.0 * z0_ocn ! cm - endif !wang - if (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m(i),z0_ocn) ! wind, m/s, z0, m - z0rl_ocn(i) = 100.0 * z0_ocn ! cm - endif !wang - - endif ! end of if(open ocean) +! endif ! end of if(flagiter) loop enddo @@ -382,8 +361,11 @@ end subroutine sfc_diff_run !---------------------------------------- !>\ingroup GFS_diff_main subroutine stability & - & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav, & ! --- inputs: - & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) ! --- outputs: +! --- inputs: + & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav, & +! --- outputs: + & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) +!----- ! --- inputs: real(kind=kind_phys), intent(in) :: & @@ -431,10 +413,10 @@ subroutine stability & #endif tem1 = 1.0 / z0max tem2 = 1.0 / ztmax - fm = log((z0max+z1) * tem1) - fh = log((ztmax+z1) * tem2) - fm10 = log((z0max+10.) * tem1) - fh2 = log((ztmax+2.) * tem2) + fm = log((z0max+z1) * tem1) + fh = log((ztmax+z1) * tem2) + fm10 = log((z0max+10.) * tem1) + fh2 = log((ztmax+2.) * tem2) hlinf = rb * fm * fm / fh hlinf = min(max(hlinf,ztmin1),ztmax1) ! @@ -543,8 +525,9 @@ end subroutine stability !! add fitted z0,zt curves for hurricane application (used in HWRF/HMON) !! Weiguo Wang, 2019-0425 - SUBROUTINE znot_m_v6(uref,znotm) - IMPLICIT NONE + SUBROUTINE znot_m_v6(uref, znotm) + use machine , only : kind_phys + IMPLICIT NONE ! Calculate areodynamical roughness over water with input 10-m wind ! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) ! For high winds, try to fit available observational data @@ -555,53 +538,42 @@ SUBROUTINE znot_m_v6(uref,znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znotm - REAL :: p13, p12, p11, p10 - REAL :: p25, p24, p23, p22, p21, p20 - REAL :: p35, p34, p33, p32, p31, p30 - REAL :: p40 - - p13 = -1.296521881682694e-02 - p12 = 2.855780863283819e-01 - p11 = -1.597898515251717e+00 - p10 = -8.396975715683501e+00 + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znotm + real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, + & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00, + & p10 = -8.396975715683501e+00, - p25 = 3.790846746036765e-10 - p24 = 3.281964357650687e-09 - p23 = 1.962282433562894e-07 - p22 = -1.240239171056262e-06 - p21 = 1.739759082358234e-07 - p20 = 2.147264020369413e-05 + & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, + & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, + & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, - p35 = 1.840430200185075e-07 - p34 = -2.793849676757154e-05 - p33 = 1.735308193700643e-03 - p32 = -6.139315534216305e-02 - p31 = 1.255457892775006e+00 - p30 = -1.663993561652530e+01 + & p35 = 1.840430200185075e-07, p34 = -2.793849676757154e-05, + & p33 = 1.735308193700643e-03, p32 = -6.139315534216305e-02, + & p31 = 1.255457892775006e+00, p30 = -1.663993561652530e+01, - p40 = 4.579369142033410e-04 + & p40 = 4.579369142033410e-04 + if (uref >= 0.0 .and. uref <= 6.5 ) then - znotm = exp( p10 + p11*uref + p12*uref**2 + - & p13*uref**3) + znotm = exp(p10 + uref * (p11 + uref * (p12 + uref*p13))) elseif (uref > 6.5 .and. uref <= 15.7) then - znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + - & p22*uref**2 + p21*uref + p20 + znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) elseif (uref > 15.7 .and. uref <= 53.0) then - znotm = exp( p35*uref**5 + p34*uref**4 + - & p33*uref**3 + p32*uref**2 + p31*uref + p30 ) + znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35))))) elseif ( uref > 53.0) then znotm = p40 else print*, 'Wrong input uref value:',uref endif - END SUBROUTINE znot_m_v6 + END SUBROUTINE znot_m_v6 - SUBROUTINE znot_t_v6(uref,znott) - IMPLICIT NONE + SUBROUTINE znot_t_v6(uref, znott) + use machine , only : kind_phys + IMPLICIT NONE ! Calculate scalar roughness over water with input 10-m wind ! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm ! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF @@ -612,85 +584,61 @@ SUBROUTINE znot_t_v6(uref,znott) ! znott(meter): scalar roughness scale over water ! - REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znott - - REAL :: p00 - REAL :: p15, p14, p13, p12, p11, p10 - REAL :: p25, p24, p23, p22, p21, p20 - REAL :: p35, p34, p33, p32, p31, p30 - REAL :: p45, p44, p43, p42, p41, p40 - REAL :: p56, p55, p54, p53, p52, p51, p50 - REAL :: p60 - - p00 = 1.100000000000000e-04 - - p15 = -9.144581627678278e-10 - p14 = 7.020346616456421e-08 - p13 = -2.155602086883837e-06 - p12 = 3.333848806567684e-05 - p11 = -2.628501274963990e-04 - p10 = 8.634221567969181e-04 - - p25 = -8.654513012535990e-12 - p24 = 1.232380050058077e-09 - p23 = -6.837922749505057e-08 - p22 = 1.871407733439947e-06 - p21 = -2.552246987137160e-05 - p20 = 1.428968311457630e-04 - - p35 = 3.207515102100162e-12 - p34 = -2.945761895342535e-10 - p33 = 8.788972147364181e-09 - p32 = -3.814457439412957e-08 - p31 = -2.448983648874671e-06 - p30 = 3.436721779020359e-05 - - p45 = -3.530687797132211e-11 - p44 = 3.939867958963747e-09 - p43 = -1.227668406985956e-08 - p42 = -1.367469811838390e-05 - p41 = 5.988240863928883e-04 - p40 = -7.746288511324971e-03 - - p56 = -1.187982453329086e-13 - p55 = 4.801984186231693e-11 - p54 = -8.049200462388188e-09 - p53 = 7.169872601310186e-07 - p52 = -3.581694433758150e-05 - p51 = 9.503919224192534e-04 - p50 = -1.036679430885215e-02 - - p60 = 4.751256171799112e-05 - - if (uref >= 0.0 .and. uref < 5.9 ) then + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znott + real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, + & p15 = -9.144581627678278e-10, p14 = 7.020346616456421e-08, + & p13 = -2.155602086883837e-06, p12 = 3.333848806567684e-05, + & p11 = -2.628501274963990e-04, p10 = 8.634221567969181e-04, + + & p25 = -8.654513012535990e-12, p24 = 1.232380050058077e-09, + & p23 = -6.837922749505057e-08, p22 = 1.871407733439947e-06, + & p21 = -2.552246987137160e-05, p20 = 1.428968311457630e-04, + + & p35 = 3.207515102100162e-12, p34 = -2.945761895342535e-10, + & p33 = 8.788972147364181e-09, p32 = -3.814457439412957e-08, + & p31 = -2.448983648874671e-06, p30 = 3.436721779020359e-05, + + & p45 = -3.530687797132211e-11, p44 = 3.939867958963747e-09, + & p43 = -1.227668406985956e-08, p42 = -1.367469811838390e-05, + & p41 = 5.988240863928883e-04, p40 = -7.746288511324971e-03, + + & p56 = -1.187982453329086e-13, p55 = 4.801984186231693e-11, + & p54 = -8.049200462388188e-09, p53 = 7.169872601310186e-07, + & p52 = -3.581694433758150e-05, p51 = 9.503919224192534e-04, + & p50 = -1.036679430885215e-02, + + & p60 = 4.751256171799112e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then znott = p00 - elseif (uref >= 5.9 .and. uref <= 15.4) then - znott = p15*uref**5 + p14*uref**4 + p13*uref**3 - & + p12*uref**2 + p11*uref + p10 - elseif (uref > 15.4 .and. uref <= 21.6) then - znott = p25*uref**5 + p24*uref**4 + p23*uref**3 - & + p22*uref**2 + p21*uref + p20 - elseif (uref > 21.6 .and. uref <= 42.2) then - znott = p35*uref**5 + p34*uref**4 + p33*uref**3 - & + p32*uref**2 + p31*uref + p30 - elseif ( uref > 42.2 .and. uref <= 53.3) then - znott = p45*uref**5 + p44*uref**4 + p43*uref**3 - & + p42*uref**2 + p41*uref + p40 - elseif ( uref > 53.3 .and. uref <= 80.0) then - znott = p56*uref**6 + p55*uref**5 + p54*uref**4 - & + p53*uref**3 + p52*uref**2 + p51*uref + p50 - elseif ( uref > 80.0) then + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 + & + uref * (p14 + uref * p15)))) + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) + elseif (uref > 21.6 .and. uref <= 42.2) then + znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35)))) + elseif ( uref > 42.2 .and. uref <= 53.3) then + znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 + & + uref * (p44 + uref * p45)))) + elseif ( uref > 53.3 .and. uref <= 80.0) then + znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 + & + uref * (p54 + uref * (p55 + uref * p56))))) + elseif ( uref > 80.0) then znott = p60 - else + else print*, 'Wrong input uref value:',uref - endif + endif - END SUBROUTINE znot_t_v6 + END SUBROUTINE znot_t_v6 - SUBROUTINE znot_m_v7(uref,znotm) - IMPLICIT NONE + SUBROUTINE znot_m_v7(uref, znotm) + use machine , only : kind_phys + IMPLICIT NONE ! Calculate areodynamical roughness over water with input 10-m wind ! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) ! For high winds, try to fit available observational data @@ -702,52 +650,41 @@ SUBROUTINE znot_m_v7(uref,znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znotm - REAL :: p13, p12, p11, p10 - REAL :: p25, p24, p23, p22, p21, p20 - REAL :: p35, p34, p33, p32, p31, p30 - REAL :: p40 - - p13 = -1.296521881682694e-02 - p12 = 2.855780863283819e-01 - p11 = -1.597898515251717e+00 - p10 = -8.396975715683501e+00 + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znotm - p25 = 3.790846746036765e-10 - p24 = 3.281964357650687e-09 - p23 = 1.962282433562894e-07 - p22 = -1.240239171056262e-06 - p21 = 1.739759082358234e-07 - p20 = 2.147264020369413e-05 + real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, + & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00, + & p10 = -8.396975715683501e+00, + & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, + & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, + & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, - p35 = 1.897534489606422e-07 - p34 = -3.019495980684978e-05 - p33 = 1.931392924987349e-03 - p32 = -6.797293095862357e-02 - p31 = 1.346757797103756e+00 - p30 = -1.707846930193362e+01 + & p35 = 1.897534489606422e-07, p34 = -3.019495980684978e-05, + & p33 = 1.931392924987349e-03, p32 = -6.797293095862357e-02, + & p31 = 1.346757797103756e+00, p30 = -1.707846930193362e+01, - p40 = 3.371427455376717e-04 + & p40 = 3.371427455376717e-04 - if (uref >= 0.0 .and. uref <= 6.5 ) then - znotm = exp( p10 + p11*uref + p12*uref**2 + p13*uref**3) - elseif (uref > 6.5 .and. uref <= 15.7) then - znotm = p25*uref**5 + p24*uref**4 + p23*uref**3 + - & p22*uref**2 + p21*uref + p20 - elseif (uref > 15.7 .and. uref <= 53.0) then - znotm = exp( p35*uref**5 + p34*uref**4 + p33*uref**3 - & + p32*uref**2 + p31*uref + p30 ) - elseif ( uref > 53.0) then + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp( p10 + uref * (p11 + uref * (p12 + uref * p13))) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) + elseif (uref > 15.7 .and. uref <= 53.0) then + znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35))))) + elseif ( uref > 53.0) then znotm = p40 - else + else print*, 'Wrong input uref value:',uref - endif + endif END SUBROUTINE znot_m_v7 - SUBROUTINE znot_t_v7(uref,znott) - IMPLICIT NONE + SUBROUTINE znot_t_v7(uref, znott) + use machine , only : kind_phys + IMPLICIT NONE ! Calculate scalar roughness over water with input 10-m wind ! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm ! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF @@ -759,79 +696,54 @@ SUBROUTINE znot_t_v7(uref,znott) ! znott(meter): scalar roughness scale over water ! - REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znott - - REAL :: p00 - REAL :: p15, p14, p13, p12, p11, p10 - REAL :: p25, p24, p23, p22, p21, p20 - REAL :: p35, p34, p33, p32, p31, p30 - REAL :: p45, p44, p43, p42, p41, p40 - REAL :: p56, p55, p54, p53, p52, p51, p50 - REAL :: p60 - - p00 = 1.100000000000000e-04 - - p15 = -9.193764479895316e-10 - p14 = 7.052217518653943e-08 - p13 = -2.163419217747114e-06 - p12 = 3.342963077911962e-05 - p11 = -2.633566691328004e-04 - p10 = 8.644979973037803e-04 - - p25 = -9.402722450219142e-12 - p24 = 1.325396583616614e-09 - p23 = -7.299148051141852e-08 - p22 = 1.982901461144764e-06 - p21 = -2.680293455916390e-05 - p20 = 1.484341646128200e-04 - - p35 = 7.921446674311864e-12 - p34 = -1.019028029546602e-09 - p33 = 5.251986927351103e-08 - p32 = -1.337841892062716e-06 - p31 = 1.659454106237737e-05 - p30 = -7.558911792344770e-05 - - p45 = -2.694370426850801e-10 - p44 = 5.817362913967911e-08 - p43 = -5.000813324746342e-06 - p42 = 2.143803523428029e-04 - p41 = -4.588070983722060e-03 - p40 = 3.924356617245624e-02 - - p56 = -1.663918773476178e-13 - p55 = 6.724854483077447e-11 - p54 = -1.127030176632823e-08 - p53 = 1.003683177025925e-06 - p52 = -5.012618091180904e-05 - p51 = 1.329762020689302e-03 - p50 = -1.450062148367566e-02 - - p60 = 6.840803042788488e-05 + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znott + + real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, + + & p15 = -9.193764479895316e-10, p14 = 7.052217518653943e-08, + & p13 = -2.163419217747114e-06, p12 = 3.342963077911962e-05, + & p11 = -2.633566691328004e-04, p10 = 8.644979973037803e-04, + + & p25 = -9.402722450219142e-12, p24 = 1.325396583616614e-09, + & p23 = -7.299148051141852e-08, p22 = 1.982901461144764e-06, + & p21 = -2.680293455916390e-05, p20 = 1.484341646128200e-04, + + & p35 = 7.921446674311864e-12, p34 = -1.019028029546602e-09, + & p33 = 5.251986927351103e-08, p32 = -1.337841892062716e-06, + & p31 = 1.659454106237737e-05, p30 = -7.558911792344770e-05, + + & p45 = -2.694370426850801e-10, p44 = 5.817362913967911e-08, + & p43 = -5.000813324746342e-06, p42 = 2.143803523428029e-04, + & p41 = -4.588070983722060e-03, p40 = 3.924356617245624e-02, + + & p56 = -1.663918773476178e-13, p55 = 6.724854483077447e-11, + & p54 = -1.127030176632823e-08, p53 = 1.003683177025925e-06, + & p52 = -5.012618091180904e-05, p51 = 1.329762020689302e-03, + & p50 = -1.450062148367566e-02, p60 = 6.840803042788488e-05 if (uref >= 0.0 .and. uref < 5.9 ) then - znott = p00 - elseif (uref >= 5.9 .and. uref <= 15.4) then - znott = p15*uref**5 + p14*uref**4 + p13*uref**3 + - & p12*uref**2 + p11*uref + p10 - elseif (uref > 15.4 .and. uref <= 21.6) then - znott = p25*uref**5 + p24*uref**4 + p23*uref**3 + - & p22*uref**2 + p21*uref + p20 - elseif (uref > 21.6 .and. uref <= 42.6) then - znott = p35*uref**5 + p34*uref**4 + p33*uref**3 + - & p32*uref**2 + p31*uref + p30 - elseif ( uref > 42.6 .and. uref <= 53.0) then - znott = p45*uref**5 + p44*uref**4 + p43*uref**3 + - & p42*uref**2 + p41*uref + p40 - elseif ( uref > 53.0 .and. uref <= 80.0) then - znott = p56*uref**6 + p55*uref**5 + p54*uref**4 + - & p53*uref**3 + p52*uref**2 + p51*uref + p50 - elseif ( uref > 80.0) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 + & + uref * (p14 + uref * p15)))) + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) + elseif (uref > 21.6 .and. uref <= 42.6) then + znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35)))) + elseif ( uref > 42.6 .and. uref <= 53.0) then + znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 + & + uref * (p44 + uref * p45)))) + elseif ( uref > 53.0 .and. uref <= 80.0) then + znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 + & + uref * (p54 + uref * (p55 + uref * p56))))) + elseif ( uref > 80.0) then znott = p60 else print*, 'Wrong input uref value:',uref - endif + endif END SUBROUTINE znot_t_v7 diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index de8acc72a..232b0050f 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -54,24 +54,6 @@ kind = kind_phys intent = in optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer - long_name = x component of 1st model layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer - long_name = y component of 1st model layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [t1] standard_name = air_temperature_at_lowest_model_layer long_name = 1st model layer air temperature @@ -99,6 +81,15 @@ kind = kind_phys intent = in optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [prsl1] standard_name = air_pressure_at_lowest_model_layer long_name = Model layer 1 mean pressure @@ -135,15 +126,6 @@ kind = kind_phys intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = surface wind enhancement due to convection - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [sigmaf] standard_name = bounded_vegetation_area_fraction long_name = areal fractional cover of green vegetation bounded on the bottom @@ -613,15 +595,6 @@ kind = kind_phys intent = inout optional = F -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index 4e27c07f1..75afaa6ff 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -62,9 +62,9 @@ end subroutine lsm_noah_finalize ! ! ! call sfc_drv ! ! --- inputs: ! -! ( im, km, ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, ! +! ( im, km, ps, t1, q1, soiltyp, vegtype, sigmaf, ! ! sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, ! -! prsl1, prslki, zf, land, ddvel, slopetyp, ! +! prsl1, prslki, zf, land, wind, slopetyp, ! ! shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, ! ! lheatstrg, isot, ivegsrc, ! ! --- in/outs: ! @@ -94,7 +94,6 @@ end subroutine lsm_noah_finalize ! im - integer, horiz dimention and num of used pts 1 ! ! km - integer, vertical soil layer dimension 1 ! ! ps - real, surface pressure (pa) im ! -! u1, v1 - real, u/v component of surface layer wind im ! ! t1 - real, surface layer mean temperature (k) im ! ! q1 - real, surface layer mean specific humidity im ! ! soiltyp - integer, soil type (integer index) im ! @@ -112,7 +111,7 @@ end subroutine lsm_noah_finalize ! prslki - real, dimensionless exner function at layer 1 im ! ! zf - real, height of bottom layer (m) im ! ! land - logical, = T if a point with any land im ! -! ddvel - real, im ! +! wind - real, wind speed (m/s) im ! ! slopetyp - integer, class of sfc slope (integer index) im ! ! shdmin - real, min fractional coverage of green veg im ! ! shdmax - real, max fractnl cover of green veg (not used) im ! @@ -171,10 +170,10 @@ end subroutine lsm_noah_finalize !> \section general_noah_drv GFS sfc_drv General Algorithm !> @{ subroutine lsm_noah_run & - & ( im, km, grav, cp, hvap, rd, eps, epsm1, rvrdm1, ps, u1, & ! --- inputs: - & v1, t1, q1, soiltyp, vegtype, sigmaf, & + & ( im, km, grav, cp, hvap, rd, eps, epsm1, rvrdm1, ps, & ! --- inputs: + & t1, q1, soiltyp, vegtype, sigmaf, & & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - & prsl1, prslki, zf, land, ddvel, slopetyp, & + & prsl1, prslki, zf, land, wind, slopetyp, & & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & & lheatstrg, isot, ivegsrc, & & bexppert, xlaipert, vegfpert,pertvegf, & ! sfc perts, mgehne @@ -212,9 +211,9 @@ subroutine lsm_noah_run & integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp - real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + real (kind=kind_phys), dimension(im), intent(in) :: ps, & & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & - & ch, prsl1, prslki, ddvel, shdmin, shdmax, & + & ch, prsl1, prslki, wind, shdmin, shdmax, & & snoalb, sfalb, zf, & & bexppert, xlaipert, vegfpert @@ -242,7 +241,7 @@ subroutine lsm_noah_run & ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & - & q0, qs1, theta1, wind, weasd_old, snwdph_old, & + & q0, qs1, theta1, weasd_old, snwdph_old, & & tprcp_old, srflag_old, tskin_old, canopy_old real (kind=kind_phys), dimension(km) :: et, sldpth, stsoil, & @@ -319,9 +318,6 @@ subroutine lsm_noah_run & do i = 1, im if (flag_iter(i) .and. land(i)) then - wind(i) = max(sqrt( u1(i)*u1(i) + v1(i)*v1(i) ) & - & + max(0.0, min(ddvel(i), 30.0)), 1.0) - q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) diff --git a/physics/sfc_drv.meta b/physics/sfc_drv.meta index f628c6c27..7728ee375 100644 --- a/physics/sfc_drv.meta +++ b/physics/sfc_drv.meta @@ -165,24 +165,6 @@ kind = kind_phys intent = in optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer - long_name = x component of 1st model layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer - long_name = y component of 1st model layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [t1] standard_name = air_temperature_at_lowest_model_layer long_name = 1st model layer air temperature @@ -227,8 +209,8 @@ intent = in optional = F [sfcemis] - standard_name = surface_longwave_emissivity - long_name = surface longwave emissivity + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) units = frac dimensions = (horizontal_dimension) type = real @@ -236,8 +218,8 @@ intent = in optional = F [dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground - long_name = total sky surface downward longwave flux absorbed by the ground + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land units = W m-2 dimensions = (horizontal_dimension) type = real @@ -333,9 +315,9 @@ type = logical intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = surface wind enhancement due to convection +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level units = m s-1 dimensions = (horizontal_dimension) type = real diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index da9b8c87c..5d721c016 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -29,19 +29,21 @@ end subroutine sfc_nst_finalize !! \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm !> @{ subroutine sfc_nst_run & +! --- inputs: & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & & pi, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & - & prsl1, prslki, prsik1, prslk1, wet, icy, xlon, sinlat, & + & prsl1, prslki, prsik1, prslk1, wet, xlon, sinlat, & & stress, & & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & - & ddvel, flag_iter, flag_guess, nstf_name1, nstf_name4, & - & nstf_name5, lprnt, ipr, & ! inputs from here and above + & wind, flag_iter, flag_guess, nstf_name1, nstf_name4, & + & nstf_name5, lprnt, ipr, & +! --- input/output: & tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & - & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, & ! in/outs from here and above - & qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & ! outputs + & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, & +! --- outputs: + & qsurf, gflux, cmm, chh, evap, hflx, ep, errmsg, errflg & & ) - -! DH* 20190718: prslki can be removed if GSD_SURFACE_FLUXES_BUGFIX is adopted +! ! ===================================================================== ! ! description: ! ! ! @@ -51,10 +53,9 @@ subroutine sfc_nst_run & ! call sfc_nst ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! -! prsl1, prslki, prsik1, prslk1, iwet, iice, xlon, sinlat, ! -! stress, ! +! prsl1, prslki, wet, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! -! ddvel, flag_iter, flag_guess, nstf_name1, nstf_name4, ! +! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! ! nstf_name5, lprnt, ipr, ! ! input/outputs: ! ! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, ! @@ -106,17 +107,12 @@ subroutine sfc_nst_run & ! sfcemis - real, sfc lw emissivity (fraction) im ! ! dlwflx - real, total sky sfc downward lw flux (w/m**2) im ! ! sfcnsw - real, total sky sfc netsw flx into ocean (w/m**2) im ! -! DH* -! The actual unit of rain passed in is m ! see below line 438, qrain(i) = ... -! where 1000*rain in the nominator converts m to kg m^2; there is still a -! time unit 's' missing. Need to double-check what is going on. -! *DH ! rain - real, rainfall rate (kg/m**2/s) im ! ! timestep - real, timestep interval (second) 1 ! ! kdt - integer, time step counter 1 ! ! solhr - real, fcst hour at the end of prev time step 1 ! ! xcosz - real, consine of solar zenith angle 1 ! -! ddvel - real, wind enhancement due to convection (m/s) im ! +! wind - real, wind speed (m/s) im ! ! flag_iter- logical, execution or not im ! ! when iter = 1, flag_iter = .true. for all grids im ! ! when iter = 2, flag_iter = .true. when wind < 2 im ! @@ -197,12 +193,12 @@ subroutine sfc_nst_run & real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & & t1, q1, tref, cm, ch, prsl1, prslki, prsik1, prslk1, & & xlon,xcosz, & - & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, ddvel + & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind real (kind=kind_phys), intent(in) :: timestep real (kind=kind_phys), intent(in) :: solhr - logical, dimension(im), intent(in) :: flag_iter, flag_guess, wet, & - & icy + logical, dimension(im), intent(in) :: flag_iter, flag_guess, wet +! &, icy logical, intent(in) :: lprnt ! --- input/outputs: @@ -224,7 +220,7 @@ subroutine sfc_nst_run & integer :: k,i ! real (kind=kind_phys), dimension(im) :: q0, qss, rch, - & rho_a, theta1, tv1, wind, wndmag + & rho_a, theta1, tv1, wndmag real(kind=kind_phys) elocp,tem,cpinv,hvapi ! @@ -256,6 +252,62 @@ subroutine sfc_nst_run & errmsg = '' errflg = 0 + write (0,*) "DH DEBUG: IN im = ", im + write (0,*) "DH DEBUG: IN ps = ", sum(ps ) + write (0,*) "DH DEBUG: IN u1 = ", sum(u1 ) + write (0,*) "DH DEBUG: IN v1 = ", sum(v1 ) + write (0,*) "DH DEBUG: IN t1 = ", sum(t1 ) + write (0,*) "DH DEBUG: IN q1 = ", sum(q1 ) + write (0,*) "DH DEBUG: IN tref = ", sum(tref ) + write (0,*) "DH DEBUG: IN cm = ", sum(cm ) + write (0,*) "DH DEBUG: IN ch = ", sum(ch ) + write (0,*) "DH DEBUG: IN prsl1 = ", sum(prsl1 ) + write (0,*) "DH DEBUG: IN prslki = ", sum(prslki ) + write (0,*) "DH DEBUG: IN wet = ", count(wet ) + write (0,*) "DH DEBUG: IN xlon = ", sum(xlon ) + write (0,*) "DH DEBUG: IN sinlat = ", sum(sinlat ) + write (0,*) "DH DEBUG: IN stress = ", sum(stress ) + write (0,*) "DH DEBUG: IN sfcemis = ", sum(sfcemis ) + write (0,*) "DH DEBUG: IN dlwflx = ", sum(dlwflx ) + write (0,*) "DH DEBUG: IN sfcnsw = ", sum(sfcnsw ) + write (0,*) "DH DEBUG: IN rain = ", sum(rain ) + write (0,*) "DH DEBUG: IN timestep = ", timestep + write (0,*) "DH DEBUG: IN kdt = ", kdt + write (0,*) "DH DEBUG: IN solhr = ", solhr + write (0,*) "DH DEBUG: IN xcosz = ", sum(xcosz ) + write (0,*) "DH DEBUG: IN wind = ", sum(wind ) + write (0,*) "DH DEBUG: IN flag_iter = ", count(flag_iter ) + write (0,*) "DH DEBUG: IN flag_guess = ", count(flag_guess) + !write (0,*) "DH DEBUG: IN nstf_name = ", (/ nstf_name1, nstf_name4, nstf_name5 /) + write (0,*) "DH DEBUG: IN lprnt = ", lprnt + write (0,*) "DH DEBUG: IN ipr = ", ipr + write (0,*) "DH DEBUG: IN tskin = ", sum(tskin ) + write (0,*) "DH DEBUG: IN tsurf = ", sum(tsurf ) + write (0,*) "DH DEBUG: IN xt = ", sum(xt ) + write (0,*) "DH DEBUG: IN xs = ", sum(xs ) + write (0,*) "DH DEBUG: IN xu = ", sum(xu ) + write (0,*) "DH DEBUG: IN xv = ", sum(xv ) + write (0,*) "DH DEBUG: IN xz = ", sum(xz ) + write (0,*) "DH DEBUG: IN zm = ", sum(zm ) + write (0,*) "DH DEBUG: IN xtts = ", sum(xtts ) + write (0,*) "DH DEBUG: IN xzts = ", sum(xzts ) + write (0,*) "DH DEBUG: IN dt_cool = ", sum(dt_cool ) + write (0,*) "DH DEBUG: IN z_c = ", sum(z_c ) + write (0,*) "DH DEBUG: IN c_0 = ", sum(c_0 ) + write (0,*) "DH DEBUG: IN c_d = ", sum(c_d ) + write (0,*) "DH DEBUG: IN w_0 = ", sum(w_0 ) + write (0,*) "DH DEBUG: IN w_d = ", sum(w_d ) + write (0,*) "DH DEBUG: IN d_conv = ", sum(d_conv ) + write (0,*) "DH DEBUG: IN ifd = ", sum(ifd ) + write (0,*) "DH DEBUG: IN qrain = ", sum(qrain ) + write (0,*) "DH DEBUG: IN qsurf = ", sum(qsurf ) + write (0,*) "DH DEBUG: IN gflux = ", sum(gflux ) + write (0,*) "DH DEBUG: IN cmm = ", sum(cmm ) + write (0,*) "DH DEBUG: IN chh = ", sum(chh ) + write (0,*) "DH DEBUG: IN evap = ", sum(evap ) + write (0,*) "DH DEBUG: IN hflx = ", sum(hflx ) + write (0,*) "DH DEBUG: IN ep = ", sum(ep ) + cpinv=1.0/cp hvapi=1.0/hvap elocp=hvap/cp @@ -265,13 +317,15 @@ subroutine sfc_nst_run & ! flag for open water and where the iteration is on ! do i = 1, im - flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) +! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) + flag(i) = wet(i) .and. flag_iter(i) enddo ! ! save nst-related prognostic fields for guess run ! do i=1, im - if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then +! if(wet(i) .and. .not.icy(i) .and. flag_guess(i)) then + if(wet(i) .and. flag_guess(i)) then xt_old(i) = xt(i) xs_old(i) = xs(i) xu_old(i) = xu(i) @@ -298,8 +352,6 @@ subroutine sfc_nst_run & nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) - wind(i) = wndmag(i) + max( 0.0, min( ddvel(i), 30.0 ) ) - wind(i) = max( wind(i), 1.0 ) q0(i) = max(q1(i), 1.0e-8) #ifdef GSD_SURFACE_FLUXES_BUGFIX @@ -588,8 +640,9 @@ subroutine sfc_nst_run & ! restore nst-related prognostic fields for guess run do i=1, im - if(wet(i) .and. .not.icy(i)) then - if(flag_guess(i)) then ! when it is guess of +! if (wet(i) .and. .not.icy(i)) then + if (wet(i)) then + if (flag_guess(i)) then ! when it is guess of xt(i) = xt_old(i) xs(i) = xs_old(i) xu(i) = xu_old(i) @@ -609,9 +662,9 @@ subroutine sfc_nst_run & ! if ( nstf_name1 > 1 ) then tskin(i) = tsurf(i) - endif ! if nstf_name1 > 1 - endif ! if flag_guess(i) - endif ! if wet(i) .and. .not.icy(i) + endif ! if nstf_name1 > 1 then + endif ! if flag_guess(i) then + endif ! if wet(i) .and. .not.icy(i) then enddo ! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i) @@ -645,6 +698,62 @@ subroutine sfc_nst_run & ! ! if (lprnt) print *,' tskin=',tskin(ipr) + write (0,*) "DH DEBUG: OUT im = ", im + write (0,*) "DH DEBUG: OUT ps = ", sum(ps ) + write (0,*) "DH DEBUG: OUT u1 = ", sum(u1 ) + write (0,*) "DH DEBUG: OUT v1 = ", sum(v1 ) + write (0,*) "DH DEBUG: OUT t1 = ", sum(t1 ) + write (0,*) "DH DEBUG: OUT q1 = ", sum(q1 ) + write (0,*) "DH DEBUG: OUT tref = ", sum(tref ) + write (0,*) "DH DEBUG: OUT cm = ", sum(cm ) + write (0,*) "DH DEBUG: OUT ch = ", sum(ch ) + write (0,*) "DH DEBUG: OUT prsl1 = ", sum(prsl1 ) + write (0,*) "DH DEBUG: OUT prslki = ", sum(prslki ) + write (0,*) "DH DEBUG: OUT wet = ", count(wet ) + write (0,*) "DH DEBUG: OUT xlon = ", sum(xlon ) + write (0,*) "DH DEBUG: OUT sinlat = ", sum(sinlat ) + write (0,*) "DH DEBUG: OUT stress = ", sum(stress ) + write (0,*) "DH DEBUG: OUT sfcemis = ", sum(sfcemis ) + write (0,*) "DH DEBUG: OUT dlwflx = ", sum(dlwflx ) + write (0,*) "DH DEBUG: OUT sfcnsw = ", sum(sfcnsw ) + write (0,*) "DH DEBUG: OUT rain = ", sum(rain ) + write (0,*) "DH DEBUG: OUT timestep = ", timestep + write (0,*) "DH DEBUG: OUT kdt = ", kdt + write (0,*) "DH DEBUG: OUT solhr = ", solhr + write (0,*) "DH DEBUG: OUT xcosz = ", sum(xcosz ) + write (0,*) "DH DEBUG: OUT wind = ", sum(wind ) + write (0,*) "DH DEBUG: OUT flag_iter = ", count(flag_iter ) + write (0,*) "DH DEBUG: OUT flag_guess = ", count(flag_guess) + !write (0,*) "DH DEBUG: IN nstf_name = ", (/ nstf_name1, nstf_name4, nstf_name5 /) + write (0,*) "DH DEBUG: OUT lprnt = ", lprnt + write (0,*) "DH DEBUG: OUT ipr = ", ipr + write (0,*) "DH DEBUG: OUT tskin = ", sum(tskin ) + write (0,*) "DH DEBUG: OUT tsurf = ", sum(tsurf ) + write (0,*) "DH DEBUG: OUT xt = ", sum(xt ) + write (0,*) "DH DEBUG: OUT xs = ", sum(xs ) + write (0,*) "DH DEBUG: OUT xu = ", sum(xu ) + write (0,*) "DH DEBUG: OUT xv = ", sum(xv ) + write (0,*) "DH DEBUG: OUT xz = ", sum(xz ) + write (0,*) "DH DEBUG: OUT zm = ", sum(zm ) + write (0,*) "DH DEBUG: OUT xtts = ", sum(xtts ) + write (0,*) "DH DEBUG: OUT xzts = ", sum(xzts ) + write (0,*) "DH DEBUG: OUT dt_cool = ", sum(dt_cool ) + write (0,*) "DH DEBUG: OUT z_c = ", sum(z_c ) + write (0,*) "DH DEBUG: OUT c_0 = ", sum(c_0 ) + write (0,*) "DH DEBUG: OUT c_d = ", sum(c_d ) + write (0,*) "DH DEBUG: OUT w_0 = ", sum(w_0 ) + write (0,*) "DH DEBUG: OUT w_d = ", sum(w_d ) + write (0,*) "DH DEBUG: OUT d_conv = ", sum(d_conv ) + write (0,*) "DH DEBUG: OUT ifd = ", sum(ifd ) + write (0,*) "DH DEBUG: OUT qrain = ", sum(qrain ) + write (0,*) "DH DEBUG: OUT qsurf = ", sum(qsurf ) + write (0,*) "DH DEBUG: OUT gflux = ", sum(gflux ) + write (0,*) "DH DEBUG: OUT cmm = ", sum(cmm ) + write (0,*) "DH DEBUG: OUT chh = ", sum(chh ) + write (0,*) "DH DEBUG: OUT evap = ", sum(evap ) + write (0,*) "DH DEBUG: OUT hflx = ", sum(hflx ) + write (0,*) "DH DEBUG: OUT ep = ", sum(ep ) + return end subroutine sfc_nst_run !> @} @@ -678,11 +787,8 @@ end subroutine sfc_nst_pre_finalize !> \section NSST_general_pre_algorithm General Algorithm !! @{ subroutine sfc_nst_pre_run - & (im, rlapse, icy, wet, zorl_ocn, zorl_ice, cd_ocn, cd_ice, - & cdq_ocn, cdq_ice, rb_ocn, rb_ice, stress_ocn, stress_ice, - & ffmm_ocn, ffmm_ice, ffhh_ocn, ffhh_ice, uustar_ocn, - & uustar_ice, fm10_ocn, fm10_ice, fh2_ocn, fh2_ice, oro, - & oro_uf, tsfc_ocn, tsurf_ocn, tseal, errmsg, errflg) + & (im, wet, tsfc_ocn, tsurf_ocn, tseal, xt, xz, dt_cool, + & z_c, tref, cplflx, errmsg, errflg) use machine , only : kind_phys @@ -690,16 +796,14 @@ subroutine sfc_nst_pre_run ! --- inputs: integer, intent(in) :: im - logical, dimension(im), intent(in) :: icy, wet - real (kind=kind_phys), intent(in) :: rlapse - real (kind=kind_phys), dimension(im), intent(in) :: zorl_ice, - & cd_ice, cdq_ice, rb_ice, stress_ice, ffmm_ice, ffhh_ice, - & uustar_ice, fm10_ice, fh2_ice, oro, oro_uf, tsfc_ocn + logical, dimension(im), intent(in) :: wet + real (kind=kind_phys), dimension(im), intent(in) :: + & tsfc_ocn, xt, xz, dt_cool, z_c + logical, intent(in) :: cplflx ! --- input/outputs: - real (kind=kind_phys), dimension(im), intent(inout) :: tsurf_ocn, - & zorl_ocn, cd_ocn, cdq_ocn, rb_ocn, stress_ocn, ffmm_ocn, - & ffhh_ocn, uustar_ocn, fm10_ocn, fh2_ocn, tseal + real (kind=kind_phys), dimension(im), intent(inout) :: + & tsurf_ocn, tseal, tref ! --- outputs: character(len=*), intent(out) :: errmsg @@ -707,20 +811,48 @@ subroutine sfc_nst_pre_run ! --- locals integer :: i - real(kind=kind_phys) :: tem + real(kind=kind_phys), parameter :: zero = 0.0d0, + & one = 1.0d0, + & half = 0.5d0, + & omz1 = 10.0d0 + real(kind=kind_phys) :: tem1, tem2, dt_warm ! Initialize CCPP error handling variables errmsg = '' errflg = 0 do i=1,im - if (wet(i) .and. .not. icy(i)) then - tem = (oro(i)-oro_uf(i)) * rlapse - tseal(i) = tsfc_ocn(i) + tem - tsurf_ocn(i) = tsurf_ocn(i) + tem + if (wet(i)) then +! tem = (oro(i)-oro_uf(i)) * rlapse + ! DH* 20190927 simplyfing this code because tem is zero + !tem = zero + !tseal(i) = tsfc_ocn(i) + tem + tseal(i) = tsfc_ocn(i) + !tsurf_ocn(i) = tsurf_ocn(i) + tem + ! *DH endif enddo + if (cplflx) then + tem1 = half / omz1 + do i=1,im + if (wet(i)) then + tem2 = one / xz(i) + dt_warm = (xt(i)+xt(i)) * tem2 + if ( xz(i) > omz1) then + tref(i) = tseal(i) - (one-half*omz1*tem2) * dt_warm & + & + z_c(i)*dt_cool(i)*tem1 + else + tref(i) = tseal(i) - (xz(i)*dt_warm & + & - z_c(i)*dt_cool(i))*tem1 + endif + tseal(i) = tref(i) + dt_warm - dt_cool(i) +! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse + tsurf_ocn(i) = tseal(i) + endif + enddo + endif + return end subroutine sfc_nst_pre_run !! @} @@ -799,11 +931,11 @@ subroutine sfc_nst_post_run & ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), ! & ' kdt=',kdt - do i = 1, im - if (wet(i) .and. .not. icy(i)) then - tsurf_ocn(i) = tsurf_ocn(i) - (oro(i)-oro_uf(i)) * rlapse - endif - enddo +! do i = 1, im +! if (wet(i) .and. .not. icy(i)) then +! tsurf_ocn(i) = tsurf_ocn(i) - (oro(i)-oro_uf(i)) * rlapse +! endif +! enddo ! --- ... run nsst model ... --- @@ -812,12 +944,15 @@ subroutine sfc_nst_post_run & zsea1 = 0.001*real(nstf_name4) zsea2 = 0.001*real(nstf_name5) call get_dtzm_2d (xt, xz, dt_cool, & - & z_c, wet, icy, zsea1, zsea2, & + & z_c, wet, zsea1, zsea2, & & im, 1, dtzm) do i = 1, im - if ( wet(i) .and. .not. icy(i) ) then - tsfc_ocn(i) = max(271.2,tref(i) + dtzm(i)) - & - & (oro(i)-oro_uf(i))*rlapse +! if (wet(i) .and. .not.icy(i)) then +! if (wet(i) .and. (Model%frac_grid .or. .not. icy(i))) then + if (wet(i)) then + tsfc_ocn(i) = max(271.2, tref(i) + dtzm(i)) +! tsfc_ocn(i) = max(271.2, tref(i) + dtzm(i)) - & +! (oro(i)-oro_uf(i))*rlapse endif enddo endif diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 73b585c71..d74f68c0e 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -234,14 +234,6 @@ type = logical intent = in optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_dimension) - type = logical - intent = in - optional = F [xlon] standard_name = longitude long_name = longitude @@ -270,8 +262,8 @@ intent = in optional = F [sfcemis] - standard_name = surface_longwave_emissivity - long_name = surface longwave emissivity + standard_name = surface_longwave_emissivity_over_ocean_interstitial + long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) units = frac dimensions = (horizontal_dimension) type = real @@ -279,8 +271,8 @@ intent = in optional = F [dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground - long_name = total sky sfc downward lw flux absorbed by the ocean + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ocean + long_name = total sky surface downward longwave flux absorbed by the ground over ocean units = W m-2 dimensions = (horizontal_dimension) type = real @@ -340,9 +332,9 @@ kind = kind_phys intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = wind enhancement due to convection +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level units = m s-1 dimensions = (horizontal_dimension) type = real @@ -679,23 +671,6 @@ type = integer intent = in optional = F -[rlapse] - standard_name = air_temperature_lapse_rate_constant - long_name = environmental air temperature lapse rate constant - units = K m-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_dimension) - type = logical - intent = in - optional = F [wet] standard_name = flag_nonzero_wet_surface_fraction long_name = flag indicating presence of some ocean or lake surface area fraction @@ -704,230 +679,85 @@ type = logical intent = in optional = F -[zorl_ocn] - standard_name = surface_roughness_length_over_ocean_interstitial - long_name = surface roughness length over ocean (temporary use as interstitial) - units = cm - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[zorl_ice] - standard_name = surface_roughness_length_over_ice_interstitial - long_name = surface roughness length over ice (temporary use as interstitial) - units = cm - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[cd_ocn] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean - long_name = surface exchange coeff for momentum over ocean - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[cd_ice] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice - long_name = surface exchange coeff for momentum over ice - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[cdq_ocn] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean - long_name = surface exchange coeff heat & moisture over ocean - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[cdq_ice] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice - long_name = surface exchange coeff heat & moisture over ice - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[rb_ocn] - standard_name = bulk_richardson_number_at_lowest_model_level_over_ocean - long_name = bulk Richardson number at the surface over ocean - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[rb_ice] - standard_name = bulk_richardson_number_at_lowest_model_level_over_ice - long_name = bulk Richardson number at the surface over ice - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[stress_ocn] - standard_name = surface_wind_stress_over_ocean - long_name = surface wind stress over ocean - units = m2 s-2 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[stress_ice] - standard_name = surface_wind_stress_over_ice - long_name = surface wind stress over ice - units = m2 s-2 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[ffmm_ocn] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean - long_name = Monin-Obukhov similarity function for momentum over ocean - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[ffmm_ice] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice - long_name = Monin-Obukhov similarity function for momentum over ice - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[ffhh_ocn] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean - long_name = Monin-Obukhov similarity function for heat over ocean - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[ffhh_ice] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice - long_name = Monin-Obukhov similarity function for heat over ice - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[uustar_ocn] - standard_name = surface_friction_velocity_over_ocean - long_name = surface friction velocity over ocean - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[uustar_ice] - standard_name = surface_friction_velocity_over_ice - long_name = surface friction velocity over ice - units = m s-1 +[tsfc_ocn] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[fm10_ocn] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean - long_name = Monin-Obukhov similarity parameter for momentum at 10m over ocean - units = none +[tsurf_ocn] + standard_name = surface_skin_temperature_after_iteration_over_ocean + long_name = surface skin temperature after iteration over ocean + units = K dimensions = (horizontal_dimension) type = real kind = kind_phys intent = inout optional = F -[fm10_ice] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice - long_name = Monin-Obukhov similarity parameter for momentum at 10m over ice - units = none - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[fh2_ocn] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean - long_name = Monin-Obukhov similarity parameter for heat at 2m over ocean - units = none +[tseal] + standard_name = surface_skin_temperature_for_nsst + long_name = ocean surface skin temperature + units = K dimensions = (horizontal_dimension) type = real kind = kind_phys intent = inout optional = F -[fh2_ice] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice - long_name = Monin-Obukhov similarity parameter for heat at 2m over ice - units = none +[xt] + standard_name = diurnal_thermocline_layer_heat_content + long_name = heat content in diurnal thermocline layer + units = K m dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[oro] - standard_name = orography - long_name = orography +[xz] + standard_name = diurnal_thermocline_layer_thickness + long_name = diurnal thermocline layer thickness units = m dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[oro_uf] - standard_name = orography_unfiltered - long_name = unfiltered orographyo - units = m +[dt_cool] + standard_name = sub_layer_cooling_amount + long_name = sub-layer cooling amount + units = K dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[tsfc_ocn] - standard_name = surface_skin_temperature_over_ocean_interstitial - long_name = surface skin temperature over ocean (temporary use as interstitial) - units = K +[z_c] + standard_name = sub_layer_cooling_thickness + long_name = sub-layer cooling thickness + units = m dimensions = (horizontal_dimension) type = real kind = kind_phys intent = in optional = F -[tsurf_ocn] - standard_name = surface_skin_temperature_after_iteration_over_ocean - long_name = surface skin temperature after iteration over ocean +[tref] + standard_name = sea_surface_reference_temperature + long_name = reference/foundation temperature units = K dimensions = (horizontal_dimension) type = real kind = kind_phys intent = inout optional = F -[tseal] - standard_name = surface_skin_temperature_for_nsst - long_name = ocean surface skin temperature - units = K - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout +[cplflx] + standard_name = flag_for_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in optional = F [errmsg] standard_name = ccpp_error_message diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 625e8e5f0..9635f30b8 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -23,8 +23,8 @@ end subroutine sfc_ocean_finalize subroutine sfc_ocean_run & !................................... ! --- inputs: - & ( im, cp, rd, eps, epsm1, hvap, rvrdm1, ps, u1, v1, t1, q1, & - & tskin, cm, ch, prsl1, prslki, wet, ddvel, & + & ( im, cp, rd, eps, epsm1, hvap, rvrdm1, ps, t1, q1, & + & tskin, cm, ch, prsl1, prslki, wet, wind, & & flag_iter, & ! --- outputs: & qsurf, cmm, chh, gflux, evap, hflx, ep, & @@ -38,8 +38,9 @@ subroutine sfc_ocean_run & ! ! ! call sfc_ocean ! ! inputs: ! -! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! -! prsl1, prslki, wet, ddvel, flag_iter, ! +! ( im, ps, t1, q1, tskin, cm, ch, ! +!! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! +! prsl1, prslki, wet, wind, flag_iter, ! ! outputs: ! ! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! ! ! @@ -62,7 +63,6 @@ subroutine sfc_ocean_run & ! inputs: size ! ! im - integer, horizontal dimension 1 ! ! ps - real, surface pressure im ! -! u1, v1 - real, u/v component of surface layer wind im ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tskin - real, ground surface skin temperature ( k ) im ! @@ -71,7 +71,7 @@ subroutine sfc_ocean_run & ! prsl1 - real, surface layer mean pressure im ! ! prslki - real, im ! ! wet - logical, =T if any ocean/lak, =F otherwise im ! -! ddvel - real, wind enhancement due to convection (m/s) im ! +! wind - real, wind speed (m/s) im ! ! flag_iter- logical, im ! ! ! ! outputs: ! @@ -95,8 +95,8 @@ subroutine sfc_ocean_run & real (kind=kind_phys), intent(in) :: cp, rd, eps, epsm1, hvap, & & rvrdm1 - real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & - & t1, q1, tskin, cm, ch, prsl1, prslki, ddvel + real (kind=kind_phys), dimension(im), intent(in) :: ps, & + & t1, q1, tskin, cm, ch, prsl1, prslki, wind logical, dimension(im), intent(in) :: flag_iter, wet @@ -109,7 +109,7 @@ subroutine sfc_ocean_run & ! --- locals: - real (kind=kind_phys) :: q0, qss, rch, rho, wind, tem, cpinv, & + real (kind=kind_phys) :: q0, qss, rch, rho, tem, cpinv, & & hvapi, elocp integer :: i @@ -134,10 +134,6 @@ subroutine sfc_ocean_run & ! rho is density, qss is sat. hum. at surface if ( flag(i) ) then - - wind = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - & + max( 0.0, min( ddvel(i), 30.0 ) ), 1.0) - q0 = max( q1(i), 1.0e-8 ) rho = prsl1(i) / (rd*t1(i)*(1.0 + rvrdm1*q0)) @@ -151,9 +147,9 @@ subroutine sfc_ocean_run & ! --- ... rcp = rho cp ch v - rch = rho * cp * ch(i) * wind - cmm(i) = cm(i) * wind - chh(i) = rho * ch(i) * wind + rch = rho * cp * ch(i) * wind(i) + cmm(i) = cm(i) * wind(i) + chh(i) = rho * ch(i) * wind(i) ! --- ... sensible and latent heat flux over open water diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index 4304e344d..d60c1ce2c 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -82,24 +82,6 @@ kind = kind_phys intent = in optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer - long_name = x component of surface layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer - long_name = y component of surface layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [t1] standard_name = air_temperature_at_lowest_model_layer long_name = surface layer mean temperature @@ -171,9 +153,9 @@ type = logical intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = wind enhancement due to convection +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level units = m s-1 dimensions = (horizontal_dimension) type = real diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 7c2da2415..9471792fa 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -41,17 +41,16 @@ end subroutine sfc_sice_finalize !> @{ subroutine sfc_sice_run & & ( im, km, sbc, hvap, tgice, cp, eps, epsm1, rvrdm1, grav, & ! --- inputs: - & t0c, rd, cimin, ps, u1, v1, t1, q1, delt, & + & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & - & cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, ddvel, & - & flag_iter, lprnt, ipr, & + & cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, wind, & + & flag_iter, lprnt, ipr, cimin, & & hice, fice, tice, weasd, tskin, tprcp, stc, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! & cplflx, cplchm, flag_cice, islmsk_cice, & & errmsg, errflg & ) -! DH* 20190718: prslki can be removed if GSD_SURFACE_FLUXES_BUGFIX is adopted ! ===================================================================== ! ! description: ! ! ! @@ -59,9 +58,9 @@ subroutine sfc_sice_run & ! ! ! call sfc_sice ! ! inputs: ! -! ( im, km, ps, u1, v1, t1, q1, delt, ! +! ( im, km, ps, t1, q1, delt, ! ! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! -! cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, ddvel, ! +! cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, wind, ! ! flag_iter, ! ! input/outputs: ! ! hice, fice, tice, weasd, tskin, tprcp, stc, ep, ! @@ -93,7 +92,6 @@ subroutine sfc_sice_run & ! inputs: size ! ! im, km - integer, horiz dimension and num of soil layers 1 ! ! ps - real, surface pressure im ! -! u1, v1 - real, u/v component of surface layer wind im ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! delt - real, time interval (second) 1 ! @@ -109,7 +107,7 @@ subroutine sfc_sice_run & ! prsik1 - real, im ! ! prslk1 - real, im ! ! islimsk - integer, sea/land/ice mask (=0/1/2) im ! -! ddvel - real, im ! +! wind - real, im ! ! flag_iter- logical, im ! ! ! ! input/outputs: ! @@ -134,7 +132,7 @@ subroutine sfc_sice_run & ! ! ! ===================================================================== ! ! - use machine, only: kind_phys + use machine, only : kind_phys use funcphys, only : fpvs ! implicit none @@ -156,15 +154,15 @@ subroutine sfc_sice_run & logical, intent(in) :: cplchm real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & - & epsm1, grav, rvrdm1, t0c, rd, cimin + & epsm1, grav, rvrdm1, t0c, rd - real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + real (kind=kind_phys), dimension(im), intent(in) :: ps, & & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, prsik1, prslk1, ddvel + & prsl1, prslki, prsik1, prslk1, wind integer, dimension(im), intent(in) :: islimsk integer, dimension(im), intent(in) :: islmsk_cice - real (kind=kind_phys), intent(in) :: delt + real (kind=kind_phys), intent(in) :: delt, cimin logical, dimension(im), intent(in) :: flag_iter, flag_cice @@ -189,7 +187,7 @@ subroutine sfc_sice_run & & snowd, theta1 real (kind=kind_phys) :: t12, t14, tem, stsice(im,kmi) - &, hflxi, hflxw, q0, qs1, wind, qssi, qssw + &, hflxi, hflxw, q0, qs1, qssi, qssw real (kind=kind_phys) :: cpinv, hvapi, elocp integer :: i, k @@ -266,9 +264,6 @@ subroutine sfc_sice_run & ! dlwflx has been given a negative sign for downward longwave ! sfcnsw is the net shortwave flux (direction: dn-up) - wind = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - & + max(zero, min(ddvel(i), 30.0d0)), one) - q0 = max(q1(i), 1.0e-8) ! tsurf(i) = tskin(i) #ifdef GSD_SURFACE_FLUXES_BUGFIX @@ -307,8 +302,8 @@ subroutine sfc_sice_run & ! --- ... rcp = rho cp ch v - cmm(i) = cm(i) * wind - chh(i) = rho(i) * ch(i) * wind + cmm(i) = cm(i) * wind(i) + chh(i) = rho(i) * ch(i) * wind(i) rch(i) = chh(i) * cp !> - Calculate sensible and latent heat flux over open water & sea ice. diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 1af043885..c9641ffaa 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -107,15 +107,6 @@ kind = kind_phys intent = in optional = F -[cimin] - standard_name = minimum_sea_ice_concentration - long_name = minimum sea ice concentration - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [ps] standard_name = surface_air_pressure long_name = surface pressure @@ -125,24 +116,6 @@ kind = kind_phys intent = in optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer - long_name = u component of surface layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer - long_name = v component of surface layer wind - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [t1] standard_name = air_temperature_at_lowest_model_layer long_name = surface layer mean temperature @@ -171,8 +144,8 @@ intent = in optional = F [sfcemis] - standard_name = surface_longwave_emissivity - long_name = sfc lw emissivity + standard_name = surface_longwave_emissivity_over_ice_interstitial + long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) units = frac dimensions = (horizontal_dimension) type = real @@ -180,8 +153,8 @@ intent = in optional = F [dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground - long_name = total sky surface downward longwave flux absorbed by the ground + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice + long_name = total sky surface downward longwave flux absorbed by the ground over ice units = W m-2 dimensions = (horizontal_dimension) type = real @@ -277,9 +250,9 @@ type = integer intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = wind enhancement due to convection +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level units = m s-1 dimensions = (horizontal_dimension) type = real @@ -310,6 +283,15 @@ type = integer intent = in optional = F +[cimin] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = ??? + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [hice] standard_name = sea_ice_thickness long_name = sea-ice thickness diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 7039884f8..6296e7856 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -6146,17 +6146,24 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & ! ijmax = imax*jmax rslmsk = 0. +! TG3 MODS BEGIN + if(kpds5 == kpdtsf .and. imax == 138 .and. jmax == 116 + & .and. kpds4 == 128) then +! print*,'turn off setrmsk for tg3' + lmask = .false. + + elseif(kpds5 == kpdtsf) then +! TG3 MODS END ! ! surface temperature ! - if(kpds5.eq.kpdtsf) then -! lmask=.false. + lmask = .false. call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat &, rlnout, rltout, gaus, blno, blto) ! &, dlon, dlat, gaus, blno, blto) - crit=0.5 + crit = 0.5 call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. + lmask = .true. ! ! bucket soil wetness ! @@ -6164,16 +6171,16 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat &, rlnout, rltout, gaus, blno, blto) ! &, dlon, dlat, gaus, blno, blto) - crit=0.5 + crit = 0.5 call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. + lmask = .true. ! write(6,*) 'wet rslmsk' ! znnt=1. ! call nntprt(rslmsk,ijmax,znnt) ! ! snow depth ! - elseif(kpds5.eq.kpdsnd) then + elseif(kpds5 == kpdsnd) then if(kpds4 == 192) then ! use the bitmap rslmsk = 0. do j = 1, jmax @@ -7043,51 +7050,51 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! get tsf climatology for the begining of the forecast ! - if (fh .gt. 0.0) then + if (fh > 0.0) then !cbosu if (me == 0) print*,'bosu fh gt 0' - iy4=iy - if(iy.lt.101) iy4=1900+iy4 - fha=0 - ida=0 - jda=0 -! fha(2)=nint(fh) - ida(1)=iy - ida(2)=im - ida(3)=id - ida(5)=ih + iy4 = iy + if (iy < 101) iy4 = 1900 + iy4 + fha = 0 + ida = 0 + jda = 0 +! fha(2) = nint(fh) + ida(1) = iy + ida(2) = im + ida(3) = id + ida(5) = ih call w3kind(w3kindreal,w3kindint) if(w3kindreal == 4) then - fha4=fha + fha4 = fha call w3movdat(fha4,ida,jda) else call w3movdat(fha,ida,jda) endif - jy=jda(1) - jm=jda(2) - jd=jda(3) - jh=jda(5) - if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh', - & jy,jm,jd,jh + jy = jda(1) + jm = jda(2) + jd = jda(3) + jh = jda(5) + if (me == 0) write(6,*) ' forecast jy,jm,jd,jh', + & jy,jm,jd,jh jdow = 0 jdoy = 0 jday = 0 call w3doxdat(jda,jdow,jdoy,jday) - rjday=jdoy+jda(5)/24. - if(rjday.lt.dayhf(1)) rjday=rjday+365. + rjday = jdoy + jda(5) / 24. + if(rjday < dayhf(1)) rjday = rjday + 365. ! - if (me .eq. 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh + if (me == 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh ! ! for monthly mean climatology ! monend = 12 do mm=1,monend - mmm=mm - mmp=mm+1 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then - mon1=mmm - mon2=mmp + mmm = mm + mmp = mm + 1 + if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then + mon1 = mmm + mon2 = mmp go to 10 endif enddo @@ -7095,17 +7102,18 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & call abort 10 continue wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) - wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if(mon2.eq.13) mon2=1 - if (me .eq. 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m + wei2m = 1.0 - wei1m +! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if (mon2 == 13) mon2 = 1 + if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', + & rjday,mon1,mon2,wei1m,wei2m ! ! read monthly mean climatology of tsf ! kpd7 = -1 do nn=1,2 mon = mon1 - if (nn .eq. 2) mon = mon2 + if (nn == 2) mon = mon2 call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto @@ -7122,8 +7130,8 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! compute current jy,jm,jd,jh of forecast and the day of the year ! - iy4=iy - if(iy.lt.101) iy4=1900+iy4 + iy4 = iy + if (iy < 101) iy4=1900+iy4 fha = 0 ida = 0 jda = 0 @@ -7133,8 +7141,8 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ida(3) = id ida(5) = ih call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - fha4=fha + if(w3kindreal == 4) then + fha4 = fha call w3movdat(fha4,ida,jda) else call w3movdat(fha,ida,jda) @@ -7149,44 +7157,45 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & jdoy = 0 jday = 0 call w3doxdat(jda,jdow,jdoy,jday) - rjday = jdoy+jda(5)/24. - if(rjday.lt.dayhf(1)) rjday=rjday+365. + rjday = jdoy + jda(5) / 24. + if(rjday < dayhf(1)) rjday = rjday + 365. - if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', - & jy,jm,jd,jh,rjday + if (me == 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', + & jy,jm,jd,jh,rjday ! - if (me .eq. 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh + if (me == 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh ! ! for monthly mean climatology ! monend = 12 do mm=1,monend - mmm=mm - mmp=mm+1 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then - mon1=mmm - mon2=mmp + mmm = mm + mmp = mm + 1 + if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then + mon1 = mmm + mon2 = mmp go to 20 endif enddo print *,'wrong rjday',rjday call abort 20 continue - wei1m=(dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) - wei2m=(rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if(mon2.eq.13) mon2=1 - if (me .eq. 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m + wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) + wei2m = 1.0 - wei1m +! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if (mon2 == 13) mon2 = 1 + if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', + & rjday,mon1,mon2,wei1m,wei2m ! ! for seasonal mean climatology ! monend = 4 is = im/3 + 1 - if (is.eq.5) is = 1 + if (is == 5) is = 1 do mm=1,monend mmm = mm*3 - 2 mmp = (mm+1)*3 - 2 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then sea1 = mmm sea2 = mmp go to 30 @@ -7196,20 +7205,21 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & call abort 30 continue wei1s = (dayhf(sea2)-rjday)/(dayhf(sea2)-dayhf(sea1)) - wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) - if(sea2.eq.13) sea2=1 - if (me .eq. 0) print *,'rjday,sea1,sea2,wei1s,wei2s=', - & rjday,sea1,sea2,wei1s,wei2s + wei2s = 1.0 - wei1s +! wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) + if (sea2 == 13) sea2 = 1 + if (me == 0) print *,'rjday,sea1,sea2,wei1s,wei2s=', + & rjday,sea1,sea2,wei1s,wei2s ! ! for summer and winter values (maximum and minimum). ! monend = 2 is = im/6 + 1 - if (is.eq.3) is = 1 + if (is == 3) is = 1 do mm=1,monend mmm = mm*6 - 5 mmp = (mm+1)*6 - 5 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then hyr1 = mmm hyr2 = mmp go to 31 @@ -7219,10 +7229,11 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & call abort 31 continue wei1y = (dayhf(hyr2)-rjday)/(dayhf(hyr2)-dayhf(hyr1)) - wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) - if(hyr2.eq.13) hyr2=1 - if (me .eq. 0) print *,'rjday,hyr1,hyr2,wei1y,wei2y=', - & rjday,hyr1,hyr2,wei1y,wei2y + wei2y = 1.0 - wei1y +! wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) + if (hyr2 == 13) hyr2 = 1 + if (me == 0) print *,'rjday,hyr1,hyr2,wei1y,wei2y=', + & rjday,hyr1,hyr2,wei1y,wei2y ! ! start reading in climatology and interpolate to the date ! @@ -7622,7 +7633,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! mon1s = mon1 ; mon2s = mon2 ; sea1s = sea1 ; sea2s = sea2 ! - if (me .eq. 0) print *,' mon1s=',mon1s,' mon2s=',mon2s + if (me == 0) print *,' mon1s=',mon1s,' mon2s=',mon2s &,' sea1s=',sea1s,' sea2s=',sea2s ! k1 = 1 ; k2 = 2 @@ -7680,11 +7691,11 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! seasonal mean climatology ! isx = sea2/3 + 1 - if (isx .eq. 5) isx = 1 - if(isx.eq.1) kpd9 = 12 - if(isx.eq.2) kpd9 = 3 - if(isx.eq.3) kpd9 = 6 - if(isx.eq.4) kpd9 = 9 + if (isx == 5) isx = 1 + if (isx == 1) kpd9 = 12 + if (isx == 2) kpd9 = 3 + if (isx == 3) kpd9 = 6 + if (isx == 4) kpd9 = 9 ! ! albedo ! there are four albedo fields in this version: @@ -7720,7 +7731,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (me == 0) print*,'bosu 2nd time in clima for month ', & mon, k1,k2 if ( index(fnalbc, "tileX.nc") == 0) then ! grib file - kpd7=-1 + kpd7 = -1 do k = 1, 4 call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, & alb(1,k,nn),len,iret @@ -7737,7 +7748,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! tsf at the current time t ! - kpd7=-1 + kpd7 = -1 call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto @@ -7745,13 +7756,13 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! soil wetness ! - if(fnwetc(1:8).ne.' ') then + if (fnwetc(1:8).ne.' ') then kpd7=-1 call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, & wet(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - elseif(fnsmcc(1:8).ne.' ') then + elseif (fnsmcc(1:8).ne.' ') then if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data kpd7=-1 call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, @@ -7793,13 +7804,13 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! sea ice ! - kpd7=-1 - if(fnacnc(1:8).ne.' ') then + kpd7 = -1 + if (fnacnc(1:8).ne.' ') then call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, & acn(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - elseif(fnaisc(1:8).ne.' ') then + elseif (fnaisc(1:8).ne.' ') then call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, & ais(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto @@ -7819,7 +7830,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! snow cover ! - if(fnscvc(1:8).ne.' ') then + if (fnscvc(1:8).ne.' ') then kpd7=-1 call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, & scv(1,nn),len,iret @@ -7830,7 +7841,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! surface roughness ! - if(fnzorc(1:3) == 'sib') then + if (fnzorc(1:3) == 'sib') then if (me == 0) then write(6,*) 'roughness length to be set from sib veg type' endif @@ -7848,7 +7859,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! vegetation cover ! - if(fnvegc(1:8).ne.' ') then + if (fnvegc(1:8) .ne. ' ') then if ( index(fnvegc, "tileX.nc") == 0) then ! grib file kpd7=-1 call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, @@ -7870,35 +7881,35 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! when chosen, set the z0 based on the vegetation type. ! for this option to work, namelist variable fnvetc must be ! set to point at the proper vegetation type file. - if(fnzorc(1:3) == 'sib') then - if(fnvetc(1:4) == ' ') then + if (fnzorc(1:3) == 'sib') then + if (fnvetc(1:4) == ' ') then if (me==0) write(6,*) "must choose sib veg type climo file" call abort endif zorclm = 0.0 do i=1,len - ivtyp=nint(vet(i)) + ivtyp = nint(vet(i)) if (ivtyp >= 1 .and. ivtyp <= 13) then zorclm(i) = z0_sib(ivtyp) endif enddo elseif(fnzorc(1:4) == 'igbp') then - if(fnvetc(1:4) == ' ') then - if (me==0) write(6,*) "must choose igbp veg type climo file" + if (fnvetc(1:4) == ' ') then + if (me == 0) write(6,*) "must choose igbp veg type climo file" call abort endif zorclm = 0.0 do i=1,len - ivtyp=nint(vet(i)) + ivtyp = nint(vet(i)) if (ivtyp >= 1 .and. ivtyp <= 20) then z0_season(1) = z0_igbp_min(ivtyp) z0_season(7) = z0_igbp_max(ivtyp) - if(outlat(i) < 0.0)then + if (outlat(i) < 0.0) then zorclm(i) = wei1y * z0_season(hyr2) + - & wei2y *z0_season(hyr1) + & wei2y * z0_season(hyr1) else zorclm(i) = wei1y * z0_season(hyr1) + - & wei2y *z0_season(hyr2) + & wei2y * z0_season(hyr2) endif endif enddo diff --git a/physics/sflx.f b/physics/sflx.f index 5c0cf08ce..1654a8872 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -337,7 +337,8 @@ subroutine gfssflx &! --- input & psisat, quartz, rch, refkdt, rr, rgl, rsmax, sndens, & & sncond, sbeta, sn_new, slope, snup, salp, soilwm, soilww, & & t1v, t24, t2v, th2v, topt, tsnow, zbot, z0 - + + real (kind=kind_phys) :: shdfac0 real (kind=kind_phys), dimension(nsold) :: rtdis, zsoil logical :: frzgra, snowng @@ -368,6 +369,7 @@ subroutine gfssflx &! --- input ! vegetation fraction (shdfac) = 0. !> - Set ice = -1 and green vegetation fraction (shdfac) = 0 for glacial-ice land. + shdfac0 = shdfac ice = icein if(ivegsrc == 2) then @@ -420,12 +422,18 @@ subroutine gfssflx &! --- input !only igbp type has urban !urban if(vegtyp == 13)then - shdfac=0.05 - rsmin=400.0 - smcmax = 0.45 - smcref = 0.42 - smcwlt = 0.40 - smcdry = 0.40 +! shdfac=0.05 +! rsmin=400.0 +! smcmax = 0.45 +! smcref = 0.42 +! smcwlt = 0.40 +! smcdry = 0.40 + rsmin=400.0*(1-shdfac0)+40.0*shdfac0 ! gvf + shdfac=shdfac0 ! gvf + smcmax = 0.45*(1-shdfac0)+smcmax*shdfac0 + smcref = 0.42*(1-shdfac0)+smcref*shdfac0 + smcwlt = 0.40*(1-shdfac0)+smcwlt*shdfac0 + smcdry = 0.40*(1-shdfac0)+smcdry*shdfac0 endif endif @@ -662,18 +670,21 @@ subroutine gfssflx &! --- input ! --- outputs: & df1 & & ) -!> - For IGBP/urban, \f$df1=3.24\f$. - if(ivegsrc == 1) then +! if(ivegsrc == 1) then !only igbp type has urban !urban - if ( vegtyp == 13 ) df1=3.24 - endif +! if ( vegtyp == 13 ) df1=3.24 +! endif !> - Add subsurface heat flux reduction effect from the !! overlying green canopy, adapted from section 2.1.2 of !! \cite peters-lidard_et_al_1997. - - df1 = df1 * exp( sbeta*shdfac ) +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) + else + df1 = df1 * exp( sbeta*shdfac ) + endif endif ! end if_ice_block @@ -1499,18 +1510,22 @@ subroutine nopac ! --- outputs: & df1 & & ) - if(ivegsrc == 1) then +! if(ivegsrc == 1) then !urban - if ( vegtyp == 13 ) df1=3.24 - endif +! if ( vegtyp == 13 ) df1=3.24 +! endif ! --- ... vegetation greenness fraction reduction in subsurface heat ! flux via reduction factor, which is convenient to apply here ! to thermal diffusivity that is later used in hrt to compute ! sub sfc heat flux (see additional comments on veg effect ! sub-sfc heat flx in routine sflx) - - df1 = df1 * exp( sbeta*shdfac ) +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) + else + df1 = df1 * exp( sbeta*shdfac ) + endif ! --- ... compute intermediate terms passed to routine hrt (via routine ! shflx below) for use in computing subsurface heat flux in hrt @@ -2595,8 +2610,8 @@ subroutine snopac if (t12 <= tfreez) then t1 = t12 -! ssoil = df1 * (t1 - stc(1)) / dtot - ssoil = (t1 - stc (1)) * max(7.0, df1/dtot) + ssoil = df1 * (t1 - stc(1)) / dtot +!wz ssoil = (t1 - stc (1)) * max(7.0, df1/dtot) sneqv = max(0.0, sneqv-esnow2) flx3 = 0.0 ex = 0.0 @@ -2729,7 +2744,7 @@ subroutine snopac ! skin temp value as revised by shflx. zz1 = 1.0 - yy = stc(1) - 0.5*ssoil*zsoil(1)*zz1 / df1 + yy = stc(1) - 0.5*ssoil*zsoil(1)*zz1 / df1 t11 = t1 ! --- ... shflx will calc/update the soil temps. note: the sub-sfc heat flux @@ -3371,6 +3386,7 @@ subroutine shflx & ! --- inputs: & ( nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, & & zbot, psisat, dt, bexp, df1, quartz, csoil,vegtyp, & + & shdfac, & ! --- input/outputs: & sh2o, & ! --- outputs: @@ -4037,6 +4053,7 @@ subroutine hrt & ! --- inputs: & ( nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, & & zbot, psisat, dt, bexp, df1, quartz, csoil, vegtyp, & + & shdfac, & ! --- input/outputs: & sh2o, & ! --- outputs: @@ -4090,7 +4107,7 @@ subroutine hrt & real (kind=kind_phys), intent(in) :: stc(nsoil), smc(nsoil), & & smcmax, zsoil(nsoil), yy, zz1, tbot, zbot, psisat, dt, & - & bexp, df1, quartz, csoil + & bexp, df1, quartz, csoil, shdfac ! --- input/outputs: real (kind=kind_phys), intent(inout) :: sh2o(nsoil) @@ -4116,7 +4133,8 @@ subroutine hrt & if (ivegsrc == 1)then !urban if( vegtyp == 13 ) then - csoil_loc=3.0e6 +! csoil_loc=3.0e6 + csoil_loc=3.0e6*(1.-shdfac)+csoil*shdfac ! gvf endif endif @@ -4206,7 +4224,7 @@ subroutine hrt & call snksrc & ! --- inputs: & ( nsoil, 1, tavg, smc(1), smcmax, psisat, bexp, dt, & - & qtot, zsoil, & + & qtot, zsoil, shdfac, & ! --- input/outputs: & sh2o(1), & ! --- outputs: @@ -4248,9 +4266,13 @@ subroutine hrt & & df1n & & ) !urban - if (ivegsrc == 1)then - if ( vegtyp == 13 ) df1n = 3.24 - endif +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1n = 3.24 +! endif +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1n = 3.24*(1.-shdfac) + shdfac*df1n + endif ! --- ... calc the vertical soil temp gradient thru this layer @@ -4288,9 +4310,13 @@ subroutine hrt & & df1n & & ) !urban - if (ivegsrc == 1)then - if ( vegtyp == 13 ) df1n = 3.24 - endif +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1n = 3.24 +! endif +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1n = 3.24*(1.-shdfac) + shdfac*df1n + endif ! --- ... calc the vertical soil temp gradient thru bottom layer. @@ -4344,7 +4370,7 @@ subroutine hrt & call snksrc & ! --- inputs: & ( nsoil, k, tavg, smc(k), smcmax, psisat, bexp, dt, & - & qtot, zsoil, & + & qtot, zsoil, shdfac, & ! --- input/outputs: & sh2o(k), & ! --- outputs: @@ -4759,7 +4785,7 @@ end subroutine rosr12 subroutine snksrc & ! --- inputs: & ( nsoil, k, tavg, smc, smcmax, psisat, bexp, dt, & - & qtot, zsoil, & + & qtot, zsoil, shdfac, & ! --- input/outputs: & sh2o, & ! --- outputs: @@ -4804,7 +4830,7 @@ subroutine snksrc & integer, intent(in) :: nsoil, k real (kind=kind_phys), intent(in) :: tavg, smc, smcmax, psisat, & - & bexp, dt, qtot, zsoil(nsoil) + & bexp, dt, qtot, zsoil(nsoil), shdfac ! --- input/outputs: real (kind=kind_phys), intent(inout) :: sh2o @@ -4819,9 +4845,13 @@ subroutine snksrc & ! real (kind=kind_phys) :: frh2o !urban - if (ivegsrc == 1)then - if ( vegtyp == 13 ) df1=3.24 - endif +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1=3.24 +! endif +!wz only urban for igbp type + if(ivegsrc == 1 .and. vegtyp == 13) then + df1 = 3.24*(1.-shdfac) + shdfac*df1 + endif ! !===> ... begin here ! diff --git a/physics/ugwp_driver_v0.f b/physics/ugwp_driver_v0.F similarity index 74% rename from physics/ugwp_driver_v0.f rename to physics/ugwp_driver_v0.F index a3ca5f96d..52375dd18 100644 --- a/physics/ugwp_driver_v0.f +++ b/physics/ugwp_driver_v0.F @@ -11,65 +11,76 @@ module sso_coorde end module sso_coorde ! ! +! Routine cires_ugwp_driver_v0 is replaced with cires_ugwp.F90/cires_ugwp_run in CCPP +#if 0 subroutine cires_ugwp_driver_v0(me, master, - & im, levs, nmtvr, dtp, kdt, imx,do_tofd, + & im, levs, nmtvr, dtp, kdt, imx, do_ugwp, do_tofd, & cdmbgwd, xlat, xlatd, sinlat, coslat, spgrid, & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, - & phii, phil, del, oro_stat, sgh30, kpbl, + & phii, phil, del, hprime, oc, oa4, clx, theta, + & gamm, sigma, elvmax, sgh30, kpbl, & dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_tofd, tau_mtb, tau_ogw, tau_ngw, - & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb ) + & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb, + & rain, ntke, tke, lprnt, ipr) !----------------------------------------------------------- -! Part 1 "old-revised" gfs-gwdps_v0 +! Part 1 "old-revised" gfs-gwdps_v0 or "old" gwdps (if do_ugwp=.false.) ! Part 2 non-stationary multi-wave GWs FV3GFS-v0 ! Part 3 Dissipative version of UGWP-tendency application ! (similar to WAM-2017) !----------------------------------------------------------- - use machine, only: kind_phys -! use physcons, only: con_cp, con_fvirt, con_g, con_rd, -! & con_rv, con_rerth, con_pi + use machine, only : kind_phys + use physcons, only : con_cp, con_g, con_rd, con_rv - use ugwp_wmsdis_init, only : tamp_mpa + use ugwp_wmsdis_init, only : tamp_mpa, ilaunch use sso_coorde, only : pgwd, pgwd4 implicit none !input integer, intent(in) :: me, master - integer, intent(in) :: im, levs, nmtvr, kdt, imx + integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr - real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(2) - logical :: do_tofd + real(kind=kind_phys), intent(in) :: dtp, cdmbgwd(4) + logical :: do_ugwp, do_tofd, lprnt integer, intent(in) :: kpbl(im) real(kind=kind_phys), intent(in), dimension(im) :: xlat, xlatd &, sgh30, sinlat, coslat, spgrid ! spgrid = tile-area + &, rain real(kind=kind_phys), intent(in), dimension(im,levs) :: ugrs &, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, del - real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) +! real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) + real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc + &, theta, gamm, sigma, elvmax + real(kind=kind_phys), intent(in), dimension(im,4) :: oa4, clx + real(kind=kind_phys), intent(in) :: tke(im,levs) !out real(kind=kind_phys), dimension(im,levs) :: gw_dudt, gw_dvdt &, gw_dTdt, gw_kdis !-----locals + diagnostics output - real(kind=kind_phys), dimension(im,levs) :: Pdvdt, Pdudt + real(kind=kind_phys), dimension(im,levs) :: Pdvdt, Pdudt &, Pdtdt, Pkdis, ed_dudt, ed_dvdt, ed_dTdt - real(kind=kind_phys), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), dimension(im) :: dusfcg, dvsfcg + + real(kind=kind_phys), dimension(im) :: rdxzb, zmtb, + & zlwb, zogw, tau_mtb, tau_ogw, tau_tofd, tau_ngw, turb_fac + real(kind=kind_phys), dimension(im,levs) :: du3dt_mtb, du3dt_ogw + &, du3dt_tms + real(kind=kind_phys), dimension(im) :: tem - real(kind=kind_phys), dimension(im) :: rdxzb, zmtb, - & zlwb, zogw, tau_mtb, tau_ogw, tau_tofd, tau_ngw - real(kind=kind_phys), dimension(im,levs) :: du3dt_mtb, du3dt_ogw - &, du3dt_tms ! locals - integer :: i, j, k, ix + real(kind=kind_phys) :: rfac, tx1 + integer :: i, j, k, ix ! ! define hprime, oc, oa4, clx, theta, sigma, gamm, elvmax ! - real(kind=kind_phys), dimension(im) :: hprime, - & oc, theta, sigma, gamm, elvmax - real(kind=kind_phys), dimension(im, 4) :: clx, oa4 +! real(kind=kind_phys), dimension(im) :: hprime, +! & oc, theta, sigma, gamm, elvmax +! real(kind=kind_phys), dimension(im, 4) :: clx, oa4 ! ! switches that activate impact of OGWs and NGWs along with eddy diffusion ! @@ -80,87 +91,129 @@ subroutine cires_ugwp_driver_v0(me, master, ! if (me == master .and. kdt < 2) then print * - write(6,*) 'FV3GFS execute ugwp_driver_v0 nmtvr=', nmtvr + write(6,*) 'FV3GFS execute ugwp_driver_v0 ' +! write(6,*) 'FV3GFS execute ugwp_driver_v0 nmtvr=', nmtvr write(6,*) ' COORDE EXPER pogw = ' , pogw write(6,*) ' COORDE EXPER pgwd = ' , pgwd write(6,*) ' COORDE EXPER pgwd4 = ', pgwd4 print * endif - -! print *, ' NMTVR in driver ', nmtvr do i=1,im - hprime(i) = oro_stat(i,1) - oc(i) = oro_stat(i,2) - oa4(i,1) = oro_stat(i,3) - oa4(i,2) = oro_stat(i,4) - oa4(i,3) = oro_stat(i,5) - oa4(i,4) = oro_stat(i,6) - clx(i,1) = oro_stat(i,7) - clx(i,2) = oro_stat(i,8) - clx(i,3) = oro_stat(i,9) - clx(i,4) = oro_stat(i,10) - theta(i) = oro_stat(i,11) - gamm(i) = oro_stat(i,12) - sigma(i) = oro_stat(i,13) - elvmax(i) = oro_stat(i,14) - - zlwb(i) = 0. + zlwb(i) = 0. enddo ! ! 1) ORO stationary GWs -! -! pdvdt(:,:) = 0. ; pdudt(:,:) = 0. -! pkdis(:,:) = 0. ; pdtdt(:,:) = 0. -! zlwb(:) = 0. +! ------------------ - CALL GWDPS_V0(IM, levs, imx, do_tofd, - & Pdvdt, Pdudt, Pdtdt, Pkdis, - & ugrs, vgrs, tgrs, qgrs,KPBL, prsi,del,prsl, - & prslk, phii, phil, DTP,KDT, - & sgh30, HPRIME,OC,OA4, CLX, THETA,SIGMA,GAMM,ELVMAX, - & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, - & cdmbgwd, me, master, rdxzb, - & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, - & du3dt_mtb, du3dt_ogw, du3dt_tms) -! -! -! non-stationary GW-scheme with GMAO/MERRA GW-forcing + if (do_ugwp .and. nmtvr == 14) then ! calling revised old GFS gravity wave drag + CALL GWDPS_V0(IM, levs, imx, do_tofd, + & Pdvdt, Pdudt, Pdtdt, Pkdis, + & ugrs , vgrs, tgrs, qgrs,KPBL, prsi,del,prsl, + & prslk, phii, phil, DTP,KDT, + & sgh30, HPRIME, OC, OA4, CLX, THETA, + & SIGMA, GAMM, ELVMAX, + & DUSFCg, DVSFCg, xlatd, sinlat, coslat, spgrid, + & cdmbgwd(1:2), me, master, rdxzb, + & zmtb, zogw, tau_mtb, tau_ogw, tau_tofd, + & du3dt_mtb, du3dt_ogw, du3dt_tms) +! + if (me == master .and. kdt < 2) then + print * + write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' + print * + endif + else ! calling old GFS gravity wave drag as is + do k=1,levs + do i=1,im + pdvdt(i,k) = 0.0 + pdudt(i,k) = 0.0 + pdtdt(i,k) = 0.0 + pkdis(i,k) = 0.0 + enddo + enddo + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & + &, ugrs, vgrs, tgrs, qgrs & + &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& + &, hprime, oc, oa4, clx, theta, sigma, gamm & + &, elvmax, dusfcg, dvsfcg & + &, con_g, con_cp, con_rd, con_rv, imx & + &, nmtvr, cdmbgwd(1:2), me, lprnt, ipr, rdxzb) + endif + + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + endif ! - if (me == master .and. kdt < 2) then - print * - write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' - print * - endif + if (cdmbgwd(3) > 0.0) then +! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing +! ---------------------------------------------- !-------- ! GMAO GEOS-5/MERRA GW-forcing lat-dep !-------- - call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) + call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) -! call slat_geos5(im, xlatd, tau_ngw) +! call slat_geos5(im, xlatd, tau_ngw) ! -! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing + if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then + if (cdmbgwd(4) > 0.0) then + do i=1,im + turb_fac(i) = 0.0 + enddo + if (ntke > 0) then + do k=1,(levs+levs)/3 + do i=1,im + turb_fac(i) = turb_fac(i) + del(i,k) * tke(i,k) + tem(i) = tem(i) + del(i,k) + enddo + enddo + do i=1,im + turb_fac(i) = turb_fac(i) / tem(i) + enddo + endif + rfac = 86400000 / dtp + do i=1,im + tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) + tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) + enddo + endif + do i=1,im + tau_ngw(i) = tau_ngw(i) * cdmbgwd(3) + enddo + endif ! - call fv3_ugwp_solv2_v0(im, levs, dtp, - & tgrs, ugrs, vgrs, qgrs, prsl, prsi, phil, xlatd, - & sinlat, coslat, gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, - & tau_ngw, me, master, kdt ) - - if (me == master .and. kdt < 2) then - print * - write(6,*)'FV3GFS finished fv3_ugwp_v0 in ugwp_driver_v0 ' - write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' - print * + call fv3_ugwp_solv2_v0(im, levs, dtp, + & tgrs, ugrs, vgrs, qgrs, prsl, prsi, + & phil, xlatd, sinlat, coslat, + & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, + & tau_ngw, me, master, kdt) + + if (me == master .and. kdt < 2) then + print * + write(6,*)'FV3GFS finished fv3_ugwp_v0 in ugwp_driver_v0 ' + write(6,*) ' non-stationary GWs with GMAO/MERRA GW-forcing ' + print * + endif + do k=1,levs + do i=1,im + gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) + gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*Pkdis(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + gw_dtdt(i,k) = Pdtdt(i,k) + gw_dudt(i,k) = Pdudt(i,k) + gw_dvdt(i,k) = Pdvdt(i,k) + gw_kdis(i,k) = Pkdis(i,k) + enddo + enddo endif - do k=1,levs - do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*Pkdis(i,k) - enddo - enddo if (pogw == 0.0) then ! zmtb = 0.; zogw =0. tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 @@ -176,9 +229,13 @@ subroutine cires_ugwp_driver_v0(me, master, ! ! 3) application of "eddy"-diffusion to "smooth" UGWP-related tendencies !------------------------------------------------------------------------------ - ed_dudt(:,:) = 0.0 ; ed_dvdt(:,:) = 0.0 ; ed_dtdt(:,:) = 0.0 + do k=1,levs + do i=1,im + ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 + enddo + enddo - call edmix_ugwp_v0(im, levs, dtp, + call edmix_ugwp_v0(im, levs, dtp, & tgrs, ugrs, vgrs, qgrs, del, & prsl, prsi, phil, prslk, & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, @@ -193,14 +250,15 @@ subroutine cires_ugwp_driver_v0(me, master, enddo enddo - end subroutine cires_ugwp_driver_v0 + end subroutine cires_ugwp_driver_v0 +#endif ! !===================================================================== ! !ugwp-v0 subroutines: GWDPS_V0 and fv3_ugwp_solv2_v0 ! !===================================================================== - SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, + SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, & Pdvdt, Pdudt, Pdtdt, Pkdis, U1,V1,T1,Q1,KPBL, & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DTP,KDT, & sgh30, HPRIME,OC,OA4,CLX4,THETA,vSIGMA,vGAMMA,ELVMAXD, @@ -236,20 +294,21 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, !---------------------------------------- implicit none character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' - integer, intent(in) :: im, levs, imx, kdt + integer, intent(in) :: im, km, imx, kdt integer, intent(in) :: me, master logical, intent(in) :: do_tofd - real(kind=kind_phys), parameter :: sigfac =3, sigfacS = 0.5 + real(kind=kind_phys), parameter :: sigfac = 3, sigfacS = 0.5 real(kind=kind_phys) :: ztopH,zlowH,ph_blk, dz_blk integer, intent(in) :: KPBL(IM) ! Index for the PBL top layer! real(kind=kind_phys), intent(in) :: dtp ! time step real(kind=kind_phys), intent(in) :: cdmbgwd(2) - real(kind=kind_phys), intent(in), dimension(im,levs) :: + real(kind=kind_phys), intent(in), dimension(im,km) :: & u1, v1, t1, q1, & del, prsl, prslk, phil - real(kind=kind_phys), intent(in),dimension(im,levs+1):: prsi, phii - real(kind=kind_phys), intent(in) ::xlatd(im),sinlat(im),coslat(im) + real(kind=kind_phys), intent(in),dimension(im,km+1):: prsi, phii + real(kind=kind_phys), intent(in) :: xlatd(im),sinlat(im), + & coslat(im) real(kind=kind_phys), intent(in) :: sparea(im) real(kind=kind_phys), intent(in) :: OC(IM), OA4(im,4), CLX4(im,4) @@ -259,7 +318,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, real(kind=kind_phys) :: SIGMA(IM), GAMMA(IM) !output -phys-tend - real(kind=kind_phys),dimension(im,levs),intent(out) :: + real(kind=kind_phys),dimension(im,km),intent(out) :: & Pdvdt, Pdudt, Pkdis, Pdtdt ! output - diag-coorde &, dudt_mtb, dudt_ogw, dudt_tms @@ -267,18 +326,39 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, real(kind=kind_phys),dimension(im) :: RDXZB, zmtb, zogw &, tau_ogw, tau_mtb, tau_tofd &, dusfc, dvsfc +! +!--------------------------------------------------------------------- +! # of permissible sub-grid orography hills for "any" resolution < 25 +! correction for "elliptical" hills based on shilmin-area =sgrid/25 +! 4.*gamma*b_ell*b_ell >= shilmin +! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min +! gamma_min = 1/4*shilmin/sso_min/sso_min +!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 +! 192: cdmbgwd = 0.5, 2.5 +! cleff = 2.5*0.5e-5 * sqrt(192./768.) => Lh_eff = 1004. km +! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective +!--------------------------------------------------------------------- + real(kind=kind_phys) :: gammin = 0.00999999 + real(kind=kind_phys), parameter :: nhilmax = 25. + real(kind=kind_phys), parameter :: sso_min = 3000. + logical, parameter :: do_adjoro = .true. +! + real(kind=kind_phys) :: shilmin, sgrmax, sgrmin + real(kind=kind_phys) :: belpmin, dsmin, dsmax +! real(kind=kind_phys) :: arhills(im) ! not used why do we need? + real(kind=kind_phys) :: xlingfs ! ! locals ! mean flow - real(kind=kind_phys) :: RI_N(IM,levs), BNV2(IM,levs), RO(IM,levs) - real(kind=kind_phys) :: VTK(IM,levs),VTJ(IM,levs),VELCO(IM,levs) + real(kind=kind_phys), dimension(im,km) :: RI_N, BNV2, RO + &, VTK, VTJ, VELCO !mtb - real(kind=kind_phys) :: OA(IM), CLX(IM) , elvmax(im) - real(kind=kind_phys) :: wk(IM) - real(kind=kind_phys), dimension(im) :: PE, EK, UP + real(kind=kind_phys), dimension(im) :: OA, CLX , elvmax, wk + &, PE, EK, UP - real(kind=kind_phys) :: DB(IM,levs),ANG(IM,levs),UDS(IM, levs) + real(kind=kind_phys), dimension(im,km) :: DB, ANG, UDS + real(kind=kind_phys) :: ZLEN, DBTMP, R, PHIANG, DBIM, ZR real(kind=kind_phys) :: ENG0, ENG1, COSANG2, SINANG2 real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem @@ -287,83 +367,61 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! Some constants now in "use ugwp_oro_init" + "use ugwp_common" ! !================== - real(kind=kind_phys) :: unew, vnew, zpbl, sigflt - real(kind=kind_phys), dimension(levs) :: utofd1, vtofd1 - &, epstofd1, krf_tofd1 - &, up1, vp1, zpm - real(kind=kind_phys) :: zsurf - real(kind=kind_phys),dimension(im, levs) :: axtms, aytms + real(kind=kind_phys) :: unew, vnew, zpbl, sigflt, zsurf + real(kind=kind_phys), dimension(km) :: utofd1, vtofd1 + &, epstofd1, krf_tofd1 + &, up1, vp1, zpm + real(kind=kind_phys),dimension(im, km) :: axtms, aytms ! ! OGW ! LOGICAL ICRILV(IM) ! - real(kind=kind_phys) :: XN(IM), YN(IM), UBAR(IM), - & VBAR(IM), ULOW(IM), - & ROLL(IM), bnv2bar(im), SCOR(IM), - & DTFAC(IM), XLINV(IM), DELKS(IM), DELKS1(IM) + real(kind=kind_phys), dimension(im) :: XN, YN, UBAR, VBAR, ULOW, + & ROLL, bnv2bar, SCOR, DTFAC, XLINV, DELKS, DELKS1 ! - real(kind=kind_phys) :: TAUP(IM,levs+1), TAUD(IM,levs) + real(kind=kind_phys) :: TAUP(IM,km+1), TAUD(IM,km) real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis - integer :: kref(IM), idxzb(im), ipt(im), k_mtb,k_zlow - integer :: kreflm(IM), iwklm(im), iwk(im), izlow(im) - integer :: ktrial, klevm1 + integer, dimension(im) :: kref, idxzb, ipt, kreflm, + & iwklm, iwk, izlow ! !check what we need ! - real(kind=kind_phys) :: bnv, fr, ri_gw , - & brvf, tem, tem1, tem2, temc, temv, - & ti, rdz, dw2, shr2, bvf2, - & rdelks, efact, coefm, gfobnv, - & scork, rscor, hd, fro, sira, - & dtaux, dtauy, pkp1log, pklog - - integer :: km, kmm1, kmm2, lcap, lcapp1 - &, npt, kbps, kbpsp1,kbpsm1 - &, kmps, idir, nwd, klcap, kp1, kmpbl, kmll -!--------------------------------------------------------------------- -! # of permissible sub-grid orography hills for "any" resolution < 25 -! correction for "elliptical" hills based on shilmin-area =sgrid/25 -! 4.*gamma*b_ell*b_ell >= shilmin -! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min -! gamma_min = 1/4*shilmin/sso_min/sso_min -!23.01.2019: cdmb = 4.*192/768_c192=1 x 0.5 -! 192: cdmbgwd = 0.5, 2.5 -! cleff = 2.5*0.5e-5 * sqrt(192./768.) => Lh_eff = 1004. km -! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective -!--------------------------------------------------------------------- - real(kind=kind_phys) :: gammin = 0.00999999 - real(kind=kind_phys) :: shilmin, sgrmax, sgrmin - real(kind=kind_phys) :: belpmin, dsmin, dsmax - real(kind=kind_phys), parameter :: nhilmax = 25. - real(kind=kind_phys), parameter :: sso_min = 3000. - real(kind=kind_phys) :: xlingfs - real(kind=kind_phys) :: arhills(im) - logical, parameter :: do_adjoro = .true. -! - integer :: i, j, k - real(kind=kind_phys) :: grav2, rcpdt, windik, wdir + real(kind=kind_phys) :: bnv, fr, ri_gw + &, brvf, tem, tem1, tem2, temc, temv + &, ti, rdz, dw2, shr2, bvf2 + &, rdelks, efact, coefm, gfobnv + &, scork, rscor, hd, fro, sira + &, dtaux, dtauy, pkp1log, pklog + &, grav2, rcpdt, windik, wdir &, sigmin, dxres,sigres,hdxres &, cdmb4, mtbridge &, kxridge, inv_b2eff, zw1, zw2 &, belps, aelps, nhills, selps -! + + integer :: kmm1, kmm2, lcap, lcapp1 + &, npt, kbps, kbpsp1,kbpsm1 + &, kmps, idir, nwd, klcap, kp1, kmpbl, kmll + &, k_mtb, k_zlow, ktrial, klevm1, i, j, k +! rcpdt = 1.0 / (cpd*dtp) grav2 = grav + grav ! ! mtb-blocking sigma_min and dxres => cires_initialize ! sgrmax = maxval(sparea) ; sgrmin = minval(sparea) - dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) + dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) dxres = pi2*arad/float(IMX) hdxres = 0.5*dxres - shilmin = sgrmin/nhilmax +! shilmin = sgrmin/nhilmax ! not used - Moorthi - gammin = min(sso_min/dsmax, 1.) +! gammin = min(sso_min/dsmax, 1.) ! Moorthi - with this results are not reproducible + gammin = min(sso_min/dxres, 1.) ! Moorthi - sigmin = 2.*hpmin/dsmax !dxres +! sigmin = 2.*hpmin/dsmax !dxres ! Moorthi - this will not reproduce + sigmin = 2.*hpmin/dxres !dxres ! if (kdt == 1) then ! print *, sgrmax, sgrmin , ' min-max sparea ' @@ -371,10 +429,10 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! print *, 'dxres/dsmax ', dxres, dsmax ! print *, ' shilmin gammin ', shilmin, gammin ! endif - + kxridge = float(IMX)/arad * cdmbgwd(2) - - if (me == master .and. kdt==1) then + + if (me == master .and. kdt == 1) then print *, ' gwdps_v0 kxridge ', kxridge print *, ' gwdps_v0 scale2 ', cdmbgwd(2) print *, ' gwdps_v0 IMX ', imx @@ -383,7 +441,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, endif do i=1,im - idxzb(:) = 0 + idxzb(i) = 0 zmtb(i) = 0.0 zogw(i) = 0.0 rdxzb(i) = 0.0 @@ -392,9 +450,13 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, dusfc(i) = 0.0 dvsfc(i) = 0.0 tau_tofd(i) = 0.0 +! + ipt(i) = 0 + sigma(i) = max(vsigma(i), sigmin) + gamma(i) = max(vgamma(i), gammin) enddo - - do k=1,levs + + do k=1,km do i=1,im pdvdt(i,k) = 0.0 pdudt(i,k) = 0.0 @@ -408,56 +470,48 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! ---- for lm and gwd calculation points - ipt(:) = 0 npt = 0 - sigma = vsigma - gamma = vgamma do i = 1,im - if ( (elvmaxd(i) >= hminmt) - & .and. (gamma(i) >= gammin) - & .and. (hprime(i) >= hpmin) ) then + if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then - npt = npt + 1 - ipt(npt) = i - arhills(i) = 1.0 -! - if (gamma(i) < gammin) gamma(i) = gammin - sigres = max(sigmin, sigma(i)) - if (sigma(i) < sigmin) sigma(i)= sigmin - dxres = sqrt(sparea(i)) - if (2.*hprime(i)/sigres > dxres) sigres=2.*hprime(i)/dxres - aelps = min(2.*hprime(i)/sigres, 0.5*dxres) - if (gamma(i) > 0.0 ) belps=min(aelps/gamma(i),.5*dxres) + npt = npt + 1 + ipt(npt) = i +! arhills(i) = 1.0 +! + sigres = max(sigmin, sigma(i)) +! if (sigma(i) < sigmin) sigma(i)= sigmin + dxres = sqrt(sparea(i)) + if (2.*hprime(i)/sigres > dxres) sigres=2.*hprime(i)/dxres + aelps = min(2.*hprime(i)/sigres, 0.5*dxres) + if (gamma(i) > 0.0 ) belps = min(aelps/gamma(i),.5*dxres) ! ! small-scale "turbulent" oro-scales < sso_min ! - if( aelps < sso_min .and. do_adjoro) then + if( aelps < sso_min .and. do_adjoro) then ! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm ! - aelps = sso_min - if (belps < sso_min ) then - gamma(i) = 1.0 - belps = aelps*gamma(i) - - else - gamma(i) = min(aelps/belps, 1.0) - endif - sigma(i) = 2.*hprime(i)/aelps - gamma(i) = min(aelps/belps, 1.0) - endif + aelps = sso_min + if (belps < sso_min ) then + gamma(i) = 1.0 + belps = aelps*gamma(i) + else + gamma(i) = min(aelps/belps, 1.0) + endif + sigma(i) = 2.*hprime(i)/aelps + gamma(i) = min(aelps/belps, 1.0) + endif - selps = belps*belps*gamma(i)*4. ! ellipse area of the el-c hill - nhills = sparea(i)/selps - if (nhills > nhilmax) nhills = nhilmax - arhills(i) = max(nhills, 1.0) + selps = belps*belps*gamma(i)*4. ! ellipse area of the el-c hill + nhills = min(nhilmax, sparea(i)/selps) +! arhills(i) = max(nhills, 1.0) !333 format( ' nhil: ', I6, 4(2x, F9.3), 2(2x, E9.3)) ! if (kdt==1 ) ! & write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, ! & belps*1.e-3, sigma(i),gamma(i) - endif + endif enddo IF (npt == 0) then @@ -473,7 +527,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, kreflm(i) = 0 enddo - do k=1,levs + do k=1,km do i=1,im db(i,k) = 0.0 ang(i,k) = 0.0 @@ -481,17 +535,16 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, enddo enddo - km = levs - KMM1 = levs- 1 ; KMM2 = levs - 2 ; KMLL = kmm1 - LCAP = levs ; LCAPP1 = LCAP + 1 - + KMM1 = km - 1 ; KMM2 = km - 2 ; KMLL = kmm1 + LCAP = km ; LCAPP1 = LCAP + 1 + DO I = 1, npt j = ipt(i) ELVMAX(J) = min (ELVMAXd(J)*0. + sigfac * hprime(j), hncrit) + izlow(i) = 1 ! surface-level ENDDO ! - izlow(:) =1 ! surface-level - DO K = 1, levs-1 + DO K = 1, kmm1 DO I = 1, npt j = ipt(i) ztopH = sigfac * hprime(j) @@ -508,7 +561,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ENDDO ENDDO ! - DO K = 1,levs + DO K = 1,km DO I =1,npt J = ipt(i) VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) @@ -520,7 +573,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! ! check RI_N or RI_MF computation ! - DO K = 1,levs-1 + DO K = 1,kmm1 DO I =1,npt J = ipt(i) RDZ = grav / (phil(j,k+1) - phil(j,k)) @@ -541,153 +594,154 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! ENDDO ENDDO - K = 1 - DO I = 1, npt - bnv2(i,k) = bnv2(i,k+1) - ENDDO + K = 1 + DO I = 1, npt + bnv2(i,k) = bnv2(i,k+1) + ENDDO ! ! level iwklm =>phil(j,k)/g < sigfac * hprime(j) < phil(j,k+1)/g ! - DO I = 1, npt - J = ipt(i) - k_zlow = izlow(I) - if (k_zlow == iwklm(i)) k_zlow = 1 - DELKS(I) = 1.0 / (PRSI(J,k_zlow) - PRSI(J,iwklm(i))) -! DELKS1(I) = 1.0 /(PRSL(J,k_zlow) - PRSL(J,iwklm(i))) - UBAR (I) = 0.0 - VBAR (I) = 0.0 - ROLL (I) = 0.0 - PE (I) = 0.0 - EK (I) = 0.0 - BNV2bar(I) = 0.0 - ENDDO + DO I = 1, npt + J = ipt(i) + k_zlow = izlow(I) + if (k_zlow == iwklm(i)) k_zlow = 1 + DELKS(I) = 1.0 / (PRSI(J,k_zlow) - PRSI(J,iwklm(i))) +! DELKS1(I) = 1.0 /(PRSL(J,k_zlow) - PRSL(J,iwklm(i))) + UBAR (I) = 0.0 + VBAR (I) = 0.0 + ROLL (I) = 0.0 + PE (I) = 0.0 + EK (I) = 0.0 + BNV2bar(I) = 0.0 + ENDDO ! - DO I = 1, npt - k_zlow = izlow(I) - if (k_zlow == iwklm(i)) k_zlow = 1 - DO K = k_zlow, iwklm(I)-1 ! Kreflm(I)= iwklm(I)-1 - J = ipt(i) ! laye-aver Rho, U, V - RDELKS = DEL(J,K) * DELKS(I) - UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below - VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below - ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below -! - BNV2bar(I) = BNV2bar(I) + .5*(BNV2(I,K)+BNV2(I,K+1))* RDELKS - ENDDO + DO I = 1, npt + k_zlow = izlow(I) + if (k_zlow == iwklm(i)) k_zlow = 1 + DO K = k_zlow, iwklm(I)-1 ! Kreflm(I)= iwklm(I)-1 + J = ipt(i) ! laye-aver Rho, U, V + RDELKS = DEL(J,K) * DELKS(I) + UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below + VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below + ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below +! + BNV2bar(I) = BNV2bar(I) + .5*(BNV2(I,K)+BNV2(I,K+1))* RDELKS ENDDO + ENDDO ! - DO I = 1, npt - J = ipt(i) + DO I = 1, npt + J = ipt(i) ! ! integrate from Ztoph = sigfac*hprime down to Zblk if exists ! find ph_blk, dz_blk like in LM-97 and IFS ! - ph_blk =0. - DO K = iwklm(I), 1, -1 - PHIANG = atan2(V1(J,K),U1(J,K))*RAD_TO_DEG - ANG(I,K) = ( THETA(J) - PHIANG ) - if ( ANG(I,K) > 90. ) ANG(I,K) = ANG(I,K) - 180. - if ( ANG(I,K) < -90. ) ANG(I,K) = ANG(I,K) + 180. - ANG(I,K) = ANG(I,K) * DEG_TO_RAD - UDS(I,K) = - & MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), velmin) -! - IF (IDXZB(I) == 0 ) then - dz_blk=( PHII(J,K+1) - PHII(J,K) ) *rgrav - PE(I) = PE(I) + BNV2(I,K) * - & ( ELVMAX(J) - phil(J,K)*rgrav ) * dz_blk - - UP(I) = max(UDS(I,K) * cos(ANG(I,K)), velmin) - EK(I) = 0.5 * UP(I) * UP(I) - - ph_blk = ph_blk + dz_blk*sqrt(BNV2(I,K))/UP(I) + ph_blk =0. + DO K = iwklm(I), 1, -1 + PHIANG = atan2(V1(J,K),U1(J,K))*RAD_TO_DEG + ANG(I,K) = ( THETA(J) - PHIANG ) + if ( ANG(I,K) > 90. ) ANG(I,K) = ANG(I,K) - 180. + if ( ANG(I,K) < -90. ) ANG(I,K) = ANG(I,K) + 180. + ANG(I,K) = ANG(I,K) * DEG_TO_RAD + UDS(I,K) = + & MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), velmin) +! + IF (IDXZB(I) == 0 ) then + dz_blk = ( PHII(J,K+1) - PHII(J,K) ) *rgrav + PE(I) = PE(I) + BNV2(I,K) * + & ( ELVMAX(J) - phil(J,K)*rgrav ) * dz_blk + + UP(I) = max(UDS(I,K) * cos(ANG(I,K)), velmin) + EK(I) = 0.5 * UP(I) * UP(I) + + ph_blk = ph_blk + dz_blk*sqrt(BNV2(I,K))/UP(I) ! --- Dividing Stream lime is found when PE =exceeds EK. oper-l GFS -! IF ( PE(I) >= EK(I) ) THEN - IF ( ph_blk >= fcrit_gfs ) THEN - IDXZB(I) = K - zmtb (J) = PHIL(J, K)*rgrav - RDXZB(J) = real(k, kind=kind_phys) - ENDIF - +! IF ( PE(I) >= EK(I) ) THEN + IF ( ph_blk >= fcrit_gfs ) THEN + IDXZB(I) = K + zmtb (J) = PHIL(J, K)*rgrav + RDXZB(J) = real(k, kind=kind_phys) ENDIF - ENDDO + + ENDIF + ENDDO ! ! Alternative expression: ZMTB = max(Heff*(1. -Fcrit_gfs/Fr), 0) ! fcrit_gfs/fr ! - goto 788 - - BNV = SQRT( BNV2bar(I) ) - heff = 2.*min(HPRIME(J),hpmax) - zw2 = UBAR(I)*UBAR(I)+VBAR(I)*VBAR(I) - Ulow(i) = sqrt(max(zw2,dw2min)) - Fr = heff*bnv/Ulow(i) - ZW1 = max(Heff*(1. -fcrit_gfs/fr), 0.0) - zw2 = phil(j,2)*rgrav - if (Fr > fcrit_gfs .and. zw1 > zw2 ) then - do k=2, levs-1 + goto 788 + + BNV = SQRT( BNV2bar(I) ) + heff = 2.*min(HPRIME(J),hpmax) + zw2 = UBAR(I)*UBAR(I)+VBAR(I)*VBAR(I) + Ulow(i) = sqrt(max(zw2,dw2min)) + Fr = heff*bnv/Ulow(i) + ZW1 = max(Heff*(1. -fcrit_gfs/fr), 0.0) + zw2 = phil(j,2)*rgrav + if (Fr > fcrit_gfs .and. zw1 > zw2 ) then + do k=2, kmm1 pkp1log = phil(j,k+1) * rgrav pklog = phil(j,k) * rgrav - if (zw1 <= pkp1log .and. zw1 >= pklog) exit - enddo + if (zw1 <= pkp1log .and. zw1 >= pklog) exit + enddo IDXZB(I) = K zmtb (J) = PHIL(J, K)*rgrav - else - zmtb (J) = 0. - IDXZB(I) = 0 - endif + else + zmtb (J) = 0. + IDXZB(I) = 0 + endif 788 continue - ENDDO + ENDDO ! ! --- The drag for mtn blocked flow ! - cdmb4 = 0.25*cdmb - DO I = 1, npt - J = ipt(i) + cdmb4 = 0.25*cdmb + DO I = 1, npt + J = ipt(i) ! - IF ( IDXZB(I) > 0 ) then + IF ( IDXZB(I) > 0 ) then ! (4.16)-IFS - gam2 = gamma(j)*gamma(j) - BGAM = 1.0 - 0.18*gamma(j) - 0.04*gam2 - CGAM = 0.48*gamma(j) + 0.30*gam2 - DO K = IDXZB(I)-1, 1, -1 + gam2 = gamma(j)*gamma(j) + BGAM = 1.0 - 0.18*gamma(j) - 0.04*gam2 + CGAM = 0.48*gamma(j) + 0.30*gam2 + DO K = IDXZB(I)-1, 1, -1 - ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / - & ( PHIL(J,K ) + Grav * hprime(J) ) ) + ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / + & ( PHIL(J,K ) + Grav * hprime(J) ) ) - COSANG2 = cos(ANG(I,K))*cos(ANG(I,K)) - SINANG2 = 1.0 - COSANG2 + tem = cos(ANG(I,K)) + COSANG2 = tem * tem + SINANG2 = 1.0 - COSANG2 ! ! cos =1 sin =0 => 1/R= gam ZR = 2.-gam ! cos =0 sin =1 => 1/R= 1/gam ZR = 2.- 1/gam ! - rdem = COSANG2 + GAM2 * SINANG2 - rnom = COSANG2*GAM2 + SINANG2 + rdem = COSANG2 + GAM2 * SINANG2 + rnom = COSANG2*GAM2 + SINANG2 ! ! metOffice Dec 2010 ! correction of H. Wells & A. Zadra for the ! aspect ratio of the hill seen by MF ! (1/R , R-inverse below: 2-R) - rdem = max(rdem, 1.e-6) - R = sqrt(rnom/rdem) - ZR = MAX( 2. - R, 0. ) + rdem = max(rdem, 1.e-6) + R = sqrt(rnom/rdem) + ZR = MAX( 2. - R, 0. ) - sigres = max(sigmin, sigma(J)) - if (hprime(J)/sigres > dxres) sigres = hprime(J)/dxres - mtbridge = ZR * sigres*ZLEN / hprime(J) + sigres = max(sigmin, sigma(J)) + if (hprime(J)/sigres > dxres) sigres = hprime(J)/dxres + mtbridge = ZR * sigres*ZLEN / hprime(J) ! (4.15)-IFS -! DBTMP = CDmb4 * mtbridge * -! & MAX(cos(ANG(I,K)), gamma(J)*sin(ANG(I,K))) +! DBTMP = CDmb4 * mtbridge * +! & MAX(cos(ANG(I,K)), gamma(J)*sin(ANG(I,K))) ! (4.16)-IFS - DBTMP = CDmb4*mtbridge*(bgam* COSANG2 +cgam* SINANG2) - DB(I,K)= DBTMP * UDS(I,K) - ENDDO + DBTMP = CDmb4*mtbridge*(bgam* COSANG2 +cgam* SINANG2) + DB(I,K)= DBTMP * UDS(I,K) + ENDDO ! - endif - ENDDO + endif + ENDDO ! !............................. !............................. @@ -724,15 +778,15 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! LEVEL ~0.4-0.5 KM from surface or/and PBL-top ! in UGWP-V1: options to modify as Htop ~ (2-3)*Hprime > Zmtb ! in UGWP-V0 we ensured that : Zogw > Zmtb -! +! KBPS = 1 - KMPS = levs - K_mtb = 1 + KMPS = km + K_mtb = 1 DO I=1,npt J = ipt(i) K_mtb = max(1, idxzb(i)) - + kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level PBL or smt-else ???? kref(I) = MAX(kref(i), iwklm(i) ) ! iwklm => sigfac*hprime @@ -746,11 +800,11 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ROLL (I) = 0.0 BNV2bar(I)= 0.0 ENDDO -! +! KBPSP1 = KBPS + 1 KBPSM1 = KBPS - 1 - K_mtb = 1 -! + K_mtb = 1 +! DO I = 1,npt K_mtb = max(1, idxzb(i)) DO K = k_mtb,KBPS !KBPS = MAX(kref) ;KMPS= MIN(kref) @@ -765,7 +819,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ENDDO ENDDO ! -! orographic asymmetry parameter (OA), and (CLX) +! orographic asymmetry parameter (OA), and (CLX) DO I = 1,npt J = ipt(i) wdir = atan2(UBAR(I),VBAR(I)) + pi @@ -777,13 +831,13 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! DO I = 1,npt DTFAC(I) = 1.0 - ICRILV(I) = .FALSE. ! INITIALIZE CRITICAL LEVEL CONTROL VECTOR + ICRILV(I) = .FALSE. ! INITIALIZE CRITICAL LEVEL CONTROL VECTOR ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I)+VBAR(I)*VBAR(I)),velmin) XN(I) = UBAR(I) / ULOW(I) - YN(I) = VBAR(I) / ULOW(I) + YN(I) = VBAR(I) / ULOW(I) ENDDO ! - DO K = 1, levs-1 + DO K = 1, kmm1 DO I = 1,npt J = ipt(i) VELCO(I,K) = 0.5 * ((U1(J,K)+U1(J,K+1))*XN(I) @@ -935,7 +989,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! ! zero momentum deposition at the top model layer ! - taup(1:npt,levs+1) = taup(1:npt,levs) + taup(1:npt,km+1) = taup(1:npt,km) ! ! Calculate wave acc-n: - (grav)*d(tau)/d(p) = taud ! @@ -948,7 +1002,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, !------scale MOMENTUM DEPOSITION AT TOP TO 1/2 VALUE ! it is zero now ! DO I = 1,npt -! TAUD(I, levs) = TAUD(I,levs) * FACTOP +! TAUD(I, km) = TAUD(I,km) * FACTOP ! ENDDO !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -985,7 +1039,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, ! XLINV(I) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./Lridge dtfac(:) = 1.0 - call oro_wam_2017(im, levs, npt, ipt, kref, kdt, me, master, + call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, & del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) @@ -1009,16 +1063,16 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of LS-SSO zsurf = phii(j,1)*rgrav - do k=1,levs + do k=1,km zpm(k) = phiL(j,k)*rgrav up1(k) = u1(j,k) vp1(k) = v1(j,k) enddo - call ugwp_tofd1d(levs, sigflt, elvmaxd(j), zsurf, zpbl, + call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) - do k=1,levs + do k=1,km axtms(j,k) = utofd1(k) aytms(j,k) = vtofd1(k) ! @@ -1028,7 +1082,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, pdudt(J,k) = pdudt(J,k) + axtms(j,k) enddo !2018-diag - tau_tofd(J) = sum( utofd1(1:levs)* del(j,1:levs)) + tau_tofd(J) = sum( utofd1(1:km)* del(j,1:km)) enddo ENDIF ! do_tofd @@ -1098,11 +1152,11 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, tau_ogw(j) = -rgrav * tau_ogw(j) tau_tofd(J) = -rgrav * tau_tofd(j) ENDDO - + RETURN -!============ debug ------------------------------------------------ +!============ debug ------------------------------------------------ if (kdt <= 2 .and. me == 0) then print *, 'vgw-oro done gwdps_v0 in ugwp-v0 step-proc ', kdt, me ! @@ -1128,7 +1182,7 @@ SUBROUTINE GWDPS_V0(IM, levs, imx, do_tofd, print *, maxval(prsL), minval(prsL), ' prsL ' print *, maxval(RO), minval(RO), ' RO-dens ' print *, maxval(bnv2(1:npt,:)), minval(bnv2(1:npt,:)),' BNV2 ' - print *, maxval(kpbl), minval(kpbl), ' kpbl ' + print *, maxval(kpbl), minval(kpbl), ' kpbl ' print *, maxval(sgh30), maxval(hprime), maxval(elvmax),'oro-d' print * do i =1, npt @@ -1185,9 +1239,9 @@ end subroutine gwdps_v0 ! (c) guidance from high-res runs for GW sources and res-aware tune-ups !23456 ! -! call gwdrag_wam(1, im, ix, levs, ksrc, dtp, +! call gwdrag_wam(1, im, ix, km, ksrc, dtp, ! & xlat, gw_dudt, gw_dvdt, taux, tauy) -! call fv3_ugwp_wms17(kid1, im, ix, levs, ksrc_ifs, dtp, +! call fv3_ugwp_wms17(kid1, im, ix, km, ksrc_ifs, dtp, ! & adt,adu,adv,prsl,prsi,phil,xlat, gw_dudt, gw_dvdt, gw_dtdt, gw_ked, ! & taux,tauy,grav, amol_i, me, lstep_first ) ! @@ -1196,9 +1250,10 @@ end subroutine gwdps_v0 subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, - & tm1 , um1, vm1, qm1, - & prsl, prsi, philg, xlatd, sinlat, coslat, - & pdudt, pdvdt, pdtdt, dked, tau_ngw, mpi_id, master, kdt) + & tm1 , um1, vm1, qm1, + & prsl, prsi, philg, xlatd, sinlat, coslat, + & pdudt, pdvdt, pdtdt, dked, tau_ngw, + & mpi_id, master, kdt) ! @@ -1218,7 +1273,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, use ugwp_wmsdis_init, only : hpscale, rhp2, bv2min, gssec &, v_kxw, v_kxw2, tamp_mpa, zfluxglob &, maxdudt, gw_eff, dked_min - &, nslope, ilaunch, zms + &, nslope, ilaunch, zmsi &, zci, zdci, zci4, zci3, zci2 &, zaz_fct, zcosang, zsinang &, nwav, nazd, zcimin, zcimax @@ -1226,33 +1281,34 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, implicit none !23456 - integer, intent(in) :: klev ! vertical level - integer, intent(in) :: klon ! horiz tiles - - real ,intent(in) :: dtime ! model time step - real ,intent(in) :: vm1(klon,klev) ! meridional wind - real ,intent(in) :: um1(klon,klev) ! zonal wind - real ,intent(in) :: qm1(klon,klev) ! spec. humidity - real ,intent(in) :: tm1(klon,klev) ! kin temperature - - real ,intent(in) :: prsl(klon,klev) ! mid-layer pressure - real ,intent(in) :: philg(klon,klev) ! m2/s2-phil => meters !!!!! phil =philg/grav - real ,intent(in) :: prsi(klon,klev+1) ! prsi interface pressure - real ,intent(in) :: xlatd(klon) ! lat was in radians, now with xlat_d in degrees - real ,intent(in) :: sinlat(klon) - real ,intent(in) :: coslat(klon) - real ,intent(in) :: tau_ngw(klon) - - integer, intent(in):: mpi_id, master, kdt + integer, intent(in) :: klev ! vertical level + integer, intent(in) :: klon ! horiz tiles + + real, intent(in) :: dtime ! model time step + real, intent(in) :: vm1(klon,klev) ! meridional wind + real, intent(in) :: um1(klon,klev) ! zonal wind + real, intent(in) :: qm1(klon,klev) ! spec. humidity + real, intent(in) :: tm1(klon,klev) ! kin temperature + + real, intent(in) :: prsl(klon,klev) ! mid-layer pressure + real, intent(in) :: philg(klon,klev) ! m2/s2-phil => meters !!!!! phil =philg/grav + real, intent(in) :: prsi(klon,klev+1)! prsi interface pressure + real, intent(in) :: xlatd(klon) ! lat was in radians, now with xlat_d in degrees + real, intent(in) :: sinlat(klon) + real, intent(in) :: coslat(klon) + real, intent(in) :: tau_ngw(klon) + + integer, intent(in) :: mpi_id, master, kdt ! ! ! out-gw effects ! - real ,intent(out) :: pdudt(klon,klev) ! zonal momentum tendency - real ,intent(out) :: pdvdt(klon,klev) ! meridional momentum tendency - real ,intent(out) :: pdtdt(klon,klev) ! gw-heating (u*ax+v*ay)/cp - real ,intent(out) :: dked(klon,klev) ! gw-eddy diffusion + real, intent(out) :: pdudt(klon,klev) ! zonal momentum tendency + real, intent(out) :: pdvdt(klon,klev) ! meridional momentum tendency + real, intent(out) :: pdtdt(klon,klev) ! gw-heating (u*ax+v*ay)/cp + real, intent(out) :: dked(klon,klev) ! gw-eddy diffusion real, parameter :: minvel = 0.5 ! + real, parameter :: epsln = 1.0d-12 ! !vay-2018 @@ -1278,12 +1334,12 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, !23456 real :: zul(klon,nazd) ! velocity in azimuthal direction at launch level real :: zci_min(klon,nazd) - real :: zcrt(klon,klev,nazd) +! real :: zcrt(klon,klev,nazd) ! not used - do we need it? Moorthi real :: zact(klon, nwav, nazd) ! if =1 then critical level encountered => c-u - real :: zacc(klon, nwav, nazd) +! real :: zacc(klon, nwav, nazd) ! not used! ! real :: zpu(klon,klev, nazd) ! momentum flux - real :: zdfl(klon,klev, nazd) +! real :: zdfl(klon,klev, nazd) real :: zfct(klon,klev) real :: zfnorm(klon) ! normalisation factor @@ -1298,7 +1354,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, real :: vm_zflx_mode, vc_zflx_mode real :: kzw2, kzw3, kdsat, cdf2, cdf1, wdop2 - real :: zang, znorm, zang1, ztx +! real :: zang, znorm, zang1, ztx real :: zu, zcin, zcpeak, zcin4, zbvfl4 real :: zcin2, zbvfl2, zcin3, zbvfl3, zcinc real :: zatmp, zfluxs, zdep, zfluxsq, zulm, zdft, ze1, ze2 @@ -1306,15 +1362,18 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! real :: zdelp,zrgpts real :: zthstd,zrhostd,zbvfstd - real :: tvc1, tvm1 + real :: tvc1, tvm1, tem1, tem2, tem3 real :: zhook_handle + real :: delpi(klon,ilaunch:klev) ! real :: rcpd, grav2cpd real, parameter :: rcpdl = cpd/grav ! 1/[g/cp] == cp/g &, grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp + &, cpdi = 1.0d0/cpd - real :: fmode, expdis, fdis + real :: expdis, fdis +! real :: fmode, expdis, fdis real :: v_kzi, v_kzw, v_cdp, v_wdp, sc, tx1 integer :: j, k, inc, jk, jl, iazi @@ -1355,8 +1414,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, do jk=1,klev do jl=1,klon zpu(jl,jk,iazi) = 0.0 - zcrt(jl,jk,iazi) = 0.0 - zdfl(jl,jk,iazi) = 0.0 +! zcrt(jl,jk,iazi) = 0.0 +! zdfl(jl,jk,iazi) = 0.0 enddo enddo enddo @@ -1381,7 +1440,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) zdelp = phil(jl,jk)-phil(jl,jk-1) !>0 ...... dz-meters - v_zmet(jl,jk) = 2.*zdelp + v_zmet(jl,jk) = zdelp + zdelp + delpi(jl,jk) = grav / (prsi(jl,jk-1) - prsi(jl,jk)) vueff(jl,jk) = & 2.e-5*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min ! @@ -1406,9 +1466,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo endif do jl=1,klon - tx1 = OMEGA2 * SINLAT(JL) / V_KXW - C2F2(JL) = tx1 * tx1 - zbvfl(jl) = zbvfhm1(jl,ilaunch) + tx1 = OMEGA2 * SINLAT(JL) / V_KXW + C2F2(JL) = tx1 * tx1 + zbvfl(jl) = zbvfhm1(jl,ilaunch) enddo ! ! define intrinsic velocity (relative to launch level velocity) u(z)-u(zo), and coefficinets @@ -1461,9 +1521,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, zcin = zci(inc) zcin4 = zci4(inc) do jl=1,klon - zbvfl4 = zbvfl(jl)*zbvfl(jl) - zbvfl4 = zbvfl4 * zbvfl4 - zcpeak = zbvfl(jl)/zms + zbvfl4 = zbvfl(jl) * zbvfl(jl) + zbvfl4 = zbvfl4 * zbvfl4 + zcpeak = zbvfl(jl) * zmsi zflux(jl,inc,1) = zfct(jl,ilaunch)* & zbvfl4*zcin*zcpeak/(zbvfl4*zcpeak+zcin4*zcin) enddo @@ -1536,7 +1596,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! copy zflux into all other azimuths ! -------------------------------- - zact(:,:,:) = 1.0 ; zacc(:,:,:) = 1.0 +! zact(:,:,:) = 1.0 ; zacc(:,:,:) = 1.0 + zact(:,:,:) = 1.0 do iazi=2, nazd do inc=1,nwav do jl=1,klon @@ -1549,6 +1610,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! azimuth do-loop ! -------------------- do iazi=1, nazd + +! write(0,*)' iazi=',iazi,' ilaunch=',ilaunch ! vertical do-loop ! ---------------- do jk=ilaunch, klev-1 @@ -1560,44 +1623,52 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! set zact to zero if critical level encountered ! ---------------------------------------------- do inc=1, nwav - zcin = zci(inc) +! zcin = zci(inc) do jl=1,klon - zatmp = minvel + sign(minvel,zcin-zci_min(jl,iazi)) - zacc(jl,inc,iazi) = zact(jl,inc,iazi)-zatmp - zact(jl,inc,iazi) = zatmp +! zatmp = minvel + sign(minvel,zcin-zci_min(jl,iazi)) +! zacc(jl,inc,iazi) = zact(jl,inc,iazi)-zatmp +! zact(jl,inc,iazi) = zatmp + zact(jl,inc,iazi) = minvel + & + sign(minvel,zci(inc)-zci_min(jl,iazi)) enddo enddo ! +! zdfl not used! - do we need it? Moorthi ! integrate to get critical-level contribution to mom deposition ! --------------------------------------------------------------- - do inc=1, nwav - zcinc = zdci(inc) - do jl=1,klon - zdfl(jl,jk,iazi) = zdfl(jl,jk,iazi) + - & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zcinc - enddo - enddo +! do inc=1, nwav +! zcinc = zdci(inc) +! do jl=1,klon +! zdfl(jl,jk,iazi) = zdfl(jl,jk,iazi) + +! & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zcinc +! enddo +! enddo ! -------------------------------------------- -! get weighted average of phase speed in layer +! get weighted average of phase speed in layer zcrt is not used - do we need it? Moorthi ! -------------------------------------------- - do jl=1,klon - if(zdfl(jl,jk,iazi) > 0.0 ) then - zatmp = zcrt(jl,jk,iazi) - do inc=1, nwav - zatmp = zatmp + zci(inc) * - & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zdci(inc) - enddo -! - zcrt(jl,jk,iazi)=zatmp/zdfl(jl,jk,iazi) - else - zcrt(jl,jk,iazi)=zcrt(jl,jk-1,iazi) - endif - enddo +! do jl=1,klon +! write(0,*)' jk=',jk,' jl=',jl,' iazi=',iazi, zdfl(jl,jk,iazi) +! if(zdfl(jl,jk,iazi) > epsln ) then +! zatmp = zcrt(jl,jk,iazi) +! do inc=1, nwav +! zatmp = zatmp + zci(inc) * +! & zacc(jl,inc,iazi)*zflux(jl,inc,iazi)*zdci(inc) +! enddo +! +! zcrt(jl,jk,iazi) = zatmp / zdfl(jl,jk,iazi) +! else +! zcrt(jl,jk,iazi) = zcrt(jl,jk-1,iazi) +! endif +! enddo ! do inc=1, nwav zcin = zci(inc) - zcinc = 1.0 / zcin + if (abs(zcin) > epsln) then + zcinc = 1.0 / zcin + else + zcinc = 1.0 + endif do jl=1,klon !======================================================================= ! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat @@ -1632,18 +1703,18 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, v_cdp = 0. ! no effects of reflected waves endif - fmode = zflux(jl,inc,iazi) - fdis = fmode*expdis +! fmode = zflux(jl,inc,iazi) +! fdis = fmode*expdis + fdis = expdis * zflux(jl,inc,iazi) ! ! saturated flux + wave dissipation - Keddy_gwsat in UGWP-V1 ! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] ! - zfluxs= zfct(jl,jk)*v_cdp*v_cdp*zcinc + zfluxs = zfct(jl,jk)*v_cdp*v_cdp*zcinc ! ! zfluxs= zfct(jl,jk)*(zcin-zui(jl,jk,iazi))**2/zcin ! flux_tot - sat.flux ! - zdep = zact(jl,inc,iazi)* (fdis-zfluxs) if(zdep > 0.0 ) then ! subs on sat-limit @@ -1662,7 +1733,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, zdfdz_v(:,jk,iazi) = 0.0 do inc=1, nwav - zcinc=zdci(inc) ! dc-integration + zcinc = zdci(inc) ! dc-integration do jl=1,klon vc_zflx_mode = zact(jl,inc,iazi)*zflux(jl,inc,iazi) zpu(jl,jk,iazi) = zpu(jl,jk,iazi) + vc_zflx_mode*zcinc @@ -1673,8 +1744,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! later sum over selected azimuths as "non-negative" scalars) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ if (jk > ilaunch)then - zdelp = grav/(prsi(jl,jk-1)-prsi(jl,jk))* - & abs(zcin-zui(jl,jk,iazi)) *zcinc +! zdelp = grav/(prsi(jl,jk-1)-prsi(jl,jk))* +! & abs(zcin-zui(jl,jk,iazi)) *zcinc + zdelp = delpi(jl,jk) * abs(zcin-zui(jl,jk,iazi)) *zcinc vm_zflx_mode = zact(jl,inc,iazi)* zflux_z(jl,inc,jk-1) if (vc_zflx_mode > vm_zflx_mode) @@ -1690,7 +1762,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! -------------- enddo ! end jk do-loop vertical loop ! --------------- - enddo ! end nazd do-loop + enddo ! end nazd do-loop ! ---------------------------------------------------------------------------- ! sum contribution for total zonal and meridional flux + ! energy dissipation @@ -1703,15 +1775,15 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo enddo + tem3 = zaz_fct*cpdi do iazi=1,nazd + tem1 = zaz_fct*zcosang(iazi) + tem2 = zaz_fct*zsinang(iazi) do jk=ilaunch, klev-1 do jl=1,klon - taux(jl,jk) = taux(jl,jk) - & + zpu(jl,jk,iazi)*zaz_fct*zcosang(iazi) ! zaz_fct - "azimuth"-norm-n - tauy(jl,jk) = tauy(jl,jk) - & + zpu(jl,jk,iazi)*zaz_fct*zsinang(iazi) - pdtdt(jl,jk) = pdtdt(jl,jk) - & + zdfdz_v(jl,jk,iazi)*zaz_fct/cpd ! eps_dis =sum( +d(flux_e)/dz) > 0. + taux(jl,jk) = taux(jl,jk) + tem1 * zpu(jl,jk,iazi) ! zaz_fct - "azimuth"-norm-n + tauy(jl,jk) = tauy(jl,jk) + tem2 * zpu(jl,jk,iazi) + pdtdt(jl,jk) = pdtdt(jl,jk) + tem3 * zdfdz_v(jl,jk,iazi) ! eps_dis =sum( +d(flux_e)/dz) > 0. enddo enddo @@ -1723,7 +1795,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, do jk=ilaunch,klev do jl=1, klon - zdelp = grav / (prsi(jl,jk-1)-prsi(jl,jk)) +! zdelp = grav / (prsi(jl,jk-1)-prsi(jl,jk)) + zdelp = delpi(jl,jk) ze1 = (taux(jl,jk)-taux(jl,jk-1))*zdelp ze2 = (tauy(jl,jk)-tauy(jl,jk-1))*zdelp if (abs(ze1) >= maxdudt ) then @@ -1737,7 +1810,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! ! Cx =0 based Cx=/= 0. above ! - pdtdt(jl,jk) = (ze1*um1(jl,jk) + ze2*vm1(jl,jk))/cpd + pdtdt(jl,jk) = (ze1*um1(jl,jk) + ze2*vm1(jl,jk)) * cpdi ! dked(jl,jk) = max(dked_min, pdtdt(jl,jk)/zbn2(jl,jk)) ! if (dked(jl,jk) < 0) dked(jl,jk) = dked_min @@ -1776,7 +1849,7 @@ end subroutine fv3_ugwp_solv2_v0 ! after tests of OGW (new revision) and NGW with MERRA-2 forcing. ! !------------------------------------------------------------------------------- - subroutine edmix_ugwp_v0(im, levs, dtp, + subroutine edmix_ugwp_v0(im, levs, dtp, & t1, u1, v1, q1, del, & prsl, prsi, phil, prslk, & pdudt, pdvdt, pdTdt, pkdis, @@ -1848,7 +1921,7 @@ subroutine edmix_ugwp_v0(im, levs, dtp, ! real(kind=kind_phys), parameter :: iPr_pt = 0.5, dw2min = 1.e-4 real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb - real(kind=kind_phys),parameter :: ulturb=150.,sc2u=ulturb* ulturb + real(kind=kind_phys), parameter :: ulturb=150.,sc2u=ulturb* ulturb real(kind=kind_phys), parameter :: ric =0.25 real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 real(kind=kind_phys), parameter :: prmax = 4.0 @@ -1920,7 +1993,7 @@ subroutine edmix_ugwp_v0(im, levs, dtp, Km(1:levs) = ksum(1:levs) * rho(1:levs)* rho(1:levs) do j=1, nstab - call diff_1d_wtend(levs, dtstab, Fw, Fw1, Km, + call diff_1d_wtend(levs, dtstab, Fw, Fw1, levs, & del(i,:), Sw, Sw1) Fw = Sw Fw1 = Sw1 @@ -1950,13 +2023,15 @@ subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) integer :: i, k - real(kind=kind_phys) :: Km1, Kp1, ad, cd, bd + real(kind=kind_phys) :: Kp1, ad, cd, bd +! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd ! S(:) = 0.0 ; S1(:) = 0.0 ! ! explicit diffusion solver ! k = 1 - km1 = 0. ; ad =0. +! km1 = 0. ; ad =0. + ad =0. kp1 = .5*(Km(k)+Km(k+1)) cd = rdp(1)*rdpm(1)*kp1*dt bd = 1. - cd - ad @@ -1981,16 +2056,18 @@ subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) implicit none integer :: levs real(kind=kind_phys) :: dt - real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) + real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) integer :: i, k - real(kind=kind_phys) :: Km1, Kp1, ad, cd, bd + real(kind=kind_phys) :: Kp1, ad, cd, bd +! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd ! ! explicit "eddy" smoother for tendencies ! k = 1 - km1 = 0. ; ad =0. +! km1 = 0. ; ad =0. + ad =0. kp1 = .5*(Km(k)+Km(k+1)) cd = rdp(1)*rdpm(1)*kp1*dt bd = 1. -(cd +ad) @@ -2003,6 +2080,6 @@ subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) bd = 1.-(ad +cd) S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) enddo - k =levs + k = levs S(k) = F(k) end subroutine diff_1d_ptend From b4d277ed26476d4930b04872bf277e0720d33a1c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 7 Oct 2019 09:00:57 +0900 Subject: [PATCH 40/59] physics/GFS_surface_composites.F90, physics/GFS_PBL_generic.F90: update with final changes to IPD GFSv16 physics --- physics/GFS_PBL_generic.F90 | 168 ++++++++++++++++++----------- physics/GFS_surface_composites.F90 | 6 +- 2 files changed, 110 insertions(+), 64 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 471978d07..29227db99 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -112,7 +112,6 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, vdftra(i,k,12) = qgrs(i,k,ntoz) enddo enddo - kk = 12 else ! MG2 do k=1,levs do i=1,im @@ -128,17 +127,6 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, vdftra(i,k,10) = qgrs(i,k,ntoz) enddo enddo - kk = 10 - endif - if (trans_aero) then - do n=ntchs,ntchm+ntchs-1 - kk = kk + 1 - do k=1,levs - do i=1,im - vdftra(i,k,kk) = qgrs(i,k,n) - enddo - enddo - enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP @@ -153,30 +141,36 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, vdftra(i,k,7) = qgrs(i,k,ntoz) enddo enddo - if (trans_aero) then - kk = 7 - do n=ntchs,ntchm+ntchs-1 - kk = kk + 1 - do k=1,levs - do i=1,im - vdftra(i,k,kk) = qgrs(i,k,n) - enddo - enddo - enddo - endif elseif (imp_physics == imp_physics_zhao_carr) then ! Zhao/Carr/Sundqvist - if (cplchm) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = qgrs(i,k,ntqv) + vdftra(i,k,2) = qgrs(i,k,ntcw) + vdftra(i,k,3) = qgrs(i,k,ntoz) + enddo + enddo + endif +! + if (trans_aero) then + call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, kk, & + errmsg, errflg) + if (.not.errflg==1) return + ! + k1 = kk + do n=ntchs,ntchm+ntchs-1 + k1 = k1 + 1 do k=1,levs do i=1,im - vdftra(i,k,1) = qgrs(i,k,ntqv) - vdftra(i,k,2) = qgrs(i,k,ntcw) - vdftra(i,k,3) = qgrs(i,k,ntoz) + vdftra(i,k,k1) = qgrs(i,k,n) enddo enddo - endif + enddo endif - +! if (ntke>0) then do k=1,levs do i=1,im @@ -184,7 +178,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, enddo enddo endif - +! endif end subroutine GFS_PBL_generic_pre_run @@ -270,7 +264,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if (nvdiff == ntrac .and. (hybedmf .or. do_shoc .or. satmedmf)) then dqdt = dvdftra elseif (nvdiff /= ntrac .and. .not. shinhong .and. .not. do_ysu) then - +! if (ntke>0) then do k=1,levs do i=1,im @@ -278,7 +272,27 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, enddo enddo endif - +! + if (trans_aero) then + ! Set kk if chemistry-aerosol tracers are diffused + call set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, kk, & + errmsg, errflg) + if (.not.errflg==1) return + ! + k1 = kk + do n=ntchs,ntchm+ntchs-1 + k1 = k1 + 1 + do k=1,levs + do i=1,im + dqdt(i,k,n) = dvdftra(i,k,k1) + enddo + enddo + enddo + endif +! if (imp_physics == imp_physics_wsm6) then ! WSM6 do k=1,levs @@ -337,7 +351,6 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,12) enddo enddo - kk = 12 else ! MG2 do k=1,levs do i=1,im @@ -353,17 +366,6 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,10) enddo enddo - kk = 10 - endif - if (trans_aero) then - do n=ntchs,ntchm+ntchs-1 - kk = kk + 1 - do k=1,levs - do i=1,im - dqdt(i,k,n) = dvdftra(i,k,kk) - enddo - enddo - enddo endif elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP do k=1,levs @@ -377,27 +379,14 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt(i,k,ntoz) = dvdftra(i,k,7) enddo enddo - if (trans_aero) then - kk = 7 - do n=ntchs,ntchm+ntchs-1 - kk = kk + 1 - do k=1,levs - do i=1,im - dqdt(i,k,n) = dvdftra(i,k,kk) - enddo - enddo - enddo - endif elseif (imp_physics == imp_physics_zhao_carr) then - if (cplchm) then - do k=1,levs - do i=1,im - dqdt(i,k,1) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntoz) = dvdftra(i,k,3) - enddo + do k=1,levs + do i=1,im + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntoz) = dvdftra(i,k,3) enddo - endif + enddo endif endif ! nvdiff == ntrac @@ -501,4 +490,57 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, end subroutine GFS_PBL_generic_post_run + + subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, kk, & + errmsg, errflg) + implicit none + ! + integer, intent(in ) :: imp_physics, imp_physics_wsm6, & + imp_physics_thompson, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr + logical, intent(in ) :: ltaerosol + integer, intent(out) :: kk + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errflg = 0 + +! Set Interstitial%kk = last index in diffused tracer array before chemistry-aerosol tracers + if (imp_physics == imp_physics_wsm6) then +! WSM6 + kk = 4 + elseif (imp_physics == imp_physics_thompson) then +! Thompson + if(ltaerosol) then + kk = 10 + else + kk = 7 + endif +! MG + elseif (imp_physics == imp_physics_mg) then + if (ntgl > 0) then + kk = 12 + else + kk = 10 + endif + elseif (imp_physics == imp_physics_gfdl) then +! GFDL MP + kk = 7 + elseif (imp_physics == imp_physics_zhao_carr) then +! Zhao/Carr/Sundqvist + kk = 3 + else + write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' + kk = -999 + errflg = 1 + return + endif + + end subroutine set_aerosol_tracer_index + + end module GFS_PBL_generic_post diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 59598913c..4a0ed7d6c 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -351,7 +351,11 @@ subroutine GFS_surface_composites_post_run ( if (.not. flag_cice(i)) then if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array ! DH* NOT NEEDED? Sfcprop%hice(i) = zice(i) - cice(i) = cice(i) * (1.0-landfrac(i)) ! fice is fraction of lake area that is frozen +! DH* is this correct? can we update cice in place or do we need separate variables as for IPD? +!! Sfcprop%fice(i) = fice(i) * Sfcprop%lakefrac(i) ! fice is fraction of lake area that is frozen +! Sfcprop%fice(i) = fice(i) * (one-Sfcprop%landfrac(i)) ! fice is fraction of wet area that is frozen + cice(i) = cice(i) * (1.0-landfrac(i)) ! cice is fraction of wet area that is frozen +! *DH tisfc(i) = tice(i) else ! this would be over open ocean or land (no ice fraction) hice(i) = zero From 78dc94bbac243f204852cf17f2480c0c6af12aaf Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 7 Oct 2019 12:22:23 +0900 Subject: [PATCH 41/59] Remove debug prints from GFSv16 changes --- physics/GFS_phys_time_vary.scm.F90 | 2 +- physics/cires_ugwp.F90 | 39 ---------- physics/gwdps.f | 87 ---------------------- physics/sfc_diag_post.F90 | 4 +- physics/sfc_nst.f | 112 ----------------------------- 5 files changed, 3 insertions(+), 241 deletions(-) diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index d8ca39ba3..3b4bbaf77 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -368,7 +368,7 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED endif endif - + #if 0 !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) if (first_time_step) then diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index b6442aefd..99767e9b0 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -75,10 +75,7 @@ subroutine cires_ugwp_init (me, master, nlunit, logunit, fn_nml2, & if (is_initialized) return - write(0,*) "DH DEBUG cires_ugwp_init: do_ugwp, (cdmbgwd(3) > 0.0) ?", do_ugwp, " ", (cdmbgwd(3) > 0.0) - if (do_ugwp .or. cdmbgwd(3) > 0.0) then - write(0,*) "DH DEBUG cires_ugwp_init: cires_ugwp_mod_init" call cires_ugwp_mod_init (me, master, nlunit, logunit, fn_nml2, & lonr, latr, levs, ak, bk, con_p0, dtp, & cdmbgwd(1:2), cgwf, pa_rf_in, tau_rf_in) @@ -94,8 +91,6 @@ subroutine cires_ugwp_init (me, master, nlunit, logunit, fn_nml2, & return end if - write(0,*) "DH DEBUG cires_ugwp_init: set is_initialized = .true." - is_initialized = .true. end subroutine cires_ugwp_init @@ -213,14 +208,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr errmsg = '' errflg = 0 - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: do_ugwp, nmtvr:", do_ugwp, " ", nmtvr - ! *DH - - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: cdmbgwd=", cdmbgwd - ! *DH - ! 1) ORO stationary GWs ! ------------------ ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality @@ -238,9 +225,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr zlwb(:) = 0. - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: calling GWDPS_V0, cdmbgwd:", cdmbgwd - ! *DH call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & @@ -260,9 +244,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr enddo if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: calling gwdps_run, cdmbgwd:", cdmbgwd - ! *DH call gwdps_run(im, im, levs, Pdvdt, Pdudt, Pdtdt, & ugrs, vgrs, tgrs, qgrs, & kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & @@ -271,9 +252,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr con_g, con_cp, con_rd, con_rv, lonr, & nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, & errmsg, errflg) - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: after calling gwdps_run, errflg=", errflg - ! *DH if (errflg/=0) return endif @@ -284,16 +262,8 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr endif ! do_ugwp - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: after do_ugwp" - ! *DH - if (cdmbgwd(3) > 0.0) then - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: calling slat_geos5_tamp" - ! *DH - ! 2) non-stationary GW-scheme with GMAO/MERRA GW-forcing call slat_geos5_tamp(im, tamp_mpa, xlat_d, tau_ngw) @@ -332,11 +302,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr enddo endif - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: tau_ngw=", sum(tau_ngw) - write(0,*) "DH DEBUG cires_ugwp_run: calling fv3_ugwp_solv2_v0" - ! *DH - call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), & prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_ngw, me, master, kdt) @@ -367,10 +332,6 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr endif - ! DH* - write(0,*) "DH DEBUG cires_ugwp_run: before final pogw assignment" - ! *DH - if (pogw == 0.0) then tau_mtb = 0. ; tau_ogw = 0. ; tau_tofd = 0. dudt_mtb = 0. ; dudt_ogw = 0. ; dudt_tms = 0. diff --git a/physics/gwdps.f b/physics/gwdps.f index a29c89218..d5e34a04a 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -294,9 +294,6 @@ subroutine gwdps_run( & ! ! ******************************************************************** USE MACHINE , ONLY : kind_phys - ! DH* - use GFS_diagtoscreen - ! *DH implicit none ! ! Interface variables @@ -415,48 +412,6 @@ subroutine gwdps_run( & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - - call print_var(-999, -999, -999, "IM :", IM ) - call print_var(-999, -999, -999, "IX :", IX ) - call print_var(-999, -999, -999, "KM :", KM ) - call print_var(-999, -999, -999, "A :", A ) - call print_var(-999, -999, -999, "B :", B ) - call print_var(-999, -999, -999, "C :", C ) - call print_var(-999, -999, -999, "U1 :", U1 ) - call print_var(-999, -999, -999, "V1 :", V1 ) - call print_var(-999, -999, -999, "T1 :", T1 ) - call print_var(-999, -999, -999, "Q1 :", Q1 ) - call print_var(-999, -999, -999, "KPBL :", KPBL ) - call print_var(-999, -999, -999, "PRSI :", PRSI ) - call print_var(-999, -999, -999, "DEL :", DEL ) - call print_var(-999, -999, -999, "PRSL :", PRSL ) - call print_var(-999, -999, -999, "PRSLK :", PRSLK ) - call print_var(-999, -999, -999, "PHII :", PHII ) - call print_var(-999, -999, -999, "PHIL :", PHIL ) - call print_var(-999, -999, -999, "DELTIM :", DELTIM ) - call print_var(-999, -999, -999, "KDT :", KDT ) - call print_var(-999, -999, -999, "HPRIME :", HPRIME ) - call print_var(-999, -999, -999, "OC :", OC ) - call print_var(-999, -999, -999, "OA4 :", OA4 ) - call print_var(-999, -999, -999, "CLX4 :", CLX4 ) - call print_var(-999, -999, -999, "THETA :", THETA ) - call print_var(-999, -999, -999, "SIGMA :", SIGMA ) - call print_var(-999, -999, -999, "GAMMA :", GAMMA ) - call print_var(-999, -999, -999, "ELVMAX :", ELVMAX ) - call print_var(-999, -999, -999, "DUSFC :", DUSFC ) - call print_var(-999, -999, -999, "DVSFC :", DVSFC ) - call print_var(-999, -999, -999, "G :", G ) - call print_var(-999, -999, -999, "CP :", CP ) - call print_var(-999, -999, -999, "RD :", RD ) - call print_var(-999, -999, -999, "RV :", RV ) - call print_var(-999, -999, -999, "IMX :", IMX ) - call print_var(-999, -999, -999, "nmtvr :", nmtvr ) - !call print_var(-999, -999, -999, "cdmbgwd :", cdmbgwd) - call print_var(-999, -999, -999, "me :", me ) - call print_var(-999, -999, -999, "lprnt :", lprnt ) - call print_var(-999, -999, -999, "ipr :", ipr ) - call print_var(-999, -999, -999, "rdxzb :", rdxzb ) - ! ! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) ! non-dim sub grid mtn drag Amp (*j*) @@ -1354,48 +1309,6 @@ subroutine gwdps_run( & ! ! print *,' in gwdps_lm.f 18 =',A(ipt(1),idxzb(1)) ! &, B(ipt(1),idxzb(1)),me - - call print_var(-777, -777, -777, "IM :", IM ) - call print_var(-777, -777, -777, "IX :", IX ) - call print_var(-777, -777, -777, "KM :", KM ) - call print_var(-777, -777, -777, "A :", A ) - call print_var(-777, -777, -777, "B :", B ) - call print_var(-777, -777, -777, "C :", C ) - call print_var(-777, -777, -777, "U1 :", U1 ) - call print_var(-777, -777, -777, "V1 :", V1 ) - call print_var(-777, -777, -777, "T1 :", T1 ) - call print_var(-777, -777, -777, "Q1 :", Q1 ) - call print_var(-777, -777, -777, "KPBL :", KPBL ) - call print_var(-777, -777, -777, "PRSI :", PRSI ) - call print_var(-777, -777, -777, "DEL :", DEL ) - call print_var(-777, -777, -777, "PRSL :", PRSL ) - call print_var(-777, -777, -777, "PRSLK :", PRSLK ) - call print_var(-777, -777, -777, "PHII :", PHII ) - call print_var(-777, -777, -777, "PHIL :", PHIL ) - call print_var(-777, -777, -777, "DELTIM :", DELTIM ) - call print_var(-777, -777, -777, "KDT :", KDT ) - call print_var(-777, -777, -777, "HPRIME :", HPRIME ) - call print_var(-777, -777, -777, "OC :", OC ) - call print_var(-777, -777, -777, "OA4 :", OA4 ) - call print_var(-777, -777, -777, "CLX4 :", CLX4 ) - call print_var(-777, -777, -777, "THETA :", THETA ) - call print_var(-777, -777, -777, "SIGMA :", SIGMA ) - call print_var(-777, -777, -777, "GAMMA :", GAMMA ) - call print_var(-777, -777, -777, "ELVMAX :", ELVMAX ) - call print_var(-777, -777, -777, "DUSFC :", DUSFC ) - call print_var(-777, -777, -777, "DVSFC :", DVSFC ) - call print_var(-777, -777, -777, "G :", G ) - call print_var(-777, -777, -777, "CP :", CP ) - call print_var(-777, -777, -777, "RD :", RD ) - call print_var(-777, -777, -777, "RV :", RV ) - call print_var(-777, -777, -777, "IMX :", IMX ) - call print_var(-777, -777, -777, "nmtvr :", nmtvr ) - !call print_var(-777, -777, -777, "cdmbgwd :", cdmbgwd) - call print_var(-777, -777, -777, "me :", me ) - call print_var(-777, -777, -777, "lprnt :", lprnt ) - call print_var(-777, -777, -777, "ipr :", ipr ) - call print_var(-777, -777, -777, "rdxzb :", rdxzb ) - RETURN end subroutine gwdps_run !> @} diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 6f5561cc0..767e98db5 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -41,7 +41,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + if (lsm == lsm_noahmp) then do i=1,im if(dry(i)) then @@ -50,7 +50,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con endif enddo endif - + if (lssav) then do i=1,im tmpmax(i) = max(tmpmax(i),t2m(i)) diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 5d721c016..ed43a719d 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -252,62 +252,6 @@ subroutine sfc_nst_run & errmsg = '' errflg = 0 - write (0,*) "DH DEBUG: IN im = ", im - write (0,*) "DH DEBUG: IN ps = ", sum(ps ) - write (0,*) "DH DEBUG: IN u1 = ", sum(u1 ) - write (0,*) "DH DEBUG: IN v1 = ", sum(v1 ) - write (0,*) "DH DEBUG: IN t1 = ", sum(t1 ) - write (0,*) "DH DEBUG: IN q1 = ", sum(q1 ) - write (0,*) "DH DEBUG: IN tref = ", sum(tref ) - write (0,*) "DH DEBUG: IN cm = ", sum(cm ) - write (0,*) "DH DEBUG: IN ch = ", sum(ch ) - write (0,*) "DH DEBUG: IN prsl1 = ", sum(prsl1 ) - write (0,*) "DH DEBUG: IN prslki = ", sum(prslki ) - write (0,*) "DH DEBUG: IN wet = ", count(wet ) - write (0,*) "DH DEBUG: IN xlon = ", sum(xlon ) - write (0,*) "DH DEBUG: IN sinlat = ", sum(sinlat ) - write (0,*) "DH DEBUG: IN stress = ", sum(stress ) - write (0,*) "DH DEBUG: IN sfcemis = ", sum(sfcemis ) - write (0,*) "DH DEBUG: IN dlwflx = ", sum(dlwflx ) - write (0,*) "DH DEBUG: IN sfcnsw = ", sum(sfcnsw ) - write (0,*) "DH DEBUG: IN rain = ", sum(rain ) - write (0,*) "DH DEBUG: IN timestep = ", timestep - write (0,*) "DH DEBUG: IN kdt = ", kdt - write (0,*) "DH DEBUG: IN solhr = ", solhr - write (0,*) "DH DEBUG: IN xcosz = ", sum(xcosz ) - write (0,*) "DH DEBUG: IN wind = ", sum(wind ) - write (0,*) "DH DEBUG: IN flag_iter = ", count(flag_iter ) - write (0,*) "DH DEBUG: IN flag_guess = ", count(flag_guess) - !write (0,*) "DH DEBUG: IN nstf_name = ", (/ nstf_name1, nstf_name4, nstf_name5 /) - write (0,*) "DH DEBUG: IN lprnt = ", lprnt - write (0,*) "DH DEBUG: IN ipr = ", ipr - write (0,*) "DH DEBUG: IN tskin = ", sum(tskin ) - write (0,*) "DH DEBUG: IN tsurf = ", sum(tsurf ) - write (0,*) "DH DEBUG: IN xt = ", sum(xt ) - write (0,*) "DH DEBUG: IN xs = ", sum(xs ) - write (0,*) "DH DEBUG: IN xu = ", sum(xu ) - write (0,*) "DH DEBUG: IN xv = ", sum(xv ) - write (0,*) "DH DEBUG: IN xz = ", sum(xz ) - write (0,*) "DH DEBUG: IN zm = ", sum(zm ) - write (0,*) "DH DEBUG: IN xtts = ", sum(xtts ) - write (0,*) "DH DEBUG: IN xzts = ", sum(xzts ) - write (0,*) "DH DEBUG: IN dt_cool = ", sum(dt_cool ) - write (0,*) "DH DEBUG: IN z_c = ", sum(z_c ) - write (0,*) "DH DEBUG: IN c_0 = ", sum(c_0 ) - write (0,*) "DH DEBUG: IN c_d = ", sum(c_d ) - write (0,*) "DH DEBUG: IN w_0 = ", sum(w_0 ) - write (0,*) "DH DEBUG: IN w_d = ", sum(w_d ) - write (0,*) "DH DEBUG: IN d_conv = ", sum(d_conv ) - write (0,*) "DH DEBUG: IN ifd = ", sum(ifd ) - write (0,*) "DH DEBUG: IN qrain = ", sum(qrain ) - write (0,*) "DH DEBUG: IN qsurf = ", sum(qsurf ) - write (0,*) "DH DEBUG: IN gflux = ", sum(gflux ) - write (0,*) "DH DEBUG: IN cmm = ", sum(cmm ) - write (0,*) "DH DEBUG: IN chh = ", sum(chh ) - write (0,*) "DH DEBUG: IN evap = ", sum(evap ) - write (0,*) "DH DEBUG: IN hflx = ", sum(hflx ) - write (0,*) "DH DEBUG: IN ep = ", sum(ep ) - cpinv=1.0/cp hvapi=1.0/hvap elocp=hvap/cp @@ -698,62 +642,6 @@ subroutine sfc_nst_run & ! ! if (lprnt) print *,' tskin=',tskin(ipr) - write (0,*) "DH DEBUG: OUT im = ", im - write (0,*) "DH DEBUG: OUT ps = ", sum(ps ) - write (0,*) "DH DEBUG: OUT u1 = ", sum(u1 ) - write (0,*) "DH DEBUG: OUT v1 = ", sum(v1 ) - write (0,*) "DH DEBUG: OUT t1 = ", sum(t1 ) - write (0,*) "DH DEBUG: OUT q1 = ", sum(q1 ) - write (0,*) "DH DEBUG: OUT tref = ", sum(tref ) - write (0,*) "DH DEBUG: OUT cm = ", sum(cm ) - write (0,*) "DH DEBUG: OUT ch = ", sum(ch ) - write (0,*) "DH DEBUG: OUT prsl1 = ", sum(prsl1 ) - write (0,*) "DH DEBUG: OUT prslki = ", sum(prslki ) - write (0,*) "DH DEBUG: OUT wet = ", count(wet ) - write (0,*) "DH DEBUG: OUT xlon = ", sum(xlon ) - write (0,*) "DH DEBUG: OUT sinlat = ", sum(sinlat ) - write (0,*) "DH DEBUG: OUT stress = ", sum(stress ) - write (0,*) "DH DEBUG: OUT sfcemis = ", sum(sfcemis ) - write (0,*) "DH DEBUG: OUT dlwflx = ", sum(dlwflx ) - write (0,*) "DH DEBUG: OUT sfcnsw = ", sum(sfcnsw ) - write (0,*) "DH DEBUG: OUT rain = ", sum(rain ) - write (0,*) "DH DEBUG: OUT timestep = ", timestep - write (0,*) "DH DEBUG: OUT kdt = ", kdt - write (0,*) "DH DEBUG: OUT solhr = ", solhr - write (0,*) "DH DEBUG: OUT xcosz = ", sum(xcosz ) - write (0,*) "DH DEBUG: OUT wind = ", sum(wind ) - write (0,*) "DH DEBUG: OUT flag_iter = ", count(flag_iter ) - write (0,*) "DH DEBUG: OUT flag_guess = ", count(flag_guess) - !write (0,*) "DH DEBUG: IN nstf_name = ", (/ nstf_name1, nstf_name4, nstf_name5 /) - write (0,*) "DH DEBUG: OUT lprnt = ", lprnt - write (0,*) "DH DEBUG: OUT ipr = ", ipr - write (0,*) "DH DEBUG: OUT tskin = ", sum(tskin ) - write (0,*) "DH DEBUG: OUT tsurf = ", sum(tsurf ) - write (0,*) "DH DEBUG: OUT xt = ", sum(xt ) - write (0,*) "DH DEBUG: OUT xs = ", sum(xs ) - write (0,*) "DH DEBUG: OUT xu = ", sum(xu ) - write (0,*) "DH DEBUG: OUT xv = ", sum(xv ) - write (0,*) "DH DEBUG: OUT xz = ", sum(xz ) - write (0,*) "DH DEBUG: OUT zm = ", sum(zm ) - write (0,*) "DH DEBUG: OUT xtts = ", sum(xtts ) - write (0,*) "DH DEBUG: OUT xzts = ", sum(xzts ) - write (0,*) "DH DEBUG: OUT dt_cool = ", sum(dt_cool ) - write (0,*) "DH DEBUG: OUT z_c = ", sum(z_c ) - write (0,*) "DH DEBUG: OUT c_0 = ", sum(c_0 ) - write (0,*) "DH DEBUG: OUT c_d = ", sum(c_d ) - write (0,*) "DH DEBUG: OUT w_0 = ", sum(w_0 ) - write (0,*) "DH DEBUG: OUT w_d = ", sum(w_d ) - write (0,*) "DH DEBUG: OUT d_conv = ", sum(d_conv ) - write (0,*) "DH DEBUG: OUT ifd = ", sum(ifd ) - write (0,*) "DH DEBUG: OUT qrain = ", sum(qrain ) - write (0,*) "DH DEBUG: OUT qsurf = ", sum(qsurf ) - write (0,*) "DH DEBUG: OUT gflux = ", sum(gflux ) - write (0,*) "DH DEBUG: OUT cmm = ", sum(cmm ) - write (0,*) "DH DEBUG: OUT chh = ", sum(chh ) - write (0,*) "DH DEBUG: OUT evap = ", sum(evap ) - write (0,*) "DH DEBUG: OUT hflx = ", sum(hflx ) - write (0,*) "DH DEBUG: OUT ep = ", sum(ep ) - return end subroutine sfc_nst_run !> @} From 11e1d3d37898d1855a1cf1b1dadfcfecb9d0c783 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Mon, 7 Oct 2019 18:10:30 +0000 Subject: [PATCH 42/59] Fix the unit conversion for soil moisture content. --- physics/sfc_drv_ruc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 64e4d4597..61246b67d 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -897,7 +897,7 @@ subroutine lsm_ruc_run & ! inputs sfcdew(i) = dew(i,j) qsurf(i) = qsfc(i,j) sncovr1(i) = sncovr(i,j) - stm(i) = soilm(i,j) * 1000.0 ! unit conversion (from m to kg m-2) + stm(i) = soilm(i,j) tsurf(i) = soilt(i,j) tice(i) = tsurf(i) From a5a15d8d14627bfc066e1a8899123d228f15ed49 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 8 Oct 2019 09:01:17 +0900 Subject: [PATCH 43/59] physics/GFS_PBL_generic.F90: bugfix, add missing local variable k1 --- physics/GFS_PBL_generic.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 29227db99..83885c096 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -43,7 +43,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, integer, intent(out) :: errflg !local variables - integer :: i, k, kk, n + integer :: i, k, kk, k1, n ! Initialize CCPP error handling variables errmsg = '' @@ -254,7 +254,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - integer :: i, k, kk, n + integer :: i, k, kk, k1, n real(kind=kind_phys) :: tem, tem1, rho ! Initialize CCPP error handling variables From 2191c5524ef79e815fb2e71c48ae48aac8bbdb9f Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 8 Oct 2019 09:01:34 +0900 Subject: [PATCH 44/59] Update NoahMP in CCPP --- physics/module_sf_noahmplsm.f90 | 88 ++++++++++++++++++++++----------- physics/sfc_noahmp_drv.f | 44 +++++++++++------ physics/sfc_noahmp_drv.meta | 14 ++++-- 3 files changed, 97 insertions(+), 49 deletions(-) diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 4f1f7dbad..af7a8362e 100755 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -286,6 +286,7 @@ subroutine noahmp_sflx (parameters, & qc , soldn , lwdn , & ! in : forcing prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing + lheatstrg , & ! in : canopy heat storage albold , sneqvo , & ! in/out : stc , sh2o , smc , tah , eah , fwet , & ! in/out : canliq , canice , tv , tg , qsfc , qsnow , & ! in/out : @@ -293,9 +294,9 @@ subroutine noahmp_sflx (parameters, & zwt , wa , wt , wslake , lfmass , rtmass , & ! in/out : stmass , wood , stblcp , fastcp , lai , sai , & ! in/out : cm , ch , tauss , & ! in/out : - smcwtd ,deeprech , rech , & ! in/out : + smcwtd ,deeprech , rech , cpfac , & ! in/out : z0wrf , & - fsa , fsr , fira , fsh , ssoil , fcev , & ! out : + fsa , fsr , fira , fshx , ssoil , fcev , & ! out : fgev , fctr , ecan , etran , edir , trad , & ! out : tgb , tgv , t2mv , t2mb , q2v , q2b , & ! out : runsrf , runsub , apar , psn , sav , sag , & ! out : @@ -336,6 +337,7 @@ subroutine noahmp_sflx (parameters, & real , intent(in) :: lwdn !downward longwave radiation (w/m2) real , intent(in) :: sfcprs !pressure (pa) real , intent(inout) :: zlvl !reference height (m) + logical , intent(in) :: lheatstrg ! flag for canopy heat storage parameterization real , intent(in) :: cosz !cosine solar zenith angle [0-1] real , intent(in) :: tbot !bottom condition for soil temp. [k] real , intent(in) :: foln !foliage nitrogen (%) [1-saturated] @@ -394,13 +396,14 @@ subroutine noahmp_sflx (parameters, & real, intent(inout) :: smcwtd !soil water content between bottom of the soil and water table [m3/m3] real, intent(inout) :: deeprech !recharge to or from the water table when deep [m] real, intent(inout) :: rech !recharge to or from the water table when shallow [m] (diagnostic) + real, intent(inout) :: cpfac ! heat capacity enhancement factor due to heat storage ! output real , intent(out) :: z0wrf !combined z0 sent to coupled model real , intent(out) :: fsa !total absorbed solar radiation (w/m2) real , intent(out) :: fsr !total reflected solar radiation (w/m2) real , intent(out) :: fira !total net lw rad (w/m2) [+ to atm] - real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fshx !total sensible heat (w/m2) [+ to atm] real , intent(out) :: fcev !canopy evap heat (w/m2) [+ to atm] real , intent(out) :: fgev !ground evap heat (w/m2) [+ to atm] real , intent(out) :: fctr !transpiration heat (w/m2) [+ to atm] @@ -450,6 +453,7 @@ subroutine noahmp_sflx (parameters, & real :: taux !wind stress: e-w (n/m2) real :: tauy !wind stress: n-s (n/m2) real :: rhoair !density air (kg/m3) + real :: fsh !total sensible heat (w/m2) [+ to atm] ! real, dimension( 1: 5) :: vocflx !voc fluxes [ug c m-2 h-1] real, dimension(-nsnow+1:nsoil) :: dzsnso !snow/soil layer thickness [m] real :: thair !potential temperature (k) @@ -640,6 +644,7 @@ subroutine noahmp_sflx (parameters, & call energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in isnow ,dt ,rhoair ,sfcprs ,qair , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in + lheatstrg , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in elai ,esai ,fwet ,foln , & !in @@ -648,16 +653,16 @@ subroutine noahmp_sflx (parameters, & z0wrf , & imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out - tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + tauy ,fira ,fsh ,fshx ,fcev ,fgev ,fctr , & !out trad ,psn ,apar ,ssoil ,btrani ,btran , & !out ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out tv ,tg ,stc ,snowh ,eah ,tah , & !inout sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout #ifdef CCPP - tauss ,errmsg ,errflg , & !inout + tauss ,cpfac ,errmsg ,errflg , & !inout #else - tauss , & !inout + tauss ,cpfac , & !inout #endif !jref:start qc ,qsfc ,psfc , & !in @@ -709,7 +714,7 @@ subroutine noahmp_sflx (parameters, & ! water and energy balance check - call error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & !in + call error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & !in fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & !in sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & !in etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in @@ -1413,6 +1418,7 @@ end subroutine error subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in isnow ,dt ,rhoair ,sfcprs ,qair , & !in sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in + lheatstrg , & !in co2air ,o2air ,solad ,solai ,cosz ,igs , & !in eair ,tbot ,zsnso ,zsoil , & !in elai ,esai ,fwet ,foln , & !in @@ -1421,16 +1427,16 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in z0wrf , & imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out - tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + tauy ,fira ,fsh ,fshx ,fcev ,fgev ,fctr , & !out trad ,psn ,apar ,ssoil ,btrani ,btran , & !out ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out tv ,tg ,stc ,snowh ,eah ,tah , & !inout sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout #ifdef CCPP - tauss ,errmsg ,errflg, & !inout + tauss ,cpfac ,errmsg ,errflg, & !inout #else - tauss , & !inout + tauss ,cpfac , & !inout #endif !jref:start qc ,qsfc ,psfc , & !in @@ -1512,6 +1518,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real , intent(in) :: igs !growing season index (0=off, 1=on) real , intent(in) :: zref !reference height (m) + logical , intent(in) :: lheatstrg ! flag for canopy heat storage parameterization real , intent(in) :: tbot !bottom condition for soil temp. (k) real , dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bottom depth from snow surf [m] real , dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf [m] @@ -1546,6 +1553,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real , intent(out) :: tauy !wind stress: n-s (n/m2) real , intent(out) :: fira !total net lw. rad (w/m2) [+ to atm] real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fshx !total sensible heat (w/m2) [+ to atm] real , intent(out) :: fcev !canopy evaporation (w/m2) [+ to atm] real , intent(out) :: fgev !ground evaporation (w/m2) [+ to atm] real , intent(out) :: fctr !transpiration (w/m2) [+ to atm] @@ -1592,6 +1600,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real , intent(inout) :: tah !canopy air temperature (k) real , intent(inout) :: albold !snow albedo at last time step(class type) real , intent(inout) :: tauss !non-dimensional snow age + real , intent(inout) :: cpfac !heat capacity enhancement factor due to heat storage real , intent(inout) :: cm !momentum drag coefficient real , intent(inout) :: ch !sensible heat exchange coefficient real , intent(inout) :: q1 @@ -1693,6 +1702,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real, parameter :: mpe = 1.e-6 real, parameter :: psiwlt = -150. !metric potential for wilting point (m) real, parameter :: z0 = 0.01 ! bare-soil roughness length (m) (i.e., under the canopy) +! +! parameters for heat storage parametrization +! + real, parameter :: z0min = 0.2 !minimum roughness length for heat storage + real, parameter :: z0max = 1.0 !maximum roughness length for heat storage ! --------------------------------------------------------------------------------------------------- ! initialize fluxes from veg. fraction @@ -1758,6 +1772,13 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in z0m = z0mg zpd = zpdg end if +! +! compute heat capacity enhancement factor as a function of z0m to mimic heat storage +! + if (lheatstrg .and. (.not. parameters%urban_flag) ) then + cpfac = (z0m - z0min) / (z0max - z0min) + cpfac = 1. + min(max(cpfac, 0.0), 1.0) + endif zlvl = max(zpd,parameters%hvt) + zref if(zpdg >= zlvl) zlvl = zpdg + zref @@ -1862,7 +1883,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in latheav = hsub frozen_canopy = .true. end if - gammav = cpair*sfcprs/(0.622*latheav) + gammav = cpair*cpfac*sfcprs/(0.622*latheav) if (tg .gt. tfrz) then latheag = hvap @@ -1871,14 +1892,14 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in latheag = hsub frozen_ground = .true. end if - gammag = cpair*sfcprs/(0.622*latheag) + gammag = cpair*cpfac*sfcprs/(0.622*latheag) ! if (sfctmp .gt. tfrz) then ! lathea = hvap ! else ! lathea = hsub ! end if -! gamma = cpair*sfcprs/(0.622*lathea) +! gamma = cpair*cpfac*sfcprs/(0.622*lathea) ! surface temperatures of the ground and canopy and energy fluxes @@ -1891,9 +1912,9 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call vege_flux (parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in dt ,sav ,sag ,lwdn ,ur , & !in uu ,vv ,sfctmp ,thair ,qair , & !in - eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in + eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg , & !in + zlvl ,cpfac ,zpd ,z0m ,fveg , & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -1923,7 +1944,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in lwdn ,ur ,uu ,vv ,sfctmp , & !in thair ,qair ,eair ,rhoair ,snowh , & !in - dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in + dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in #ifdef CCPP @@ -1949,6 +1970,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in tauy = fveg * tauyv + (1.0 - fveg) * tauyb fira = fveg * irg + (1.0 - fveg) * irb + irc fsh = fveg * shg + (1.0 - fveg) * shb + shc + fshx = fveg * shg/cpfac + (1.0 - fveg) * shb + shc/cpfac fgev = fveg * evg + (1.0 - fveg) * evb ssoil = fveg * ghv + (1.0 - fveg) * ghb fcev = evc @@ -1967,6 +1989,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in tauy = tauyb fira = irb fsh = shb + fshx = shb fgev = evb ssoil = ghb tg = tgb @@ -3260,7 +3283,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & uu ,vv ,sfctmp ,thair ,qair , & !in eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in fwet ,laisun ,laisha ,cwp ,dzsnso , & !in - zlvl ,zpd ,z0m ,fveg , & !in + zlvl ,cpfac , & !in + zpd ,z0m ,fveg , & !in z0mg ,emv ,emg ,canliq ,fsno, & !in canice ,stc ,df ,rssun ,rssha , & !in rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in @@ -3320,6 +3344,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real, intent(in) :: laisun !sunlit leaf area index, one-sided (m2/m2) real, intent(in) :: laisha !shaded leaf area index, one-sided (m2/m2) real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: cpfac !heat capacity enhancement factor due to heat storage + real, intent(in) :: zpd !zero plane displacement (m) real, intent(in) :: z0m !roughness length, momentum (m) real, intent(in) :: z0mg !roughness length, momentum, ground (m) @@ -3449,6 +3475,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real :: kh !turbulent transfer coefficient, sensible heat, (m2/s) real :: h !temporary sensible heat flux (w/m2) real :: hg !temporary sensible heat flux (w/m2) + real :: moz !monin-obukhov stability parameter real :: mozg !monin-obukhov stability parameter real :: mozold !monin-obukhov stability parameter from prior iteration @@ -3578,6 +3605,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 cir = (2.-emv*(1.-emg))*emv*sb + ! --------------------------------------------------------------------------------------------- loop1: do iter = 1, niterc ! begin stability iteration @@ -3674,7 +3702,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cond = cah + cvh + cgh ata = (sfctmp*cah + tg*cgh) / cond bta = cvh/cond - csh = (1.-bta)*rhoair*cpair*cvh + csh = (1.-bta)*rhoair*cpair*cpfac*cvh ! prepare for latent heat flux above veg. @@ -3685,8 +3713,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & cond = caw + cew + ctw + cgw aea = (eair*caw + estg*cgw) / cond bea = (cew+ctw)/cond - cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 - ctr = (1.-bea)*ctw*rhoair*cpair/gammav + cev = (1.-bea)*cew*rhoair*cpair*cpfac/gammav ! barlage: change to vegetation v3.6 + ctr = (1.-bea)*ctw*rhoair*cpair*cpfac/gammav ! evaluate surface fluxes with current temperature and solve for dts @@ -3694,9 +3722,9 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & eah = aea + bea*estv ! canopy air e irc = fveg*(air + cir*tv**4) - shc = fveg*rhoair*cpair*cvh * ( tv-tah) - evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 - tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav + shc = fveg*rhoair*cpair*cpfac*cvh * ( tv-tah) + evc = fveg*rhoair*cpair*cpfac*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 + tr = fveg*rhoair*cpair*cpfac*ctw * (estv-eah) / gammav if (tv > tfrz) then evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 else @@ -3736,8 +3764,8 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 cir = emg*sb - csh = rhoair*cpair/rahg - cev = rhoair*cpair / (gammag*(rawg+rsurf)) ! barlage: change to ground v3.6 + csh = rhoair*cpair*cpfac/rahg + cev = rhoair*cpair*cpfac / (gammag*(rawg+rsurf)) ! barlage: change to ground v3.6 cgh = 2.*df(isnow+1)/dzsnso(isnow+1) ! write(*,*)'inside tg=',tg,'stc(1)=',stc(1) @@ -3792,10 +3820,10 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! consistent vegetation air temperature and vapor pressure since tg is not consistent with the tah/eah ! calculation. -! tah = sfctmp + (shg+shc)/(rhoair*cpair*cah) -! tah = sfctmp + (shg*fveg+shc)/(rhoair*cpair*cah) ! ground flux need fveg -! eah = eair + (evc+fveg*(tr+evg))/(rhoair*caw*cpair/gammag ) -! qfx = (qsfc-qair)*rhoair*caw !*cpair/gammag +! tah = sfctmp + (shg+shc)/(rhoair*cpair*cpfac*cah) +! tah = sfctmp + (shg*fveg+shc)/(rhoair*cpair*cpfac*cah) ! ground flux need fveg +! eah = eair + (evc+fveg*(tr+evg))/(rhoair*caw*cpair*cpfac/gammag ) +! qfx = (qsfc-qair)*rhoair*cpfac*caw !*cpair/gammag ! 2m temperature over vegetation ( corrected for low cq2v values ) if (opt_sfc == 1 .or. opt_sfc == 2) then @@ -3808,7 +3836,7 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & ! q2v = (eah*0.622/(sfcprs - 0.378*eah)) q2v = qsfc else - t2mv = tah - (shg+shc/fveg)/(rhoair*cpair) * 1./cah2 + t2mv = tah - (shg+shc/fveg)/(rhoair*cpair*cpfac) * 1./cah2 ! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v endif diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index a089e84d0..ab9f2af0d 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -41,14 +41,19 @@ end subroutine noahmpdrv_finalize !> \section arg_table_noahmpdrv_run Argument Table !! \htmlinclude noahmpdrv_run.html !! +! ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! ! !----------------------------------- subroutine noahmpdrv_run & !................................... ! --- inputs: & ( im, km, itime, ps, u1, v1, t1, q1, soiltyp, vegtype, & & sigmaf, sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - & prsl1, prslki, zf, dry, ddvel, slopetyp, & + & prsl1, prslki, zf, dry, wind, slopetyp, & & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & + & lheatstrg, & & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & & iopt_stc, xlatin, xcoszin, iyrlen, julian, & @@ -118,7 +123,7 @@ subroutine noahmpdrv_run & real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & - & ch, prsl1, prslki, ddvel, shdmin, shdmax, & + & ch, prsl1, prslki, wind, shdmin, shdmax, & & snoalb, sfalb, zf, & & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp @@ -136,7 +141,9 @@ subroutine noahmpdrv_run & real (kind=kind_phys), intent(in) :: delt logical, dimension(im), intent(in) :: flag_iter, flag_guess - + + logical, intent(in) :: lheatstrg + real (kind=kind_phys), intent(in) :: con_hvap, con_cp, con_jcal, & & rhoh2o, con_eps, con_epsm1, con_fvirt, & & con_rd, con_hfus @@ -178,7 +185,7 @@ subroutine noahmpdrv_run & ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & - & q0, qs1, theta1, tv1, wind, weasd_old, snwdph_old, & + & q0, qs1, theta1, tv1, weasd_old, snwdph_old, & & tprcp_old, srflag_old, tskin_old, canopy_old real (kind=kind_phys), dimension(km) :: et,stsoil,smsoil, slsoil @@ -236,6 +243,8 @@ subroutine noahmpdrv_run & & irb,tr,evc,chleaf,chuc,chv2,chb2, & & fpice,pahv,pahg,pahb,pah,co2pp,o2pp,ch2b + real (kind=kind_phys) :: cpfac + integer :: i, k, ice, stype, vtype ,slope,nroot,couple logical :: flag(im) logical :: snowng,frzgra @@ -358,10 +367,6 @@ subroutine noahmpdrv_run & do i = 1, im if (flag_iter(i) .and. flag(i)) then - wind(i) = sqrt( u1(i)*u1(i) + v1(i)*v1(i) ) & - & + max(0.0, min(ddvel(i), 30.0)) - wind(i) = max(wind(i), 1.0) - q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) @@ -628,6 +633,10 @@ subroutine noahmpdrv_run & call noahmp_options(idveg ,iopt_crs,iopt_btr,iopt_run,iopt_sfc, & & iopt_frz,iopt_inf,iopt_rad,iopt_alb,iopt_snf,iopt_tbot,iopt_stc) +! +! initialize heat capacity enhancement factor for heat storage parameterization +! + cpfac = 1.0 if ( vtype == isice_table ) then @@ -716,6 +725,7 @@ subroutine noahmpdrv_run & & qc , swdn , lwdn ,& ! in : forcing & pconv , pnonc , pshcv , psnow , pgrpl , phail ,& ! in : forcing & tbot , co2pp , o2pp , foln , ficeold , zlvl ,& ! in : forcing + & lheatstrg ,& ! in : canopy heat storage & alboldx , sneqvox ,& ! in/out : & tsnsox , slsoil , smsoil , tahx , eahx , fwetx ,& ! in/out : & canliqx , canicex , tvx , tgx , qsfc1d , qsnowx ,& ! in/out : @@ -723,7 +733,7 @@ subroutine noahmpdrv_run & & zwtx , wax , wtx , wslakex , lfmassx , rtmassx,& ! in/out : & stmassx , woodx , stblcpx , fastcpx , xlaix ,xsaix ,& ! in/out : & cmx , chx , taussx ,& ! in/out : - & smcwtdx ,deeprechx, rechx ,& ! in/out : + & smcwtdx ,deeprechx, rechx , cpfac ,& ! in/out : & z0wrf ,& ! out & fsa , fsr , fira , fsh , ssoil , fcev ,& ! out : & fgev , fctr , ecan , etran , edir , trad ,& ! out : @@ -864,7 +874,7 @@ subroutine noahmpdrv_run & ! ssoil = -1.0 *ssoil call penman (sfctmp,sfcprs,chx,t2v,th2,prcp,fdown,ssoil, & - & q2,q2sat,etp,snowng,frzgra,ffrozp,dqsdt2,emissi,fsno) + & cpfac,q2,q2sat,etp,snowng,frzgra,ffrozp,dqsdt2,emissi,fsno) ep(i) = etp @@ -1126,7 +1136,7 @@ end subroutine transfer_mp_parameters subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & - & q2,q2sat,etp,snowng,frzgra,ffrozp, & + & cpfac,q2,q2sat,etp,snowng,frzgra,ffrozp, & & dqsdt2,emissi_in,sncovr) ! etp is calcuated right after ssoil @@ -1141,11 +1151,12 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & implicit none logical, intent(in) :: snowng, frzgra real, intent(in) :: ch, dqsdt2,fdown,prcp,ffrozp, & - & q2, q2sat,ssoil, sfcprs, sfctmp, & + & q2, q2sat,ssoil,cpfac, sfcprs, sfctmp, & & t2v, th2,emissi_in,sncovr real, intent(out) :: etp real :: epsca,flx2,rch,rr,t24 real :: a, delta, fnet,rad,rho,emissi,elcp1,lvs + real :: elcpx real, parameter :: elcp = 2.4888e+3, lsubc = 2.501000e+6,cp = 1004.6 real, parameter :: lsubs = 2.83e+6, rd = 287.05, cph2o = 4.1855e+3 @@ -1159,11 +1170,12 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! prepare partial quantities for penman equation. ! ---------------------------------------------------------------------- emissi=emissi_in -! elcp1 = (1.0-sncovr)*elcp + sncovr*elcp*lsubs/lsubc + elcpx = elcp / cpfac +! elcp1 = (1.0-sncovr)*elcpx + sncovr*elcpx*lsubs/lsubc lvs = (1.0-sncovr)*lsubc + sncovr*lsubs flx2 = 0.0 - delta = elcp * dqsdt2 + delta = elcpx * dqsdt2 ! delta = elcp1 * dqsdt2 t24 = sfctmp * sfctmp * sfctmp * sfctmp rr = t24 * 6.48e-8 / (sfcprs * ch) + 1.0 @@ -1174,7 +1186,7 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! adjust the partial sums / products with the latent heat ! effects caused by falling precipitation. ! ---------------------------------------------------------------------- - rch = rho * cp * ch + rch = rho * cp * cpfac * ch if (.not. snowng) then if (prcp > 0.0) rr = rr + cph2o * prcp / rch else @@ -1197,7 +1209,7 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! ---------------------------------------------------------------------- end if rad = fnet / rch + th2- sfctmp - a = elcp * (q2sat - q2) + a = elcpx * (q2sat - q2) ! a = elcp1 * (q2sat - q2) epsca = (a * rr + rad * delta) / (delta + rr) etp = epsca * rch / lsubc diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 9baa85082..bcca166d0 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -256,9 +256,9 @@ type = logical intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = surface wind enhancement due to convection +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level units = m s-1 dimensions = (horizontal_dimension) type = real @@ -325,6 +325,14 @@ type = logical intent = in optional = F +[lheatstrg] + standard_name = flag_for_canopy_heat_storage + long_name = flag for canopy heat storage parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F [idveg] standard_name = flag_for_dynamic_vegetation_option long_name = choice for dynamic vegetation option (see noahmp module for definition) From e1a2451dca24e38a742766aa5f31c87398d23d23 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 8 Oct 2019 10:09:08 +0900 Subject: [PATCH 45/59] physics/GFS_PBL_generic.F90: change order of modules --- physics/GFS_PBL_generic.F90 | 129 +++++++++++++++++++----------------- 1 file changed, 69 insertions(+), 60 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 83885c096..49401d6ae 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -1,6 +1,70 @@ !> \file GFS_PBL_generic.F90 !! Contains code related to PBL schemes to be used within the GFS physics suite. + module GFS_PBL_generic_common + + implicit none + + private + + public :: set_aerosol_tracer_index + + contains + + subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & + imp_physics_thompson, ltaerosol, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr, kk, & + errmsg, errflg) + implicit none + ! + integer, intent(in ) :: imp_physics, imp_physics_wsm6, & + imp_physics_thompson, & + imp_physics_mg, ntgl, imp_physics_gfdl, & + imp_physics_zhao_carr + logical, intent(in ) :: ltaerosol + integer, intent(out) :: kk + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errflg = 0 + +! Set Interstitial%kk = last index in diffused tracer array before chemistry-aerosol tracers + if (imp_physics == imp_physics_wsm6) then +! WSM6 + kk = 4 + elseif (imp_physics == imp_physics_thompson) then +! Thompson + if(ltaerosol) then + kk = 10 + else + kk = 7 + endif +! MG + elseif (imp_physics == imp_physics_mg) then + if (ntgl > 0) then + kk = 12 + else + kk = 10 + endif + elseif (imp_physics == imp_physics_gfdl) then +! GFDL MP + kk = 7 + elseif (imp_physics == imp_physics_zhao_carr) then +! Zhao/Carr/Sundqvist + kk = 3 + else + write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' + kk = -999 + errflg = 1 + return + endif + + end subroutine set_aerosol_tracer_index + + end module GFS_PBL_generic_common + + module GFS_PBL_generic_pre contains @@ -12,11 +76,9 @@ subroutine GFS_PBL_generic_pre_finalize() end subroutine GFS_PBL_generic_pre_finalize !> \brief This scheme sets up the vertically diffused tracer array for any PBL scheme based on the microphysics scheme chosen -#if 0 !! \section arg_table_GFS_PBL_generic_pre_run Argument Table !! \htmlinclude GFS_PBL_generic_pre_run.html !! -#endif subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & ntwa, ntia, ntgl, ntoz, ntke, ntkev, trans_aero, ntchs, ntchm, & @@ -24,7 +86,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, imp_physics_zhao_carr, imp_physics_mg, cplchm, ltaerosol, hybedmf, do_shoc, & satmedmf, qgrs, vdftra, errmsg, errflg) - use machine, only : kind_phys + use machine, only : kind_phys + use GFS_PBL_generic_common, only : set_aerosol_tracer_index implicit none @@ -185,6 +248,7 @@ end subroutine GFS_PBL_generic_pre_run end module GFS_PBL_generic_pre + module GFS_PBL_generic_post contains @@ -195,12 +259,9 @@ end subroutine GFS_PBL_generic_post_init subroutine GFS_PBL_generic_post_finalize () end subroutine GFS_PBL_generic_post_finalize - -#if 0 !> \section arg_table_GFS_PBL_generic_post_run Argument Table !! \htmlinclude GFS_PBL_generic_post_run.html !! -#endif subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, & trans_aero, ntchs, ntchm, & @@ -213,7 +274,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dq3dt_ozone, rd, cp,fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, fice, dusfc_cice, dvsfc_cice, dtsfc_cice, & dqsfc_cice, wet, dry, icy, wind, stress_ocn, hflx_ocn, evap_ocn, ugrs1, vgrs1, dkt_cpl, dkt, errmsg, errflg) - use machine, only: kind_phys + use machine, only : kind_phys + use GFS_PBL_generic_common, only : set_aerosol_tracer_index implicit none @@ -490,57 +552,4 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, end subroutine GFS_PBL_generic_post_run - - subroutine set_aerosol_tracer_index(imp_physics, imp_physics_wsm6, & - imp_physics_thompson, ltaerosol, & - imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr, kk, & - errmsg, errflg) - implicit none - ! - integer, intent(in ) :: imp_physics, imp_physics_wsm6, & - imp_physics_thompson, & - imp_physics_mg, ntgl, imp_physics_gfdl, & - imp_physics_zhao_carr - logical, intent(in ) :: ltaerosol - integer, intent(out) :: kk - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errflg = 0 - -! Set Interstitial%kk = last index in diffused tracer array before chemistry-aerosol tracers - if (imp_physics == imp_physics_wsm6) then -! WSM6 - kk = 4 - elseif (imp_physics == imp_physics_thompson) then -! Thompson - if(ltaerosol) then - kk = 10 - else - kk = 7 - endif -! MG - elseif (imp_physics == imp_physics_mg) then - if (ntgl > 0) then - kk = 12 - else - kk = 10 - endif - elseif (imp_physics == imp_physics_gfdl) then -! GFDL MP - kk = 7 - elseif (imp_physics == imp_physics_zhao_carr) then -! Zhao/Carr/Sundqvist - kk = 3 - else - write(errmsg,'(*(a))') 'Logic error: unknown microphysics option in set_aerosol_tracer_index' - kk = -999 - errflg = 1 - return - endif - - end subroutine set_aerosol_tracer_index - - end module GFS_PBL_generic_post From cb60e202f45f716acef551cef8096e64373c7527 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 8 Oct 2019 21:14:10 +0000 Subject: [PATCH 46/59] Added semi-implicit time differencing for turbulent form drag and small-scale gravity wave drag schemes -- allows for longer time step --- physics/drag_suite.F90 | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 56902c631..eb371adb1 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -485,7 +485,7 @@ subroutine drag_suite_run( & varmax_fd = 150., & beta_ss = 0.1, & beta_fd = 0.2 - real(kind=kind_phys) :: var_temp + real(kind=kind_phys) :: var_temp, var_temp2 ! added Beljaars orographic form drag real(kind=kind_phys), dimension(im,km) :: utendform,vtendform @@ -1060,7 +1060,9 @@ subroutine drag_suite_run( & !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) var_temp = MIN(varss(i),varmax_ss) + & MAX(0.,beta_ss*(varss(i)-varmax_ss)) - tauwavex0=0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar)*u1(i,kvar) + ! Note: This is a semi-implicit treatment of the time differencing + var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero + tauwavex0=-var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) tauwavex0=tauwavex0*ss_taper else tauwavex0=0. @@ -1073,7 +1075,8 @@ subroutine drag_suite_run( & !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) var_temp = MIN(varss(i),varmax_ss) + & MAX(0.,beta_ss*(varss(i)-varmax_ss)) - tauwavey0=0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar)*v1(i,kvar) + ! Note: This is a semi-implicit treatment of the time differencing + tauwavey0=-var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) tauwavey0=tauwavey0*ss_taper else tauwavey0=0. @@ -1154,10 +1157,12 @@ subroutine drag_suite_run( & DO k=kts,km wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - utendform(i,k)=-0.0759*wsp*u1(i,k)* & - EXP(-(zl(i,k)/H_efold)**1.5)*a2*zl(i,k)**(-1.2)*ss_taper - vtendform(i,k)=-0.0759*wsp*v1(i,k)* & - EXP(-(zl(i,k)/H_efold)**1.5)*a2*zl(i,k)**(-1.2)*ss_taper + var_temp = 0.0759*EXP(-(zl(i,k)/H_efold)**1.5)*a2* & + zl(i,k)**(-1.2)*ss_taper ! this is greater than zero + ! Note: This is a semi-implicit treatment of the time differencing + ! per Beljaars et al. (2004, QJRMS) + utendform(i,k) = - var_temp*wsp*u1(i,k)/(1. + var_temp*deltim*wsp) + vtendform(i,k) = - var_temp*wsp*v1(i,k)/(1. + var_temp*deltim*wsp) !IF(zl(i,k) > 4000.) exit ENDDO ENDIF From b1d5f4cb820dc41ae7add8c659f65bba3688cd90 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Tue, 8 Oct 2019 22:13:43 +0000 Subject: [PATCH 47/59] Added sea_land_ice mask to the parameter list in sfc_drv_ruc. It will be used in the check for consistency of land information. --- physics/sfc_drv_ruc.F90 | 5 +++-- physics/sfc_drv_ruc.meta | 8 ++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 61246b67d..a16cfc334 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -143,7 +143,7 @@ subroutine lsm_ruc_run & ! inputs & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & & prsl1, zf, ddvel, shdmin, shdmax, alvwf, alnwf, & & snoalb, sfalb, flag_iter, flag_guess, isot, ivegsrc, fice, & - & smc, stc, slc, lsm_ruc, lsm, land, & + & smc, stc, slc, lsm_ruc, lsm, land, islimsk, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & smcwlt2, smcref2, wspd, do_mynnsfclay, & & con_cp, con_rv, con_rd, con_g, con_pi, con_hvap, con_fvirt,& ! constants @@ -184,6 +184,7 @@ subroutine lsm_ruc_run & ! inputs con_hvap, con_fvirt logical, dimension(im), intent(in) :: flag_iter, flag_guess, land + integer, dimension(im), intent(in) :: islimsk ! sea/land/ice mask (=0/1/2) logical, intent(in) :: do_mynnsfclay ! --- in/out: @@ -384,7 +385,7 @@ subroutine lsm_ruc_run & ! inputs !> - Set flag for land and ice points. !- 10may19 - ice points are turned off. flag(i) = land(i) - if (land(i) .and. (vegtype(i)==iswater .or. vegtype(i)==isice)) then + if (land(i) .and. (vegtype(i)==iswater .or. (vegtype(i)==isice.and.islimsk(i)==2))) then !write(errmsg,'(a,i0,a,i0)') 'Logic error in sfc_drv_ruc_run: for i=', i, & ! ', land(i) is true but vegtype(i) is water or ice: ', vegtype(i) !errflg = 1 diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 8d06e4785..8128a03dd 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -278,6 +278,14 @@ type = logical intent = in optional = F +[islimsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F [rainnc] standard_name = lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep long_name = explicit rainfall from previous timestep From 86e06dfdad6661a0b204f56a45618f32ac49a5ae Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 9 Oct 2019 07:31:16 +0900 Subject: [PATCH 48/59] physics/GFS_surface_composites.{F90,meta}: create new interstitial scheme GFS_surface_composites_inter that needs to run after dcyc2t3 and before the surface (land, ocean, ice) schemes --- physics/GFS_surface_composites.F90 | 74 ++++++++++++++---- physics/GFS_surface_composites.meta | 117 +++++++++++++++++++++++----- 2 files changed, 158 insertions(+), 33 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 4a0ed7d6c..539d9579a 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -22,20 +22,17 @@ end subroutine GFS_surface_composites_pre_init subroutine GFS_surface_composites_pre_finalize() end subroutine GFS_surface_composites_pre_finalize -#if 0 !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! -#endif subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, landfrac, lakefrac, oceanfrac, & frland, dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorl_ocn, & zorl_lnd, zorl_ice, snowd, snowd_ocn, snowd_lnd, snowd_ice, tprcp, tprcp_ocn, & tprcp_lnd, tprcp_ice, uustar, uustar_lnd, uustar_ice, weasd, weasd_ocn, & weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_ocn, tsfc_lnd, & tsfc_ice, tisfc, tice, tsurf, tsurf_ocn, tsurf_lnd, tsurf_ice, gflx_ice, & - tgice, islmsk, semis_rad, semis_ocn, semis_lnd, semis_ice, adjsfcdlw, & - gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_ocn, min_lakeice, min_seaice, & - errmsg, errflg) + tgice, islmsk, semis_rad, semis_ocn, semis_lnd, semis_ice, & + min_lakeice, min_seaice, errmsg, errflg) implicit none @@ -57,9 +54,8 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, lan real(kind=kind_phys), dimension(im), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice integer, dimension(im), intent(in ) :: islmsk - real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad, adjsfcdlw + real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad real(kind=kind_phys), dimension(im), intent(inout) :: semis_ocn, semis_lnd, semis_ice - real(kind=kind_phys), dimension(im), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_ocn real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice ! CCPP error handling @@ -180,7 +176,60 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, lan end if enddo - ! --- convert lw fluxes for land/ocean/sea-ice models + ! Assign sea ice temperature to interstitial variable + do i = 1, im + tice(i) = tisfc(i) + end do + + end subroutine GFS_surface_composites_pre_run + +end module GFS_surface_composites_pre + + +module GFS_surface_composites_inter + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_composites_inter_init, GFS_surface_composites_inter_finalize, GFS_surface_composites_inter_run + +contains + + subroutine GFS_surface_composites_inter_init () + end subroutine GFS_surface_composites_inter_init + + subroutine GFS_surface_composites_inter_finalize() + end subroutine GFS_surface_composites_inter_finalize + +!> \section arg_table_GFS_surface_composites_inter_run Argument Table +!! \htmlinclude GFS_surface_composites_inter_run.html +!! + subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_ocn, semis_lnd, semis_ice, adjsfcdlw, & + gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_ocn, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: im + logical, dimension(im), intent(in ) :: dry, icy, wet + real(kind=kind_phys), dimension(im), intent(in ) :: semis_ocn, semis_lnd, semis_ice, adjsfcdlw + real(kind=kind_phys), dimension(im), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_ocn + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! --- convert lw fluxes for land/ocean/sea-ice models - requires dcyc2t3 to set adjsfcdlw ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. @@ -203,14 +252,9 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, lan if (wet(i)) gabsbdlw_ocn(i) = semis_ocn(i) * adjsfcdlw(i) enddo - ! Assign sea ice temperature to interstitial variable - do i = 1, im - tice(i) = tisfc(i) - end do - - end subroutine GFS_surface_composites_pre_run + end subroutine GFS_surface_composites_inter_run -end module GFS_surface_composites_pre +end module GFS_surface_composites_inter module GFS_surface_composites_post diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index d06cedf90..74c6b9575 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -495,6 +495,105 @@ kind = kind_phys intent = inout optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = ??? + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = ??? + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_inter_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[semis_ocn] + standard_name = surface_longwave_emissivity_over_ocean_interstitial + long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[semis_lnd] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[semis_ice] + standard_name = surface_longwave_emissivity_over_ice_interstitial + long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [adjsfcdlw] standard_name = surface_downwelling_longwave_flux long_name = surface downwelling longwave flux at current time @@ -531,24 +630,6 @@ kind = kind_phys intent = inout optional = F -[min_lakeice] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = ??? - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = ??? - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From c0a7aeed764f0536078dc2269aed1b22cfd0c7f0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 9 Oct 2019 07:32:46 +0900 Subject: [PATCH 49/59] physics/cires_ugwp_post.{F90,meta}: add missing block to save diagnostic output variables --- physics/cires_ugwp_post.F90 | 55 +++++++++++++++++-------- physics/cires_ugwp_post.meta | 79 ++++++++++++++++++++++++++++++++++++ 2 files changed, 116 insertions(+), 18 deletions(-) diff --git a/physics/cires_ugwp_post.F90 b/physics/cires_ugwp_post.F90 index 20be1fe74..72f59a6c5 100755 --- a/physics/cires_ugwp_post.F90 +++ b/physics/cires_ugwp_post.F90 @@ -25,7 +25,8 @@ subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & tot_zmtb, tot_zlwb, tot_zogw, & tot_tofd, tot_mtb, tot_ogw, tot_ngw, & du3dt_mtb,du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw, & - dtdt, dudt, dvdt, errmsg, errflg) + dtdt, dudt, dvdt, lssav, ldiag3d, dusfcg, dvsfcg, dugwd, & + dvgwd, du3dt, dv3dt, dt3dt, errmsg, errflg) use machine, only: kind_phys @@ -44,6 +45,12 @@ subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & real(kind=kind_phys), intent(inout), dimension(im, levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw real(kind=kind_phys), intent(inout), dimension(im, levs) :: dtdt, dudt, dvdt + ! For if (lssav) block, originally in gwdps_post_run + logical, intent(in) :: lssav, ldiag3d + real(kind=kind_phys), intent(in), dimension(im) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(inout), dimension(im) :: dugwd, dvgwd + real(kind=kind_phys), intent(inout), dimension(im, levs) :: du3dt, dv3dt, dt3dt + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -52,25 +59,37 @@ subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & errflg = 0 if (ldiag_ugwp) then - tot_zmtb = tot_zmtb + dtf *zmtb - tot_zlwb = tot_zlwb + dtf *zlwb - tot_zogw = tot_zogw + dtf *zogw + tot_zmtb = tot_zmtb + dtf *zmtb + tot_zlwb = tot_zlwb + dtf *zlwb + tot_zogw = tot_zogw + dtf *zogw - tot_tofd = tot_tofd + dtf *tau_tofd - tot_mtb = tot_mtb + dtf *tau_mtb - tot_ogw = tot_ogw + dtf *tau_ogw - tot_ngw = tot_ngw + dtf *tau_ngw + tot_tofd = tot_tofd + dtf *tau_tofd + tot_mtb = tot_mtb + dtf *tau_mtb + tot_ogw = tot_ogw + dtf *tau_ogw + tot_ngw = tot_ngw + dtf *tau_ngw - du3dt_mtb = du3dt_mtb + dtf *dudt_mtb - du3dt_tms = du3dt_tms + dtf *dudt_tms - du3dt_ogw = du3dt_ogw + dtf *dudt_ogw - du3dt_ngw = du3dt_ngw + dtf *gw_dudt - dv3dt_ngw = dv3dt_ngw + dtf *gw_dvdt - endif - - dtdt = dtdt + gw_dtdt - dudt = dudt + gw_dudt - dvdt = dvdt + gw_dvdt + du3dt_mtb = du3dt_mtb + dtf *dudt_mtb + du3dt_tms = du3dt_tms + dtf *dudt_tms + du3dt_ogw = du3dt_ogw + dtf *dudt_ogw + du3dt_ngw = du3dt_ngw + dtf *gw_dudt + dv3dt_ngw = dv3dt_ngw + dtf *gw_dvdt + endif + + dtdt = dtdt + gw_dtdt + dudt = dudt + gw_dudt + dvdt = dvdt + gw_dvdt + + ! Originally in gwdps_post_run + if (lssav) then + dugwd(:) = dugwd(:) + dusfcg(:)*dtf + dvgwd(:) = dvgwd(:) + dvsfcg(:)*dtf + + if (ldiag3d) then + du3dt(:,:) = du3dt(:,:) + dudt(:,:) * dtf + dv3dt(:,:) = dv3dt(:,:) + dvdt(:,:) * dtf + dt3dt(:,:) = dt3dt(:,:) + dtdt(:,:) * dtf + endif + endif end subroutine cires_ugwp_post_run diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 1f98aa8a4..980e99a65 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -291,6 +291,85 @@ kind = kind_phys intent = inout optional = F +[lssav] + standard_name = flag_diagnostics + long_name = flag for calculating diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for calculating 3-D diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dugwd] + standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag + long_name = integral over time of zonal stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvgwd] + standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag + long_name = integral over time of meridional stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in zonal wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dv3dt] + standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in meridional wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt] + standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag + long_name = cumulative change in temperature due to orographic gravity wave drag + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 325f9b1f721ab712d3687d304edd804e7cca1489 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 28 Aug 2019 18:39:39 -0600 Subject: [PATCH 50/59] Modifications of CMakeLists.txt to support out-of-source builds, required for parallel cmake builds in NEMSfv3gfs --- CMakeLists.txt | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bfcceebc6..5000bd62a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -97,9 +97,23 @@ list(APPEND LIBS "ccpp") #------------------------------------------------------------------------------ # Set the sources: physics schemes -include(./CCPP_SCHEMES.cmake) +set(SCHEMES $ENV{CCPP_SCHEMES}) +if(SCHEMES) + message(INFO "Got CCPP_SCHEMES from environment variable: ${SCHEMES}") +else(SCHEMES) + include(./CCPP_SCHEMES.cmake) + message(INFO "Got SCHEMES from cmakefile include file: ${SCHEMES}") +endif(SCHEMES) + # Set the sources: physics scheme caps -include(./CCPP_CAPS.cmake) +set(CAPS $ENV{CCPP_CAPS}) +if(CAPS) + message(INFO "Got CAPS from environment variable: ${CAPS}") +else(CAPS) + include(./CCPP_CAPS.cmake) + message(INFO "Got CAPS from cmakefile include file: ${CAPS}") +endif(CAPS) + # Create empty lists for schemes with special compiler optimization flags set(SCHEMES_SFX_OPT "") # Create empty lists for schemes with special floating point precision flags @@ -334,7 +348,7 @@ if(STATIC) foreach(source_f90 ${CAPS}) string(REGEX REPLACE ".F90" ".mod" tmp_module_f90 ${source_f90}) string(TOLOWER ${tmp_module_f90} module_f90) - list(APPEND MODULES_F90 ${CMAKE_CURRENT_BINARY_DIR}/../${module_f90}) + list(APPEND MODULES_F90 ${CMAKE_CURRENT_BINARY_DIR}/${module_f90}) endforeach() else(STATIC) add_library(ccppphys SHARED ${SCHEMES} ${SCHEMES_SFX_OPT} ${CAPS}) From d9d0ff01efe3bf6c8f6b080c7672ce7d0724e7a0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 10 Oct 2019 08:43:53 +0900 Subject: [PATCH 51/59] physics/sfc_noahmp_drv.meta: bugfix, use interstitial variables over land for surface lw emissivity and total sky surface downward longwave flux absorbed by the ground --- physics/sfc_noahmp_drv.meta | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index bcca166d0..066bc1e87 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -150,22 +150,22 @@ intent= in optional = F [sfcemis] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) units = frac dimensions = (horizontal_dimension) type = real kind = kind_phys - intent= in + intent = in optional = F [dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground - long_name = total sky surface downward longwave flux absorbed by the ground + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land units = W m-2 dimensions = (horizontal_dimension) type = real kind = kind_phys - intent= in + intent = in optional = F [dswsfc] standard_name = surface_downwelling_shortwave_flux From 4b840ffd114510ab038b2133dddb0309ec1711fb Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 10 Oct 2019 11:00:41 +0900 Subject: [PATCH 52/59] physics/GFS_surface_composites.F90: bugfix for surface temperature assignments over land/ocean in GFS_surface_composites_post_run --- physics/GFS_surface_composites.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 539d9579a..cd5f3db11 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -424,7 +424,7 @@ subroutine GFS_surface_composites_post_run ( fm10(i) = fm10_lnd(i) fh2(i) = fh2_lnd(i) !tsurf(i) = tsurf_lnd(i) - tsfcl(i) = tsurf_lnd(i) + tsfcl(i) = tsfc_lnd(i) cmm(i) = cmm_lnd(i) chh(i) = chh_lnd(i) gflx(i) = gflx_lnd(i) @@ -450,7 +450,7 @@ subroutine GFS_surface_composites_post_run ( fm10(i) = fm10_ocn(i) fh2(i) = fh2_ocn(i) !tsurf(i) = tsurf_ocn(i) - tsfco(i) = tsurf_ocn(i) + tsfco(i) = tsfc_ocn(i) cmm(i) = cmm_ocn(i) chh(i) = chh_ocn(i) gflx(i) = gflx_ocn(i) From 7fbe839a6b515ec14b16bd84dbfbf3a3fdbbff3f Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 10 Oct 2019 19:26:03 +0000 Subject: [PATCH 53/59] Bug fix in the unit conversion from [mm] to [m] for liquid rain. --- physics/mp_thompson.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 3b2da9c3e..812229f98 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -395,7 +395,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & graupel = max(0.0, delta_graupel_mp/1000.0_kind_phys) ice = max(0.0, delta_ice_mp/1000.0_kind_phys) snow = max(0.0, delta_snow_mp/1000.0_kind_phys) - rain = max(0.0, delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp)/1000.0_kind_phys) + rain = max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) end subroutine mp_thompson_run !>@} From 15de364a567b1604348e876daf474e5a148682f7 Mon Sep 17 00:00:00 2001 From: tanyasmirnova Date: Thu, 10 Oct 2019 20:08:11 +0000 Subject: [PATCH 54/59] Use fraction of frozen precipitation SR, computed in GFDL or Thompson microphysics, directly without recomputing it with taking into account temperature-based treatment of convective precipitation. This change will affect only use of RUC LSM with GFDL or Thompson microphysics. --- physics/GFS_MP_generic.F90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index b83f592f2..91d29c0f3 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -270,7 +270,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt enddo enddo - ! Conversion factor mm per physics timestep to m per day + ! Conversion factor from mm per day to m per physics timestep tem = dtp * con_p001 / con_day !> - For GFDL and Thompson MP scheme, determine convective snow by surface temperature; @@ -280,6 +280,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP + + if (lsm/=lsm_ruc) then do i = 1, im !tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp ! DH now lines 245-250 srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) @@ -300,6 +302,14 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt srflag(i) = (snow0(i)+ice0(i)+graupel0(i)+csnow)/total_precip endif enddo + else + ! only for RUC LSM + do i=1,im + srflag(i) = sr(i) + !if(sr(i) > 0.) print *,'RUC LSM uses SR from MP - srflag(i)',i,srflag(i) + enddo + endif ! lsm==lsm_ruc + elseif( .not. cal_pre) then if (imp_physics == imp_physics_mg) then ! MG microphysics do i=1,im From 57e5c6960295f187ccc573b9fa4a8edaab8e2968 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sun, 13 Oct 2019 14:57:54 +0900 Subject: [PATCH 55/59] physics/cires_ugwp_post.F90: use assumed-size arrays for arrays that may not be allocated --- physics/cires_ugwp_post.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/physics/cires_ugwp_post.F90 b/physics/cires_ugwp_post.F90 index 72f59a6c5..70a7d602d 100755 --- a/physics/cires_ugwp_post.F90 +++ b/physics/cires_ugwp_post.F90 @@ -37,19 +37,19 @@ subroutine cires_ugwp_post_run (ldiag_ugwp, dtf, im, levs, & real(kind=kind_phys), intent(in) :: dtf logical, intent(in) :: ldiag_ugwp !< flag for CIRES UGWP Diagnostics - real(kind=kind_phys), intent(in), dimension(im) :: zmtb, zlwb, zogw - real(kind=kind_phys), intent(in), dimension(im) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw - real(kind=kind_phys), intent(inout), dimension(im) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw - real(kind=kind_phys), intent(inout), dimension(im) :: tot_zmtb, tot_zlwb, tot_zogw - real(kind=kind_phys), intent(in), dimension(im, levs) :: gw_dtdt, gw_dudt, gw_dvdt, dudt_mtb, dudt_ogw, dudt_tms - real(kind=kind_phys), intent(inout), dimension(im, levs) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw - real(kind=kind_phys), intent(inout), dimension(im, levs) :: dtdt, dudt, dvdt + real(kind=kind_phys), intent(in), dimension(:) :: zmtb, zlwb, zogw + real(kind=kind_phys), intent(in), dimension(:) :: tau_mtb, tau_ogw, tau_tofd, tau_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_mtb, tot_ogw, tot_tofd, tot_ngw + real(kind=kind_phys), intent(inout), dimension(:) :: tot_zmtb, tot_zlwb, tot_zogw + real(kind=kind_phys), intent(in), dimension(:,:) :: gw_dtdt, gw_dudt, gw_dvdt, dudt_mtb, dudt_ogw, dudt_tms + real(kind=kind_phys), intent(inout), dimension(:,:) :: du3dt_mtb, du3dt_ogw, du3dt_tms, du3dt_ngw, dv3dt_ngw + real(kind=kind_phys), intent(inout), dimension(:,:) :: dtdt, dudt, dvdt ! For if (lssav) block, originally in gwdps_post_run logical, intent(in) :: lssav, ldiag3d - real(kind=kind_phys), intent(in), dimension(im) :: dusfcg, dvsfcg - real(kind=kind_phys), intent(inout), dimension(im) :: dugwd, dvgwd - real(kind=kind_phys), intent(inout), dimension(im, levs) :: du3dt, dv3dt, dt3dt + real(kind=kind_phys), intent(in), dimension(:) :: dusfcg, dvsfcg + real(kind=kind_phys), intent(inout), dimension(:) :: dugwd, dvgwd + real(kind=kind_phys), intent(inout), dimension(:,:) :: du3dt, dv3dt, dt3dt character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg From 81e02a74d87fd1d9674fc08d112b6334d3557d34 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 14 Oct 2019 07:13:27 +0900 Subject: [PATCH 56/59] physics/gwdps.f: remove note that adding intent(in) for certain variables changes the results, this is only true in (CCPP) PROD mode, not in REPRO mode --- physics/gwdps.f | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/physics/gwdps.f b/physics/gwdps.f index d5e34a04a..0ea2c8754 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -299,12 +299,8 @@ subroutine gwdps_run( & ! Interface variables integer, intent(in) :: im, ix, km, imx, kdt, ipr, me integer, intent(in) :: KPBL(IM) ! Index for the PBL top layer! - ! DH* adding intent(in) information for the following variables - ! changes the results on Theia/Intel - skip for bit-for-bit results *DH -! real(kind=kind_phys), intent(in) :: & -! & deltim, G, CP, RD, RV, cdmbgwd(2) - real(kind=kind_phys) deltim, G, CP, RD, RV, cdmbgwd(4) - ! *DH + real(kind=kind_phys), intent(in) :: & + & deltim, G, CP, RD, RV, cdmbgwd(4) real(kind=kind_phys), intent(inout) :: & & A(IX,KM), B(IX,KM), C(IX,KM) real(kind=kind_phys), intent(in) :: & From d139dbbbc12e8e439e8f42e5323378a662efc964 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 18 Oct 2019 09:54:35 +0900 Subject: [PATCH 57/59] physics/sfc_drv_ruc.*: update for GFSv16 --- physics/sfc_drv_ruc.F90 | 24 ++++++++---------------- physics/sfc_drv_ruc.meta | 37 +++++-------------------------------- 2 files changed, 13 insertions(+), 48 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index a16cfc334..fe12b5e17 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -69,7 +69,6 @@ end subroutine lsm_ruc_finalize ! im - integer, horiz dimention and num of used pts 1 ! ! km - integer, vertical soil layer dimension 9 ! ! ps - real, surface pressure (pa) im ! -! u1, v1 - real, u/v component of surface layer wind im ! ! t1 - real, surface layer mean temperature (k) im ! ! q1 - real, surface layer mean specific humidity im ! ! soiltyp - integer, soil type (integer index) im ! @@ -86,6 +85,7 @@ end subroutine lsm_ruc_finalize ! prsl1 - real, sfc layer 1 mean pressure (pa) im ! ! prslki - real, dimensionless exner function at layer 1 im ! ! zf - real, height of bottom layer (m) im ! +! wind real, surface layer wind speed (m/s) im ! ! slopetyp - integer, class of sfc slope (integer index) im ! ! shdmin - real, min fractional coverage of green veg im ! ! shdmax - real, max fractnl cover of green veg (not used) im ! @@ -139,13 +139,13 @@ end subroutine lsm_ruc_finalize ! DH* TODO - make order of arguments the same as in the metadata table subroutine lsm_ruc_run & ! inputs & ( iter, me, master, kdt, im, nlev, lsoil_ruc, lsoil, zs, & - & u1, v1, t1, q1, qc, soiltyp, vegtype, sigmaf, & + & t1, q1, qc, soiltyp, vegtype, sigmaf, & & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - & prsl1, zf, ddvel, shdmin, shdmax, alvwf, alnwf, & + & prsl1, zf, wind, shdmin, shdmax, alvwf, alnwf, & & snoalb, sfalb, flag_iter, flag_guess, isot, ivegsrc, fice, & & smc, stc, slc, lsm_ruc, lsm, land, islimsk, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & - & smcwlt2, smcref2, wspd, do_mynnsfclay, & + & smcwlt2, smcref2, do_mynnsfclay, & & con_cp, con_rv, con_rd, con_g, con_pi, con_hvap, con_fvirt,& ! constants & weasd, snwdph, tskin, tskin_ocn, & ! in/outs & rainnc, rainc, ice, snow, graupel, & ! in @@ -173,10 +173,10 @@ subroutine lsm_ruc_run & ! inputs real (kind=kind_phys), dimension(im,lsoil), intent(inout) :: smc,stc,slc - real (kind=kind_phys), dimension(im), intent(in) :: u1, v1,& + real (kind=kind_phys), dimension(im), intent(in) :: & & t1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & - & ch, prsl1, ddvel, shdmin, shdmax, & - & snoalb, alvwf, alnwf, zf, qc, q1, wspd + & ch, prsl1, wind, shdmin, shdmax, & + & snoalb, alvwf, alnwf, zf, qc, q1 real (kind=kind_phys), intent(in) :: delt real (kind=kind_phys), intent(in) :: con_cp, con_rv, con_g, & @@ -216,7 +216,7 @@ subroutine lsm_ruc_run & ! inputs ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & - & q0, qs1, wind, weasd_old, snwdph_old, & + & q0, qs1, weasd_old, snwdph_old, & & tprcp_old, srflag_old, tskin_old, canopy_old, & & tsnow_old, snowfallac_old, acsnow_old, sfalb_old, & & sfcqv_old, sfcqc_old, wetness_old, zorl_old, sncovr1_old @@ -472,15 +472,7 @@ subroutine lsm_ruc_run & ! inputs do i = 1, im if (flag_iter(i) .and. flag(i)) then - !if (do_mynnsfclay) then - ! WARNING - used of wspd computed in MYNN sfc leads to massive cooling. - ! wind(i) = wspd(i) - !else - wind(i) = max(sqrt( u1(i)*u1(i) + v1(i)*v1(i) ) & - + max(0.0, min(ddvel(i), 30.0)), 1.0) - !endif q0(i) = max(q1(i)/(1.-q1(i)), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) - rho(i) = prsl1(i) / (con_rd*t1(i)*(1.0+con_fvirt*q0(i))) qs1(i) = rslf(prsl1(i),t1(i)) !* qs1=sat. mixing ratio at level 1 (kg/kg) q0 (i) = min(qs1(i), q0(i)) diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 8128a03dd..dac459405 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -385,24 +385,6 @@ kind = kind_phys intent = in optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer - long_name = zonal wind at lowest model layer - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer - long_name = meridional wind at lowest model layer - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F [prsl1] standard_name = air_pressure_at_lowest_model_layer long_name = mean pressure at lowest model layer @@ -412,9 +394,9 @@ kind = kind_phys intent = in optional = F -[ddvel] - standard_name = surface_wind_enhancement_due_to_convection - long_name = surface wind enhancement due to convection +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level units = m s-1 dimensions = (horizontal_dimension) type = real @@ -476,23 +458,14 @@ intent = in optional = F [sfcemis] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) units = frac dimensions = (horizontal_dimension) type = real kind = kind_phys intent = inout optional = F -[wspd] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [cm] standard_name = surface_drag_coefficient_for_momentum_in_air_over_land long_name = surface exchange coeff for momentum over land From 3bb41d618ac5fca641a6b93150626e4a4c2c7372 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 22 Oct 2019 06:29:34 +0900 Subject: [PATCH 58/59] Add / prefix to all source files --- CMakeLists.txt | 132 +++++++++++++++++++++++++++++++------------------ 1 file changed, 85 insertions(+), 47 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 5000bd62a..531230328 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -123,12 +123,25 @@ set(SCHEMES2 ${SCHEMES}) #------------------------------------------------------------------------------ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffree-line-length-none") - SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -fdefault-real-8) - SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_model.f90 ./physics/calpreciptype.f90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -ffree-form") - SET_SOURCE_FILES_PROPERTIES(./physics/mersenne_twister.f PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fno-range-check") - SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-ffree-line-length-none -fdefault-real-8 -ffree-form") - SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") - SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_bfmicrophysics.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sflx.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diff.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diag.f + PROPERTIES COMPILE_FLAGS -fdefault-real-8) + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_model.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/calpreciptype.f90 + PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -ffree-form") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/mersenne_twister.f + PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fno-range-check") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_water_prop.f90 + PROPERTIES COMPILE_FLAGS "-ffree-line-length-none -fdefault-real-8 -ffree-form") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/aer_cloud.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/wv_saturation.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/cldwat2m_micro.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/surface_perturbation.F90 + PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_mp_thompson_make_number_concentrations.F90 + PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") if (PROJECT STREQUAL "CCPP-FV3") # Set 32-bit floating point precision flags for certain files @@ -140,10 +153,10 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") CMAKE_Fortran_FLAGS_PREC32 "${CMAKE_Fortran_FLAGS_PREC32}") string(REPLACE "-fdefault-double-8" "" CMAKE_Fortran_FLAGS_PREC32 "${CMAKE_Fortran_FLAGS_PREC32}") - SET_PROPERTY(SOURCE ./physics/gfdl_fv_sat_adj.F90 + SET_PROPERTY(SOURCE ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PREC32} ") # Add all of the above files to the list of schemes with special floating point precision flags - list(APPEND SCHEMES_SFX_PREC ./physics/gfdl_fv_sat_adj.F90) + list(APPEND SCHEMES_SFX_PREC ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) endif (DYN32) # Remove files with special floating point precision flags from list @@ -159,28 +172,28 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Adjust settings for bit-for-bit reproducibility of NEMSfv3gfs if (PROJECT STREQUAL "CCPP-FV3") - SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f - ./physics/sflx.f - ./physics/sfc_diff.f - ./physics/sfc_diag.f - ./physics/module_nst_model.f90 - ./physics/calpreciptype.f90 - ./physics/mersenne_twister.f - ./physics/module_nst_water_prop.f90 - ./physics/aer_cloud.F - ./physics/wv_saturation.F - ./physics/cldwat2m_micro.F - ./physics/surface_perturbation.F90 - ./physics/radiation_aerosols.f - ./physics/cu_gf_deep.F90 - ./physics/cu_gf_sh.F90 - ./physics/module_bl_mynn.F90 - ./physics/module_MYNNPBL_wrapper.F90 - ./physics/module_sf_mynn.F90 - ./physics/module_MYNNSFC_wrapper.F90 - ./physics/module_MYNNrad_pre.F90 - ./physics/module_MYNNrad_post.F90 - ./physics/module_mp_thompson_make_number_concentrations.F90 + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_bfmicrophysics.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sflx.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diff.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diag.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_model.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/calpreciptype.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/mersenne_twister.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_water_prop.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/aer_cloud.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/wv_saturation.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/cldwat2m_micro.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/surface_perturbation.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/cu_gf_deep.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/cu_gf_sh.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_bl_mynn.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNPBL_wrapper.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNSFC_wrapper.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNrad_pre.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_MYNNrad_post.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8 -ftz") # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files @@ -194,10 +207,10 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") string(REPLACE "-axSSE4.2,AVX,CORE-AVX2,CORE-AVX512" "-axSSE4.2,AVX,CORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT1 "${CMAKE_Fortran_FLAGS_LOPT1}") - SET_SOURCE_FILES_PROPERTIES(./physics/radiation_aerosols.f + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT1}") # Add all of the above files to the list of schemes with special compiler flags - list(APPEND SCHEMES_SFX_OPT ./physics/radiation_aerosols.f) + list(APPEND SCHEMES_SFX_OPT ${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f) # Force consistent results of math calculations for MG microphysics; # in Debug/Bitforbit mode; without this flag, the results of the @@ -258,10 +271,10 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") set(CMAKE_Fortran_FLAGS_PREC32 ${CMAKE_Fortran_FLAGS_DEFAULT_PREC}) string(REPLACE "-real-size 64" "-real-size 32" CMAKE_Fortran_FLAGS_PREC32 "${CMAKE_Fortran_FLAGS_PREC32}") - SET_PROPERTY(SOURCE ./physics/gfdl_fv_sat_adj.F90 + SET_PROPERTY(SOURCE ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PREC32} ") # Add all of the above files to the list of schemes with special floating point precision flags - list(APPEND SCHEMES_SFX_PREC ./physics/gfdl_fv_sat_adj.F90) + list(APPEND SCHEMES_SFX_PREC ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) endif (DYN32) # Remove files with special floating point precision flags from list @@ -274,19 +287,44 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_DEFAULT_PREC} ") else (PROJECT STREQUAL "CCPP-FV3") - SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -r8) - SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_model.f90 ./physics/calpreciptype.f90 PROPERTIES COMPILE_FLAGS "-r8 -free") - SET_SOURCE_FILES_PROPERTIES(./physics/mersenne_twister.f PROPERTIES COMPILE_FLAGS "-r8 -ftz") - SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-extend-source 132 -r8 -free") - SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_bfmicrophysics.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sflx.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diff.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diag.f + PROPERTIES COMPILE_FLAGS -r8) + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_model.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/calpreciptype.f90 + PROPERTIES COMPILE_FLAGS "-r8 -free") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/mersenne_twister.f + PROPERTIES COMPILE_FLAGS "-r8 -ftz") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_water_prop.f90 + PROPERTIES COMPILE_FLAGS "-extend-source 132 -r8 -free") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/aer_cloud.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/wv_saturation.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/cldwat2m_micro.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/surface_perturbation.F90 + PROPERTIES COMPILE_FLAGS "-r8") endif (PROJECT STREQUAL "CCPP-FV3") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") - SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -r8) - SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_model.f90 ./physics/calpreciptype.f90 PROPERTIES COMPILE_FLAGS "-r8 -Mfree") - SET_SOURCE_FILES_PROPERTIES(./physics/mersenne_twister.f PROPERTIES COMPILE_FLAGS "-r8 -Mnofptrap") - SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-r8 -Mfree") - SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") - SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_bfmicrophysics.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sflx.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diff.f + ${CMAKE_CURRENT_SOURCE_DIR}/physics/sfc_diag.f + PROPERTIES COMPILE_FLAGS -r8) + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_model.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/physics/calpreciptype.f90 + PROPERTIES COMPILE_FLAGS "-r8 -Mfree") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/mersenne_twister.f + PROPERTIES COMPILE_FLAGS "-r8 -Mnofptrap") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_nst_water_prop.f90 + PROPERTIES COMPILE_FLAGS "-r8 -Mfree") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/aer_cloud.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/wv_saturation.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/cldwat2m_micro.F + ${CMAKE_CURRENT_SOURCE_DIR}/physics/surface_perturbation.F90 + PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_mp_thompson_make_number_concentrations.F90 + PROPERTIES COMPILE_FLAGS "-r8") if (PROJECT STREQUAL "CCPP-FV3") # Set 32-bit floating point precision flags for certain files # that are executed in the dynamics (fast physics part) @@ -295,10 +333,10 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") set(CMAKE_Fortran_FLAGS_PREC32 ${CMAKE_Fortran_FLAGS_DEFAULT_PREC}) string(REPLACE "-r8" "-r4" CMAKE_Fortran_FLAGS_PREC32 "${CMAKE_Fortran_FLAGS_PREC32}") - SET_PROPERTY(SOURCE ./physics/gfdl_fv_sat_adj.F90 + SET_PROPERTY(SOURCE ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PREC32} ") # Add all of the above files to the list of schemes with special floating point precision flags - list(APPEND SCHEMES_SFX_PREC ./physics/gfdl_fv_sat_adj.F90) + list(APPEND SCHEMES_SFX_PREC ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) endif (DYN32) # Remove files with special floating point precision flags from list From e1a33ba926460d35e0a68230bffe9c13c42cbbe5 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 22 Oct 2019 18:54:54 +0900 Subject: [PATCH 59/59] CMakeLists.txt: extract filename from full path for auto-generated caps for creatig list of Fortran module files to install (static build only) --- CMakeLists.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index ff8a7012d..b8d3c3e18 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -350,7 +350,8 @@ if(STATIC) add_library(ccppphys STATIC ${SCHEMES} ${SCHEMES_SFX_OPT} ${CAPS}) # Generate list of Fortran modules from defined sources foreach(source_f90 ${CAPS}) - string(REGEX REPLACE ".F90" ".mod" tmp_module_f90 ${source_f90}) + get_filename_component(tmp_source_f90 ${source_f90} NAME) + string(REGEX REPLACE ".F90" ".mod" tmp_module_f90 ${tmp_source_f90}) string(TOLOWER ${tmp_module_f90} module_f90) list(APPEND MODULES_F90 ${CMAKE_CURRENT_BINARY_DIR}/${module_f90}) endforeach()