From 71b8df2662cadbc9ab54fadc4ebb306508419216 Mon Sep 17 00:00:00 2001 From: Jerold Herwehe Date: Tue, 24 Jan 2023 15:41:09 -0500 Subject: [PATCH] Add the Pleim-Xiu (P-X) LSM scheme to MPAS-A This EPA_PXLSM commit will add the Pleim-Xiu land surface model (Pleim and Xiu, 1995; Xiu and Pleim, 2001; Pleim and Xiu, 2003) to MPAS-A as a new "config_lsm_scheme" option called "px". The PX LSM code (module_sf_pxlsm.F) and its associated data module (module_sf_pxlsm_data.F) were migrated from WRF-4.4.2 with only minor changes and have been generalized to work with either MPAS or WRF. The PX LSM utilizes MODIS leaf area index (LAI) and albedo data (Ran et al., 2015; Ran et al., 2016), as well as various soil characteristics, all aggregated from fractional land use (NLCD40 over CONUS with MODIS elsewhere) and soil textures. The PX LSM is normally used in conjunction with the ACM2 PBL and Pleim surface layer schemes for retrospective simulations, but will also work with other PBL and surface layer schemes. The PX LSM codes in this commit include the basic changes needed for adding this LSM, and require that the optional soil nudging be disabled. To maintain numerical stability for longer simulations, a subsequent PX LSM commit ("EPA_PXLSM_with_FDDA" branch) will include the additional codes for 3-D grid nudging FDDA needed when using soil nudging with the PX LSM (Pleim and Gilliam, 2009). Also refer to the PX LSM description in the WRF-ARW technical document available at https://opensky.ucar.edu/islandora/object/opensky:2898 for an overview of the physics behind this option. New files: src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm.F src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm_data.F Modified files: Makefile src/core_atmosphere/Registry.xml src/core_atmosphere/physics/mpas_atmphys_control.F src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F src/core_atmosphere/physics/mpas_atmphys_initialize_real.F src/core_atmosphere/physics/mpas_atmphys_manager.F src/core_atmosphere/physics/mpas_atmphys_update_surface.F src/core_atmosphere/physics/mpas_atmphys_vars.F src/core_atmosphere/physics/physics_wrf/Makefile src/core_init_atmosphere/Registry.xml src/core_init_atmosphere/mpas_init_atm_cases.F src/core_init_atmosphere/mpas_init_atm_core_interface.F src/core_init_atmosphere/mpas_init_atm_static.F src/core_init_atmosphere/mpas_init_atm_surface.F These EPA_PXLSM code changes to MPAS-A are based on the 12 December 2022 "develop" branch of MPAS v7.3. References: Pleim, J. E., and R. Gilliam, 2009: An indirect data assimilation scheme for deep soil temperature in the Pleim-Xiu land Surface model. J. Appl. Meteor. Climatol., 48, 13621376. https://doi.org/10.1175/2009jamc2053.1 Pleim, J. E., and A. Xiu, 1995: Development and testing of a surface flux and planetary boundary layer model for application in mesoscale models. J. Appl. Meteor. Climatol., 34, 1632. https://journals.ametsoc.org/view/journals/apme/34/1/1520-0450- 34_1_16.xml?rskey=jWu6i6&result=18 Pleim, J. E., and A. Xiu, 2003: Development of a land surface model. Part II: Data assimilation. J. Appl. Meteor., 42, 18111822. https://doi.org/10.1175/1520-0450(2003)042%3c1811:doalsm%3e2.0.co;2 Ran, L., R. Gilliam, F. S. Binkowski, A. Xiu, J. Pleim, and L. Band, 2015: Sensitivity of the WRF/CMAQ modeling system to MODIS LAI, FPAR, and albedo, J. Geophys. Res. Atmos., 120(16), 8491-8511. https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2015JD023424 Ran, L., J. Pleim, R. Gilliam, F. S. Binkowski, C. Hogrefe, and L. Band, 2016: Improved meteorology from an updated WRF/CMAQ modeling system with MODIS vegetation and albedo, J. Geophys. Res. Atmos., 121, 23932415. https://agupubs.onlinelibrary.wiley.com/doi/abs/10.1002/2015JD024406 Xiu, A., and J. E. Pleim, 2001: Development of a land-surface model. Part I: Application in a mesoscale meteorological model. J. Appl. Meteor., 42, 18111822. https://doi.org/10.1175/1520-0450(2001)040%3c0192:DOALSM%3e2.0.CO;2 --- Makefile | 12 +- src/core_atmosphere/Registry.xml | 186 +- .../physics/mpas_atmphys_control.F | 14 +- .../physics/mpas_atmphys_driver_lsm.F | 307 ++- .../physics/mpas_atmphys_initialize_real.F | 118 +- .../physics/mpas_atmphys_manager.F | 37 +- .../physics/mpas_atmphys_update_surface.F | 132 +- .../physics/mpas_atmphys_vars.F | 44 +- .../physics/physics_wrf/Makefile | 6 + .../physics/physics_wrf/module_sf_pxlsm.F | 2179 +++++++++++++++++ .../physics_wrf/module_sf_pxlsm_data.F | 639 +++++ src/core_init_atmosphere/Registry.xml | 220 +- .../mpas_init_atm_cases.F | 297 ++- .../mpas_init_atm_core_interface.F | 13 + .../mpas_init_atm_static.F | 484 +++- .../mpas_init_atm_surface.F | 361 ++- 16 files changed, 4895 insertions(+), 154 deletions(-) create mode 100644 src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm.F create mode 100644 src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm_data.F diff --git a/Makefile b/Makefile index 98a7d5ea75..0c63335207 100644 --- a/Makefile +++ b/Makefile @@ -300,11 +300,11 @@ intel-mpi: # BUILDTARGET Intel compiler suite with Intel MPI library "CC_SERIAL = icc" \ "CXX_SERIAL = icpc" \ "FFLAGS_PROMOTION = -real-size 64" \ - "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ - "CFLAGS_OPT = -O3" \ - "CXXFLAGS_OPT = -O3" \ + "FFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback -no-wrap-margin -convert big_endian -free -align array64byte" \ + "CFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback" \ + "CXXFLAGS_OPT = -O3 -xBROADWELL -fma -fp-model precise -traceback" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback -no-wrap-margin" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ @@ -660,7 +660,7 @@ ifneq "$(LAPACK)" "" endif RM = rm -f -CPP = cpp -P -traditional +CPP = ${CXX_SERIAL} -E # Modified for use with the Intel C++ compiler RANLIB = ranlib ifdef CORE @@ -875,7 +875,7 @@ ifeq "$(findstring clean, $(MAKECMDGOALS))" "clean" # CHECK FOR CLEAN TARGET override AUTOCLEAN=false endif # END OF CLEAN TARGET CHECK -VER=$(shell git describe --dirty 2> /dev/null) +VER="v7.3.develop.EPA_PXLSM" # Hard-coded specific version identifier #override CPPFLAGS += -DMPAS_GIT_VERSION=$(VER) ifeq "$(findstring v, $(VER))" "v" diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 9bbf8e5af5..8eca8f60d3 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -38,6 +38,10 @@ description="The number of months in a year"/> + + + + + + @@ -502,6 +510,7 @@ + @@ -715,6 +724,9 @@ + + + @@ -812,16 +824,20 @@ + + + + @@ -830,6 +846,12 @@ + + + + + + @@ -959,7 +981,9 @@ + + @@ -969,12 +993,15 @@ + + + @@ -1107,6 +1134,20 @@ #endif + + +#ifdef DO_PHYSICS + + + +#endif + + + description="number of soil layers used in land surface scheme" + possible_values="Positive integers; 4 for Noah LSM, 2 for PX LSM."/> + + + + + + + + + + + + + + + possible_values="`suite',`noah',`px',`off'"/> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -2802,7 +2946,7 @@ - + + + + @@ -3051,13 +3201,16 @@ + + - - - - + + @@ -3096,9 +3252,12 @@ - + + @@ -3120,6 +3279,15 @@ + + + + + + diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index 9b7a08c5e0..377a66f697 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -59,6 +59,8 @@ module mpas_atmphys_control ! Laura D. Fowler (laura@ucar.edu) / 2016-03-31. ! * added the options sf_mynn and bl_mynn and for the MYNN parameterization from WRF version 3.6.1. ! Laura D. Fowler (laura@ucar.edu) / 2016-04-11. +! * added Pleim-Xiu LSM scheme option px. +! Robert Gilliam (gilliam.robert@epa.gov) / 2016-09-19. ! * added the option cu_ntiedtke for the "new" Tiedtke parameterization of convection from WRF version 3.8.1. ! Laura D. Fowler (laura@ucar.edu) / 2016-09-19. ! * added the physics suite "convection_scale_aware" (see below for the physics options used in the suite). @@ -278,7 +280,8 @@ subroutine physics_namelist_check(configs) 'set config_sfclayer_scheme different than off') elseif(.not. (config_lsm_scheme .eq. 'off ' .or. & - config_lsm_scheme .eq. 'noah')) then + config_lsm_scheme .eq. 'noah' .or. & + config_lsm_scheme .eq. 'px')) then write(mpas_err_message,'(A,A10)') 'illegal value for land surface scheme: ', & trim(config_lsm_scheme) @@ -358,6 +361,15 @@ subroutine physics_registry_init(mesh,configs,sfc_input) dzs(4,iCell) = 1.00_RKIND enddo + case("px") + !initialize the thickness of the soil layers for the PX scheme: + do iCell = 1, nCells + if(landmask(iCell) == 1) then + dzs(1,iCell) = 0.01_RKIND + dzs(2,iCell) = 0.99_RKIND + endif + enddo + case default end select lsm_select diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index 6b431b3cc5..af89dcd9df 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -20,6 +20,7 @@ module mpas_atmphys_driver_lsm use module_sf_noahdrv use module_sf_noah_seaice_drv use module_sf_sfcdiags + use module_sf_pxlsm implicit none private @@ -93,6 +94,8 @@ module mpas_atmphys_driver_lsm ! * added call to seaice_noah to include the parameterization of seaice for the updated Noah land surface ! scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-19. +! * added MODIS LAI and vegetation fraction, plus soil type fraction, improvements to P-X LSM +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2018-08-28 ! ! DOCUMENTATION: @@ -121,6 +124,10 @@ subroutine allocate_lsm(config_frac_seaice) if(.not.allocated(smois_p) ) allocate(smois_p(ims:ime,1:num_soils,jms:jme) ) if(.not.allocated(tslb_p) ) allocate(tslb_p(ims:ime,1:num_soils,jms:jme) ) +!arrays for land use and soil type fractions + if(.not.allocated(landusef_p)) allocate(landusef_p(ims:ime,1:num_landu,jms:jme)) + if(.not.allocated(soiltypf_p)) allocate(soiltypf_p(ims:ime,1:num_soilc,jms:jme)) + !other arrays: if(.not.allocated(acsnom_p) ) allocate(acsnom_p(ims:ime,jms:jme) ) if(.not.allocated(acsnow_p) ) allocate(acsnow_p(ims:ime,jms:jme) ) @@ -162,6 +169,7 @@ subroutine allocate_lsm(config_frac_seaice) if(.not.allocated(snowc_p) ) allocate(snowc_p(ims:ime,jms:jme) ) if(.not.allocated(snowh_p) ) allocate(snowh_p(ims:ime,jms:jme) ) if(.not.allocated(sr_p) ) allocate(sr_p(ims:ime,jms:jme) ) + if(.not.allocated(sst_p) ) allocate(sst_p(ims:ime,jms:jme) ) if(.not.allocated(swdown_p) ) allocate(swdown_p(ims:ime,jms:jme) ) if(.not.allocated(tmn_p) ) allocate(tmn_p(ims:ime,jms:jme) ) if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) @@ -185,6 +193,35 @@ subroutine allocate_lsm(config_frac_seaice) if(.not.allocated(sfcheadrt_p) ) allocate(sfcheadrt_p(ims:ime,jms:jme) ) if(.not.allocated(soldrain_p) ) allocate(soldrain_p(ims:ime,jms:jme) ) +!additional arrays for px: + if(.not.allocated(mavail_p) ) allocate(mavail_p(ims:ime,jms:jme) ) + if(.not.allocated(hpbl_p) ) allocate(hpbl_p(ims:ime,jms:jme) ) + if(.not.allocated(rmol_p) ) allocate(rmol_p(ims:ime,jms:jme) ) + if(.not.allocated(ust_p) ) allocate(ust_p(ims:ime,jms:jme) ) + if(.not.allocated(ra_p) ) allocate(ra_p(ims:ime,jms:jme) ) + if(.not.allocated(rs_p) ) allocate(rs_p(ims:ime,jms:jme) ) + if(.not.allocated(psih_p) ) allocate(psih_p(ims:ime,jms:jme) ) + if(.not.allocated(imperv_p) ) allocate(imperv_p(ims:ime,jms:jme) ) + if(.not.allocated(canfra_p) ) allocate(canfra_p(ims:ime,jms:jme) ) + if(.not.allocated(vegpx_p) ) allocate(vegpx_p(ims:ime,jms:jme) ) + if(.not.allocated(lai_modis_p) ) allocate(lai_modis_p(ims:ime,jms:jme) ) + if(.not.allocated(lai_px_p) ) allocate(lai_px_p(ims:ime,jms:jme) ) + if(.not.allocated(wwlt_px_p) ) allocate(wwlt_px_p(ims:ime,jms:jme) ) + if(.not.allocated(wfc_px_p) ) allocate(wfc_px_p(ims:ime,jms:jme) ) + if(.not.allocated(wsat_px_p) ) allocate(wsat_px_p(ims:ime,jms:jme) ) + if(.not.allocated(clay_px_p) ) allocate(clay_px_p(ims:ime,jms:jme) ) + if(.not.allocated(csand_px_p) ) allocate(csand_px_p(ims:ime,jms:jme) ) + if(.not.allocated(fmsand_px_p) ) allocate(fmsand_px_p(ims:ime,jms:jme) ) + if(.not.allocated(t2anl_p) ) allocate(t2anl_p(ims:ime,jms:jme) ) + if(.not.allocated(t2anl1_p) ) allocate(t2anl1_p(ims:ime,jms:jme) ) + if(.not.allocated(t2anl2_p) ) allocate(t2anl2_p(ims:ime,jms:jme) ) + if(.not.allocated(rh2anl_p) ) allocate(rh2anl_p(ims:ime,jms:jme) ) + if(.not.allocated(rh2anl1_p) ) allocate(rh2anl1_p(ims:ime,jms:jme) ) + if(.not.allocated(rh2anl2_p) ) allocate(rh2anl2_p(ims:ime,jms:jme) ) + if(.not.allocated(snoanl_p) ) allocate(snoanl_p(ims:ime,jms:jme) ) + if(.not.allocated(snoanl1_p) ) allocate(snoanl1_p(ims:ime,jms:jme) ) + if(.not.allocated(snoanl2_p) ) allocate(snoanl2_p(ims:ime,jms:jme) ) + if(config_frac_seaice) then if(.not.allocated(tsk_sea) ) allocate(tsk_sea(ims:ime,jms:jme) ) if(.not.allocated(tsk_ice) ) allocate(tsk_ice(ims:ime,jms:jme) ) @@ -209,6 +246,10 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(smois_p) ) deallocate(smois_p ) if(allocated(tslb_p) ) deallocate(tslb_p ) +!arrays for land use and soil type fractions + if(allocated(landusef_p)) deallocate(landusef_p) + if(allocated(soiltypf_p)) deallocate(soiltypf_p) + !other arrays: if(allocated(acsnom_p) ) deallocate(acsnom_p ) if(allocated(acsnow_p) ) deallocate(acsnow_p ) @@ -250,6 +291,7 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(snowc_p) ) deallocate(snowc_p ) if(allocated(snowh_p) ) deallocate(snowh_p ) if(allocated(sr_p) ) deallocate(sr_p ) + if(allocated(sst_p) ) deallocate(sst_p ) if(allocated(swdown_p) ) deallocate(swdown_p ) if(allocated(tmn_p) ) deallocate(tmn_p ) if(allocated(tsk_p) ) deallocate(tsk_p ) @@ -273,6 +315,35 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(sfcheadrt_p) ) deallocate(sfcheadrt_p ) if(allocated(soldrain_p) ) deallocate(soldrain_p ) +!additional arrays for px: + if(allocated(mavail_p) ) deallocate(mavail_p ) + if(allocated(hpbl_p) ) deallocate(hpbl_p ) + if(allocated(rmol_p) ) deallocate(rmol_p ) + if(allocated(ust_p) ) deallocate(ust_p ) + if(allocated(ra_p) ) deallocate(ra_p ) + if(allocated(rs_p) ) deallocate(rs_p ) + if(allocated(psih_p) ) deallocate(psih_p ) + if(allocated(imperv_p) ) deallocate(imperv_p ) + if(allocated(canfra_p) ) deallocate(canfra_p ) + if(allocated(vegpx_p) ) deallocate(vegpx_p ) + if(allocated(lai_modis_p) ) deallocate(lai_modis_p ) + if(allocated(lai_px_p) ) deallocate(lai_px_p ) + if(allocated(wwlt_px_p) ) deallocate(wwlt_px_p ) + if(allocated(wfc_px_p) ) deallocate(wfc_px_p ) + if(allocated(wsat_px_p) ) deallocate(wsat_px_p ) + if(allocated(clay_px_p) ) deallocate(clay_px_p ) + if(allocated(csand_px_p) ) deallocate(csand_px_p ) + if(allocated(fmsand_px_p) ) deallocate(fmsand_px_p ) + if(allocated(t2anl_p) ) deallocate(t2anl_p ) + if(allocated(t2anl1_p) ) deallocate(t2anl1_p ) + if(allocated(t2anl2_p) ) deallocate(t2anl2_p ) + if(allocated(rh2anl_p) ) deallocate(rh2anl_p ) + if(allocated(rh2anl1_p) ) deallocate(rh2anl1_p ) + if(allocated(rh2anl2_p) ) deallocate(rh2anl2_p ) + if(allocated(snoanl_p) ) deallocate(snoanl_p ) + if(allocated(snoanl1_p) ) deallocate(snoanl1_p ) + if(allocated(snoanl2_p) ) deallocate(snoanl2_p ) + if(config_frac_seaice) then if(allocated(chs_sea) ) deallocate(chs_sea ) if(allocated(chs2_sea) ) deallocate(chs2_sea ) @@ -317,10 +388,12 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) sfcrunoff,smstav,smstot,snotime,snopcx,sr,udrunoff, & z0,znt real(kind=RKIND),dimension(:),pointer :: shdmin,shdmax,snoalb,sfc_albbck,snow,snowc,snowh,tmn, & - skintemp,vegfra,xice,xland - real(kind=RKIND),dimension(:),pointer :: t2m,th2m,q2 + skintemp,sst,vegfra,xice,xland,hpbl,rmol,ust,psih + real(kind=RKIND),dimension(:),pointer :: t2m,th2m,q2,t2anl1,t2anl2,rh2anl1,rh2anl2,snoanl1,snoanl2 + real(kind=RKIND),dimension(:),pointer :: t2anl,rh2anl,snoanl,ra,rs,imperv,canfra,vegpx,mavail + real(kind=RKIND),dimension(:),pointer :: lai_modis,lai_px,wwlt_px,wfc_px,wsat_px,clay_px,csand_px,fmsand_px real(kind=RKIND),dimension(:),pointer :: raincv,rainncv - real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb,dzs + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb,dzs,landusef,soiltypf !local variables and arrays: logical:: do_fill @@ -335,24 +408,38 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'canfra' ,canfra ) call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) call mpas_pool_get_array(diag_physics,'chs' ,chs ) call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) call mpas_pool_get_array(diag_physics,'chklowq' ,chklowq ) + call mpas_pool_get_array(diag_physics,'clay_px' ,clay_px ) call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'csand_px' ,csand_px ) + call mpas_pool_get_array(diag_physics,'fmsand_px' ,fmsand_px ) call mpas_pool_get_array(diag_physics,'glw' ,glw ) call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) + call mpas_pool_get_array(diag_physics,'imperv' ,imperv ) call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'lai_px' ,lai_px ) call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'mavail' ,mavail ) call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) + call mpas_pool_get_array(diag_physics,'psih' ,psih ) call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'ra' ,ra ) + call mpas_pool_get_array(diag_physics,'rh2anl1' ,rh2anl1 ) + call mpas_pool_get_array(diag_physics,'rh2anl2' ,rh2anl2 ) + call mpas_pool_get_array(diag_physics,'rmol' ,rmol ) + call mpas_pool_get_array(diag_physics,'rs' ,rs ) call mpas_pool_get_array(diag_physics,'sfc_albedo' ,sfc_albedo ) call mpas_pool_get_array(diag_physics,'sfc_albedo_seaice',sfc_albedo_seaice) call mpas_pool_get_array(diag_physics,'sfc_emibck' ,sfc_emibck ) @@ -360,9 +447,18 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'snoanl1' ,snoanl1 ) + call mpas_pool_get_array(diag_physics,'snoanl2' ,snoanl2 ) call mpas_pool_get_array(diag_physics,'snotime' ,snotime ) call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'t2anl1' ,t2anl1 ) + call mpas_pool_get_array(diag_physics,'t2anl2' ,t2anl2 ) call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'vegpx' ,vegpx ) + call mpas_pool_get_array(diag_physics,'wfc_px' ,wfc_px ) + call mpas_pool_get_array(diag_physics,'wsat_px' ,wsat_px ) + call mpas_pool_get_array(diag_physics,'wwlt_px' ,wwlt_px ) call mpas_pool_get_array(diag_physics,'z0' ,z0 ) call mpas_pool_get_array(diag_physics,'znt' ,znt ) call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) @@ -371,13 +467,18 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) + call mpas_pool_get_array(sfc_input,'lai_modis' ,lai_modis ) + call mpas_pool_get_array(sfc_input,'rh2anl' ,rh2anl ) call mpas_pool_get_array(sfc_input,'shdmin' ,shdmin ) call mpas_pool_get_array(sfc_input,'shdmax' ,shdmax ) call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) call mpas_pool_get_array(sfc_input,'sfc_albbck',sfc_albbck) + call mpas_pool_get_array(sfc_input,'snoanl' ,snoanl ) call mpas_pool_get_array(sfc_input,'snow' ,snow ) call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'sst' ,sst ) + call mpas_pool_get_array(sfc_input,'t2anl' ,t2anl ) call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) call mpas_pool_get_array(sfc_input,'skintemp' ,skintemp ) call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) @@ -388,6 +489,8 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(sfc_input,'smcrel' ,smcrel ) call mpas_pool_get_array(sfc_input,'smois' ,smois ) call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + call mpas_pool_get_array(sfc_input,'landusef' ,landusef ) + call mpas_pool_get_array(sfc_input,'soiltypf' ,soiltypf ) !In Registry.xml, dzs is a function of nCells. In the Noah lsm scheme, dzs is independent !of cell locations: @@ -406,37 +509,76 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) enddo enddo + do j = jts,jte + do n = 1,num_soilc + do i = its,ite + soiltypf_p(i,n,j) = soiltypf(n,i) + enddo + enddo + enddo + + do j = jts,jte + do n = 1,num_landu + do i = its,ite + landusef_p(i,n,j) = landusef(n,i) + enddo + enddo + enddo + do j = jts,jte do i = its,ite acsnom_p(i,j) = acsnom(i) acsnow_p(i,j) = acsnow(i) + canfra_p(i,j) = canfra(i) canwat_p(i,j) = canwat(i) chs_p(i,j) = chs(i) chs2_p(i,j) = chs2(i) chklowq_p(i,j) = chklowq(i) + clay_px_p(i,j) = clay_px(i) cpm_p(i,j) = cpm(i) cqs2_p(i,j) = cqs2(i) + csand_px_p(i,j) = csand_px(i) + fmsand_px_p(i,j) = fmsand_px(i) glw_p(i,j) = glw(i) grdflx_p(i,j) = grdflx(i) gsw_p(i,j) = gsw(i) hfx_p(i,j) = hfx(i) + hpbl_p(i,j) = hpbl(i) + imperv_p(i,j) = imperv(i) lai_p(i,j) = lai(i) + lai_px_p(i,j) = lai_px(i) lh_p(i,j) = lh(i) + mavail_p(i,j) = mavail(i) noahres_p(i,j) = noahres(i) potevp_p(i,j) = potevp(i) + psih_p(i,j) = psih(i) qfx_p(i,j) = qfx(i) qgh_p(i,j) = qgh(i) qsfc_p(i,j) = qsfc(i) br_p(i,j) = br(i) + ra_p(i,j) = ra(i) + rh2anl1_p(i,j) = rh2anl1(i) + rh2anl2_p(i,j) = rh2anl2(i) + rmol_p(i,j) = rmol(i) + rs_p(i,j) = rs(i) sfc_albedo_p(i,j) = sfc_albedo(i) sfc_emibck_p(i,j) = sfc_emibck(i) sfc_emiss_p(i,j) = sfc_emiss(i) sfcrunoff_p(i,j) = sfcrunoff(i) smstav_p(i,j) = smstav(i) smstot_p(i,j) = smstot(i) + snoanl1_p(i,j) = snoanl1(i) + snoanl2_p(i,j) = snoanl2(i) snotime_p(i,j) = snotime(i) snopcx_p(i,j) = snopcx(i) + t2anl1_p(i,j) = t2anl1(i) + t2anl2_p(i,j) = t2anl2(i) udrunoff_p(i,j) = udrunoff(i) + ust_p(i,j) = ust(i) + vegpx_p(i,j) = vegpx(i) + wfc_px_p(i,j) = wfc_px(i) + wsat_px_p(i,j) = wsat_px(i) + wwlt_px_p(i,j) = wwlt_px(i) z0_p(i,j) = z0(i) znt_p(i,j) = znt(i) t2m_p(i,j) = t2m(i) @@ -445,13 +587,18 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) isltyp_p(i,j) = isltyp(i) ivgtyp_p(i,j) = ivgtyp(i) + lai_modis_p(i,j) = lai_modis(i) + rh2anl_p(i,j) = rh2anl(i) shdmin_p(i,j) = shdmin(i) shdmax_p(i,j) = shdmax(i) snoalb_p(i,j) = snoalb(i) + snoanl_p(i,j) = snoanl(i) sfc_albbck_p(i,j) = sfc_albbck(i) snow_p(i,j) = snow(i) snowc_p(i,j) = snowc(i) snowh_p(i,j) = snowh(i) + sst_p(i,j) = sst(i) + t2anl_p(i,j) = t2anl(i) tmn_p(i,j) = tmn(i) tsk_p(i,j) = skintemp(i) vegfra_p(i,j) = vegfra(i) @@ -574,10 +721,12 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) br,sfc_albedo,sfc_emibck,sfc_emiss,sfcrunoff, & smstav,smstot,snotime,snopcx,sr,udrunoff,z0,znt real(kind=RKIND),dimension(:),pointer :: shdmin,shdmax,snoalb,sfc_albbck,snow,snowc,snowh,tmn, & - skintemp,vegfra,xice,xland - real(kind=RKIND),dimension(:),pointer :: t2m,th2m,q2 + skintemp,sst,vegfra,xice,xland,hpbl,rmol,ust,psih + real(kind=RKIND),dimension(:),pointer :: t2m,th2m,q2,t2anl1,t2anl2,rh2anl1,rh2anl2,snoanl1,snoanl2 + real(kind=RKIND),dimension(:),pointer :: t2anl,rh2anl,snoanl,ra,rs,imperv,canfra,vegpx,mavail + real(kind=RKIND),dimension(:),pointer :: lai_modis,lai_px,wwlt_px,wfc_px,wsat_px,clay_px,csand_px,fmsand_px real(kind=RKIND),dimension(:),pointer :: raincv,rainncv - real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb,landusef,soiltypf !local variables and arrays: integer:: ip,iEdg @@ -590,35 +739,58 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'canfra' ,canfra ) call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) call mpas_pool_get_array(diag_physics,'chs' ,chs ) call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) call mpas_pool_get_array(diag_physics,'chklowq' ,chklowq ) + call mpas_pool_get_array(diag_physics,'clay_px' ,clay_px ) call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'csand_px' ,csand_px ) + call mpas_pool_get_array(diag_physics,'fmsand_px' ,fmsand_px ) call mpas_pool_get_array(diag_physics,'glw' ,glw ) call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) + call mpas_pool_get_array(diag_physics,'imperv' ,imperv ) call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'lai_px' ,lai_px ) call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'mavail' ,mavail ) call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) + call mpas_pool_get_array(diag_physics,'psih' ,psih ) call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'ra' ,ra ) call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'rh2anl1' ,rh2anl1 ) + call mpas_pool_get_array(diag_physics,'rh2anl2' ,rh2anl2 ) + call mpas_pool_get_array(diag_physics,'rmol' ,rmol ) + call mpas_pool_get_array(diag_physics,'rs' ,rs ) call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) call mpas_pool_get_array(diag_physics,'sfc_emibck',sfc_emibck) call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'snoanl1' ,snoanl1 ) + call mpas_pool_get_array(diag_physics,'snoanl2' ,snoanl2 ) call mpas_pool_get_array(diag_physics,'snotime' ,snotime ) call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'t2anl1' ,t2anl1 ) + call mpas_pool_get_array(diag_physics,'t2anl2' ,t2anl2 ) call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'vegpx' ,vegpx ) + call mpas_pool_get_array(diag_physics,'wfc_px' ,wfc_px ) + call mpas_pool_get_array(diag_physics,'wsat_px' ,wsat_px ) + call mpas_pool_get_array(diag_physics,'wwlt_px' ,wwlt_px ) call mpas_pool_get_array(diag_physics,'z0' ,z0 ) call mpas_pool_get_array(diag_physics,'znt' ,znt ) call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) @@ -627,13 +799,18 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) + call mpas_pool_get_array(sfc_input,'lai_modis' ,lai_modis ) + call mpas_pool_get_array(sfc_input,'rh2anl' ,rh2anl ) call mpas_pool_get_array(sfc_input,'shdmin' ,shdmin ) call mpas_pool_get_array(sfc_input,'shdmax' ,shdmax ) call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) call mpas_pool_get_array(sfc_input,'sfc_albbck' ,sfc_albbck) + call mpas_pool_get_array(sfc_input,'snoanl' ,snoanl ) call mpas_pool_get_array(sfc_input,'snow' ,snow ) call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'sst' ,sst ) + call mpas_pool_get_array(sfc_input,'t2anl' ,t2anl ) call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) call mpas_pool_get_array(sfc_input,'skintemp' ,skintemp ) call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) @@ -643,6 +820,8 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(sfc_input,'smcrel' ,smcrel ) call mpas_pool_get_array(sfc_input,'smois' ,smois ) call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + call mpas_pool_get_array(sfc_input,'landusef' ,landusef ) + call mpas_pool_get_array(sfc_input,'soiltypf' ,soiltypf ) do j = jts,jte do n = 1,num_soils @@ -655,49 +834,97 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) enddo enddo + do j = jts,jte + do n = 1,num_soilc + do i = its,ite + soiltypf(n,i) = soiltypf_p(i,n,j) + enddo + enddo + enddo + + do j = jts,jte + do n = 1,num_landu + do i = its,ite + landusef(n,i) = landusef_p(i,n,j) + enddo + enddo + enddo + do j = jts,jte do i = its,ite acsnom(i) = acsnom_p(i,j) acsnow(i) = acsnow_p(i,j) + canfra(i) = canfra_p(i,j) canwat(i) = canwat_p(i,j) chs(i) = chs_p(i,j) chs2(i) = chs2_p(i,j) chklowq(i) = chklowq_p(i,j) + clay_px(i) = clay_px_p(i,j) cpm(i) = cpm_p(i,j) cqs2(i) = cqs2_p(i,j) + csand_px(i) = csand_px_p(i,j) + fmsand_px(i) = fmsand_px_p(i,j) glw(i) = glw_p(i,j) grdflx(i) = grdflx_p(i,j) gsw(i) = gsw_p(i,j) hfx(i) = hfx_p(i,j) + hpbl(i) = hpbl_p(i,j) + imperv(i) = imperv_p(i,j) lai(i) = lai_p(i,j) + lai_px(i) = lai_px_p(i,j) lh(i) = lh_p(i,j) + mavail(i) = mavail_p(i,j) noahres(i) = noahres_p(i,j) potevp(i) = potevp_p(i,j) + psih(i) = psih_p(i,j) qfx(i) = qfx_p(i,j) qgh(i) = qgh_p(i,j) qsfc(i) = qsfc_p(i,j) br(i) = br_p(i,j) + ra(i) = ra_p(i,j) + rh2anl1(i) = rh2anl1_p(i,j) + rh2anl2(i) = rh2anl2_p(i,j) + rmol(i) = rmol_p(i,j) + rs(i) = rs_p(i,j) sfc_albedo(i) = sfc_albedo_p(i,j) sfc_emibck(i) = sfc_emibck_p(i,j) sfc_emiss(i) = sfc_emiss_p(i,j) sfcrunoff(i) = sfcrunoff_p(i,j) smstav(i) = smstav_p(i,j) smstot(i) = smstot_p(i,j) + snoanl1(i) = snoanl1_p(i,j) + snoanl2(i) = snoanl2_p(i,j) snotime(i) = snotime_p(i,j) snopcx(i) = snopcx_p(i,j) + t2anl1(i) = t2anl1_p(i,j) + t2anl2(i) = t2anl2_p(i,j) udrunoff(i) = udrunoff_p(i,j) + ust(i) = ust_p(i,j) + vegpx(i) = vegpx_p(i,j) + wfc_px(i) = wfc_px_p(i,j) + wsat_px(i) = wsat_px_p(i,j) + wwlt_px(i) = wwlt_px_p(i,j) z0(i) = z0_p(i,j) znt(i) = znt_p(i,j) t2m(i) = t2m_p(i,j) th2m(i) = th2m_p(i,j) q2(i) = q2_p(i,j) + isltyp(i) = isltyp_p(i,j) + ivgtyp(i) = ivgtyp_p(i,j) + lai_modis(i) = lai_modis_p(i,j) + rh2anl(i) = rh2anl_p(i,j) + shdmin(i) = shdmin_p(i,j) + shdmax(i) = shdmax_p(i,j) snoalb(i) = snoalb_p(i,j) sfc_albbck(i) = sfc_albbck_p(i,j) + snoanl(i) = snoanl_p(i,j) snow(i) = snow_p(i,j) snowc(i) = snowc_p(i,j) snowh(i) = snowh_p(i,j) skintemp(i) = tsk_p(i,j) + sst(i) = sst_p(i,j) + t2anl(i) = t2anl_p(i,j) tmn(i) = tmn_p(i,j) vegfra(i) = vegfra_p(i,j) xice(i) = xice_p(i,j) @@ -762,6 +989,9 @@ subroutine init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) case ("noah") call noah_init_forMPAS(dminfo,mesh,configs,diag_physics,sfc_input) + + case ("px") + call noah_init_forMPAS(dminfo,mesh,configs,diag_physics,sfc_input) !may be customized for PX in the future case default @@ -785,18 +1015,32 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) type(mpas_pool_type),intent(inout):: sfc_input !local pointers: - logical,pointer:: config_sfc_albedo,config_frac_seaice + logical,pointer :: config_sfc_albedo,config_frac_seaice + logical,pointer :: config_do_restart character(len=StrKIND),pointer:: lsm_scheme character(len=StrKIND),pointer:: mminlu - integer,pointer:: isice + character(len=StrKIND),pointer:: config_landuse_data + character(len=StrKIND),pointer:: config_soilndg_interval + integer,pointer :: config_px_soilndg + integer,pointer :: config_px_smoisinit + integer,pointer :: config_px_modis_veg + integer,pointer :: isice + + integer :: nlcat !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_lsm:') - call mpas_pool_get_config(configs,'config_sfc_albedo' ,config_sfc_albedo ) - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) - call mpas_pool_get_config(configs,'config_lsm_scheme',lsm_scheme) + call mpas_pool_get_config(configs, 'config_sfc_albedo' ,config_sfc_albedo ) + call mpas_pool_get_config(configs, 'config_frac_seaice',config_frac_seaice) + call mpas_pool_get_config(configs, 'config_lsm_scheme',lsm_scheme) + call mpas_pool_get_config(configs, 'config_landuse_data',config_landuse_data ) + call mpas_pool_get_config(configs, 'config_soilndg_interval',config_soilndg_interval ) + call mpas_pool_get_config(configs, 'config_px_soilndg',config_px_soilndg ) + call mpas_pool_get_config(configs, 'config_px_smoisinit',config_px_smoisinit ) + call mpas_pool_get_config(configs, 'config_px_modis_veg',config_px_modis_veg ) + call mpas_pool_get_config(configs, 'config_do_restart',config_do_restart) call mpas_pool_get_array(sfc_input,'mminlu',mminlu) call mpas_pool_get_array(sfc_input,'isice' ,isice ) @@ -894,7 +1138,46 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) call mpas_timer_stop('Noah') - + + case("px") + call mpas_timer_start('PX') + call pxlsm( & + dz8w = dz_p , qv3d = qv_p , t3d = t_p , & + th3d = th_p , rho = rho_p , psfc = psfc_p , & + gsw = gsw_p , glw = glw_p , rainbl = rainbl_p , & + emiss =sfc_emiss_p, itimestep = itimestep , restart =config_do_restart,& + nsoil = num_soils , anal_intervalc=config_soilndg_interval , & + xland = xland_p , xice = xice_p , albedo = sfc_albedo_p , & + snoalb = snoalb_p , smois = smois_p , tslb = tslb_p , & + mavail = mavail_p , ta2 = t2m_p , qa2 = q2_p , & + qsfc = qsfc_p , dzs = dzs_p , psih = psih_p , & + landusef = landusef_p, soilcbot = soiltypf_p , & + vegfra = vegfra_p , vegf_px = vegpx_p , ivgtyp = ivgtyp_p , & + isltyp = isltyp_p , ra = ra_p , rs = rs_p , & + lai = lai_modis_p,imperv = imperv_p , canfra = canfra_p , & + nlcat = num_landu , nscat = num_soilc , & + hfx = hfx_p , qfx = qfx_p , & + lh = lh_p , tsk = tsk_p , sst = sst_p , & + znt = znt_p , canwat = canwat_p , grdflx = grdflx_p , & + shdmin = shdmin_p , shdmax = shdmax_p , snowc = snowc_p , & + pblh = hpbl_p , rmol = rmol_p , ust = ust_p , & + dtbl = dt_pbl , t2_ndg_old= t2anl1_p , t2_ndg_new= t2anl2_p , & + q2_ndg_old= rh2anl1_p , q2_ndg_new= rh2anl2_p , sn_ndg_old= snoanl1_p , & + sn_ndg_new= snoanl2_p , snow = snow_p , snowh = snowh_p , & + snowncv = acsnow_p , t2obs = t2anl_p , q2obs = rh2anl_p , & + pxlsm_smois_init = config_px_smoisinit, pxlsm_soil_nudge = config_px_soilndg, & + pxlsm_modis_veg = config_px_modis_veg , & + lai_px = lai_px_p , & + wwlt_px = wwlt_px_p , wfc_px = wfc_px_p , wsat_px = wsat_px_p , & + clay_px = clay_px_p , csand_px = csand_px_p , fmsand_px = fmsand_px_p , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) +! if(config_frac_seaice) then +! call seaice_px( ) ! Future site of PX-compatible handling of fractional sea-ice +! endif + call mpas_timer_stop('PX') case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index eae7dd844d..746ee8a756 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -52,6 +52,13 @@ module mpas_atmphys_initialize_real ! * In subroutine physics_init_seaice, removed the initialization of isice_lu since it is now defined in ! Registry.xml and initialized in subroutine init_atm_static. ! Laura D. Fowler (laura@ucar.edu) / 2017-01-12. +! * generalized soilcat (isltyp) to work with either soiltype_top or soiltype_bot data. +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2018-09-10. +! * added fractional soil type (soiltypf) and land use (landusef) dependent on config_frac_landuse option; +! otherwise dominant land use and soil type will be used by default. +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2020-02-10. +! * added initialization of lai_modis from MODIS climatological monthly mean LAI for use by PX LSM. +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2020-02-20. contains @@ -81,9 +88,9 @@ subroutine physics_initialize_real(mesh, fg, dminfo, dims, configs) real(kind=RKIND),dimension(:,:),pointer:: albedo12m real(kind=RKIND),dimension(:),pointer:: seaice,xice,xland - real(kind=RKIND),dimension(:),pointer:: vegfra,shdmin,shdmax + real(kind=RKIND),dimension(:),pointer:: vegfra,shdmin,shdmax,lai_modis real(kind=RKIND),dimension(:),pointer:: snow,snowc,snowh - real(kind=RKIND),dimension(:,:),pointer:: greenfrac + real(kind=RKIND),dimension(:,:),pointer:: greenfrac,lai12m real(kind=RKIND),dimension(:),pointer:: skintemp,sst @@ -109,9 +116,11 @@ subroutine physics_initialize_real(mesh, fg, dminfo, dims, configs) call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) call mpas_pool_get_array(mesh, 'shdmin', shdmin) call mpas_pool_get_array(mesh, 'shdmax', shdmax) + call mpas_pool_get_array(mesh, 'lai12m', lai12m) call mpas_pool_get_array(fg, 'sfc_albbck', sfc_albbck) call mpas_pool_get_array(fg, 'vegfra', vegfra) + call mpas_pool_get_array(fg, 'lai_modis', lai_modis) call mpas_pool_get_array(fg, 'snow', snow) call mpas_pool_get_array(fg, 'snowc', snowc) call mpas_pool_get_array(fg, 'snowh', snowh) @@ -150,10 +159,12 @@ subroutine physics_initialize_real(mesh, fg, dminfo, dims, configs) if(landmask(iCell) .eq. 0) sfc_albbck(iCell) = 0.08_RKIND enddo -!initialization of the green-ness (vegetation) fraction: interpolation of the monthly values to -!the initial date. get the min/max for each cell for the monthly green-ness fraction: +!initialization of the green-ness (vegetation) fraction and leaf area index: +!interpolation of the monthly values to the initial date, and +!get the min/max for each cell for the monthly green-ness fraction: initial_date = trim(config_start_time) call monthly_interp_to_date(nCellsSolve,initial_date,greenfrac,vegfra) + call monthly_interp_to_date(nCellsSolve,initial_date,lai12m,lai_modis) !calculates the maximum and minimum green-ness (vegetation) fraction: call monthly_min_max(nCellsSolve,greenfrac,shdmin,shdmax) @@ -297,9 +308,6 @@ subroutine init_soil_layers_depth(mesh, fg, dims, configs) call mpas_pool_get_config(configs, 'config_nsoillevels', config_nsoillevels) - if(config_nsoillevels .ne. 4) & - call physics_error_fatal('NOAH lsm uses 4 soil layers. Correct config_nsoillevels.') - do iCell = 1, nCellsSolve iSoil = 1 zs_fg(iSoil,iCell) = 0.5_RKIND * dzs_fg(iSoil,iCell) @@ -310,21 +318,45 @@ subroutine init_soil_layers_depth(mesh, fg, dims, configs) enddo enddo - do iCell = 1, nCellsSolve - dzs(1,iCell) = 0.10_RKIND - dzs(2,iCell) = 0.30_RKIND - dzs(3,iCell) = 0.60_RKIND - dzs(4,iCell) = 1.00_RKIND + if(config_nsoillevels .eq. 4) then ! for Noah lsm + + do iCell = 1, nCellsSolve + dzs(1,iCell) = 0.10_RKIND + dzs(2,iCell) = 0.30_RKIND + dzs(3,iCell) = 0.60_RKIND + dzs(4,iCell) = 1.00_RKIND + + iSoil = 1 + zs(iSoil,iCell) = 0.5_RKIND * dzs(iSoil,iCell) + do iSoil = 2, nSoilLevels + zs(iSoil,iCell) = zs(iSoil-1,iCell) & + + 0.5_RKIND * dzs(iSoil-1,iCell) & + + 0.5_RKIND * dzs(iSoil,iCell) + enddo - iSoil = 1 - zs(iSoil,iCell) = 0.5_RKIND * dzs(iSoil,iCell) - do iSoil = 2, nSoilLevels - zs(iSoil,iCell) = zs(iSoil-1,iCell) & - + 0.5_RKIND * dzs(iSoil-1,iCell) & - + 0.5_RKIND * dzs(iSoil,iCell) enddo - enddo + elseif(config_nsoillevels .eq. 2) then ! for PX lsm + + do iCell = 1, nCellsSolve + dzs(1,iCell) = 0.01_RKIND + dzs(2,iCell) = 0.99_RKIND + + iSoil = 1 + zs(iSoil,iCell) = 0.5_RKIND * dzs(iSoil,iCell) + do iSoil = 2, nSoilLevels + zs(iSoil,iCell) = zs(iSoil-1,iCell) & + + 0.5_RKIND * dzs(iSoil-1,iCell) & + + 0.5_RKIND * dzs(iSoil,iCell) + enddo + + enddo + + else + + call physics_error_fatal('NOAH lsm uses 4 and PX lsm uses 2 soil layers. Correct config_nsoillevels.') + + endif end subroutine init_soil_layers_depth @@ -402,8 +434,8 @@ subroutine init_soil_layers_properties(mesh, fg, dminfo, dims, configs) call mpas_log_write('Error in interpolation of sm_fg to MPAS grid: num_sm = $i', messageType=MPAS_LOG_CRIT, intArgs=(/num_sm/)) endif - if(config_nsoillevels .ne. 4) & - call physics_error_fatal('NOAH lsm uses 4 soil layers. Correct config_nsoillevels.') + if(config_nsoillevels .ne. 4 .and. config_nsoillevels .ne. 2) & + call physics_error_fatal('NOAH lsm uses 4 and PX lsm uses 2 soil layers. Correct config_nsoillevels.') if(.not.allocated(zhave) ) allocate(zhave(nFGSoilLevels+2,nCellsSolve) ) if(.not.allocated(st_input)) allocate(st_input(nFGSoilLevels+2,nCellsSolve)) @@ -434,14 +466,14 @@ subroutine init_soil_layers_properties(mesh, fg, dminfo, dims, configs) enddo -!... interpolate the soil temperature, soil moisture, and soil liquid temperature to the four -! layers used in the NOAH land surface scheme: +!... interpolate the soil temperature, soil moisture, and soil liquid temperature to either +! the four layers used in the NOAH land surface scheme or the two layers used in the PX LSM: do iCell = 1, nCellsSolve if(landmask(iCell) .eq. 1) then - noah: do iSoil = 1 , nSoilLevels + do iSoil = 1 , nSoilLevels input: do ifgSoil = 1 , nFGSoilLevels+2-1 if(iCell .eq. 1) call mpas_log_write('$i $i $r $r $r', & intArgs=(/iSoil,ifgSoil/), & @@ -470,7 +502,7 @@ subroutine init_soil_layers_properties(mesh, fg, dminfo, dims, configs) endif enddo input if(iCell.eq. 1) call mpas_log_write('') - enddo noah + enddo elseif(landmask(iCell) .eq. 0) then @@ -596,14 +628,16 @@ subroutine physics_init_seaice(mesh, input, dims, configs) real(kind=RKIND):: xice_threshold real(kind=RKIND):: mid_point_depth - real(kind=RKIND),dimension(:),pointer :: vegfra + real(kind=RKIND),dimension(:),pointer :: vegfra,lai_modis real(kind=RKIND),dimension(:),pointer :: seaice,xice real(kind=RKIND),dimension(:),pointer :: skintemp,tmn,xland real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o,smcrel + real(kind=RKIND),dimension(:,:),pointer:: landusef,soiltypf - logical, pointer :: config_frac_seaice + logical, pointer :: config_frac_seaice,config_frac_landuse character(len=StrKIND),pointer:: config_landuse_data - integer,pointer:: isice_lu + integer,pointer:: isice_lu,ismax_lu + integer:: i !note that this threshold is also defined in module_physics_vars.F.It is defined here to avoid !adding "use module_physics_vars" since this subroutine is only used for the initialization of @@ -617,18 +651,23 @@ subroutine physics_init_seaice(mesh, input, dims, configs) call mpas_pool_get_config(configs, 'config_frac_seaice', config_frac_seaice) call mpas_pool_get_config(configs, 'config_landuse_data', config_landuse_data) + call mpas_pool_get_config(configs, 'config_frac_landuse', config_frac_landuse) call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(dims, 'nSoilLevels', nSoilLevels) call mpas_pool_get_array(mesh, 'isice_lu', isice_lu) + call mpas_pool_get_array(mesh, 'ismax_lu', ismax_lu) call mpas_pool_get_array(mesh, 'landmask', landmask) call mpas_pool_get_array(mesh, 'lu_index', ivgtyp) - call mpas_pool_get_array(mesh, 'soilcat_top', isltyp) + call mpas_pool_get_array(mesh, 'landusef', landusef) + call mpas_pool_get_array(mesh, 'soilcat', isltyp) + call mpas_pool_get_array(mesh, 'soiltypf', soiltypf) call mpas_pool_get_array(input, 'seaice', seaice) call mpas_pool_get_array(input, 'xice', xice) call mpas_pool_get_array(input, 'vegfra', vegfra) + call mpas_pool_get_array(input, 'lai_modis', lai_modis) call mpas_pool_get_array(input, 'skintemp', skintemp) call mpas_pool_get_array(input, 'tmn', tmn) @@ -640,6 +679,7 @@ subroutine physics_init_seaice(mesh, input, dims, configs) call mpas_pool_get_array(input, 'smcrel', smcrel) call mpas_log_write('--- isice_lu = $i', intArgs=(/isice_lu/)) + call mpas_log_write('--- ismax_lu = $i', intArgs=(/ismax_lu/)) !assign the threshold value for xice as a function of config_frac_seaice: if(.not. config_frac_seaice) then @@ -668,9 +708,25 @@ subroutine physics_init_seaice(mesh, input, dims, configs) !... sea-ice points are converted to land points: if(landmask(iCell) .eq. 0) tmn(iCell) = 271.4_RKIND ivgtyp(iCell) = isice_lu +! if(.not. config_frac_landuse) then + landusef(isice_lu,iCell) = 1.0 ! defines dominant land use only + do i = 1,isice_lu-1 + landusef(i,iCell) = 0.0 + end do + do i = isice_lu+1,ismax_lu + landusef(i,iCell) = 0.0 + end do +! else + ! Placeholder for land conversion with fractional land use +! endif isltyp(iCell) = 16 - vegfra(iCell) = 0._RKIND - xland(iCell) = 1._RKIND + soiltypf(16,iCell) = 1.0 ! Currently defines dominant soil type fraction only + do i = 1,15 + soiltypf(i,iCell) = 0.0 + end do + vegfra(iCell) = 0._RKIND + lai_modis(iCell) = 0._RKIND + xland(iCell) = 1._RKIND !... recalculate the soil temperature and soil moisture: do iSoil = 1, nSoilLevels diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index fe8ee5c27c..fd25c7bbec 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -37,7 +37,10 @@ module mpas_atmphys_manager !defines alarm to update the surface boundary conditions: character(len=*), parameter:: sfcbdyAlarmID = 'sfcbdy' -!defines alarm to update the background surface albedo and the greeness fraction: +!defines alarm to update the soil nudging analyses: + character(len=*), parameter:: soilndgAlarmID = 'soilndg' + +!defines alarm to update the background surface albedo and the greenness fraction: character(len=*), parameter:: greenAlarmID = 'green' !defines alarm to update the ozone path length,the trace gas path length,the total emissivity, @@ -148,6 +151,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) config_sfc_albedo, & config_sst_update, & config_sstdiurn_update, & + config_soilndg_update, & config_deepsoiltemp_update character(len=StrKIND),pointer:: config_convection_scheme, & @@ -193,6 +197,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) call mpas_pool_get_config(domain%blocklist%configs,'config_sfc_albedo' ,config_sfc_albedo ) call mpas_pool_get_config(domain%blocklist%configs,'config_sst_update' ,config_sst_update ) call mpas_pool_get_config(domain%blocklist%configs,'config_sstdiurn_update' ,config_sstdiurn_update ) + call mpas_pool_get_config(domain%blocklist%configs,'config_soilndg_update' ,config_soilndg_update ) call mpas_pool_get_config(domain%blocklist%configs,'config_deepsoiltemp_update',config_deepsoiltemp_update) !update the current julian day and current year: @@ -237,9 +242,16 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) if(mpas_is_alarm_ringing(clock,sfcbdyAlarmID,ierr=ierr)) then call mpas_reset_clock_alarm(clock,sfcbdyAlarmID,ierr=ierr) if(config_sst_update) & - call physics_update_sst(domain%dminfo,config_frac_seaice,mesh,sfc_input,diag_physics) + call physics_update_sst(domain%dminfo,config_frac_seaice,mesh,block%configs,sfc_input,diag_physics) endif + ! Update P-X soil nudging analyses from soilndg file: T2, RH2 and SNOW + if(mpas_is_alarm_ringing(clock,soilndgAlarmID,ierr=ierr)) then + call mpas_reset_clock_alarm(clock,soilndgAlarmID,ierr=ierr) + if(config_soilndg_update) & + call physics_update_soilndg(domain%dminfo,mesh,block%configs,sfc_input,diag_physics,itimestep) + endif + !apply a diurnal cycle to the sea-surface temperature: if(config_sstdiurn_update) & call physics_update_sstskin(dt_dyn,mesh,diag_physics,sfc_input) @@ -394,7 +406,8 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) config_radtsw_interval, & config_bucket_update, & config_camrad_abs_update, & - config_greeness_update + config_greeness_update, & + config_soilndg_interval logical,pointer:: config_sst_update logical,pointer:: config_frac_seaice @@ -404,7 +417,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) integer,pointer:: cam_dim1 integer,pointer:: nMonths integer,pointer:: nAerosols,nAerLevels,nOznLevels - integer,pointer:: nCellsSolve,nSoilLevels,nVertLevels + integer,pointer:: nCellsSolve,nSoilLevels,nVertLevels,nLandCat,nSoilCat real(kind=RKIND),pointer:: config_dt @@ -428,6 +441,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_pool_get_config(configs,'config_pbl_interval' ,config_pbl_interval ) call mpas_pool_get_config(configs,'config_radtlw_interval' ,config_radtlw_interval ) call mpas_pool_get_config(configs,'config_radtsw_interval' ,config_radtsw_interval ) + call mpas_pool_get_config(configs,'config_soilndg_interval' ,config_soilndg_interval ) call mpas_pool_get_config(configs,'config_bucket_update' ,config_bucket_update ) call mpas_pool_get_config(configs,'config_camrad_abs_update',config_camrad_abs_update) call mpas_pool_get_config(configs,'config_greeness_update' ,config_greeness_update ) @@ -445,6 +459,8 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) + call mpas_pool_get_dimension(mesh,'nLandCat' ,nLandCat ) + call mpas_pool_get_dimension(mesh,'nSoilCat' ,nSoilCat ) call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) call mpas_pool_get_dimension(state,'num_aerosols',nAerosols) @@ -561,6 +577,17 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call physics_error_fatal('subroutine physics_init: error creating alarm sfcbdy') endif +!set alarm for updating the soil nudging: + call MPAS_stream_mgr_get_property(stream_manager, 'soilndg', MPAS_STREAM_PROPERTY_RECORD_INTV, stream_interval, & + direction=MPAS_STREAM_INPUT, ierr=ierr) + if(trim(config_soilndg_interval) /= 'none') then + call mpas_set_timeInterval(alarmTimeStep,timeString=config_soilndg_interval,ierr=ierr) + alarmStartTime = startTime + call mpas_add_clock_alarm(clock,soilndgAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr) + if(ierr /= 0) & + call physics_error_fatal('subroutine physics_init: error creating alarm for soil nudging') + endif + !set alarm to update the ozone path length, the trace gas path length, the total emissivity, !and the total absorptivity in the "CAM" long-wave radiation codes. if(trim(config_radt_lw_scheme) .eq. "cam_lw" .or. & @@ -671,6 +698,8 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !initialization local physics variables: num_months = nMonths num_soils = nSoilLevels + num_landu = nLandCat + num_soilc = nSoilCat if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 diff --git a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F index 6e2057d5cb..5b366ac13e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F @@ -20,7 +20,8 @@ module mpas_atmphys_update_surface public:: physics_update_sst, & physics_update_sstskin, & physics_update_surface, & - physics_update_deepsoiltemp + physics_update_deepsoiltemp,& + physics_update_soilndg !Update surface boundary conditions. @@ -33,6 +34,7 @@ module mpas_atmphys_update_surface ! physics_update_sst : update the sea-surface temperatures. ! physics_update_sstskin : add a diurnal cycle to the sea-surface temperatures. ! physics_update_deepsoiltemp: update the deep soil temperatures. +! physics_update_soilndg : use data assimilation to nudge soil physics for retrospective simulations. ! ! add-ons and modifications to sourcecode: ! ---------------------------------------- @@ -40,11 +42,17 @@ module mpas_atmphys_update_surface ! Laura D. Fowler (laura@ucar.edu) / 2013-08-24. ! * modified sourcecode to use pools. ! Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +! * added subroutine physics_update_soilndg. +! Jon Pleim (pleim.jon@epa.gov) and Rob Gilliam (gilliam.robert@epa.gov) / 2016-09-16 ! * now use isice and iswater initialized in the init file instead of initialized in mpas_atmphys_landuse.F. ! Laura D. Fowler (laura@ucar.edu) / 2017-01-13. ! * corrected the initialization of the soil temperature tslb over ocean points for exact restartability, and ! for consistency with module_sf_noahdrv.F when itimestep = 1. ! Laura D. Fowler (laura@ucar.edu) / 2017-08-29. +! * for use with PX LSM, changed tslb back to sst over ocean points. +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2020-01-23. +! * added lai_modis interpolated from MODIS climatological monthly mean LAI for use by PX LSM. +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2020-02-27. contains @@ -72,6 +80,8 @@ subroutine physics_update_surface(current_date,config_sfc_albedo,mesh,sfc_input) real(kind=RKIND),dimension(:,:),pointer:: albedo12m real(kind=RKIND),dimension(:) ,pointer:: vegfra,shdmin,shdmax real(kind=RKIND),dimension(:,:),pointer:: greenfrac + real(kind=RKIND),dimension(:) ,pointer:: lai_modis + real(kind=RKIND),dimension(:,:),pointer:: lai12m !local variables: integer:: iCell @@ -89,6 +99,9 @@ subroutine physics_update_surface(current_date,config_sfc_albedo,mesh,sfc_input) call mpas_pool_get_array(sfc_input,'shdmin' , shdmin ) call mpas_pool_get_array(sfc_input,'shdmax' , shdmax ) + call mpas_pool_get_array(sfc_input,'lai12m' , lai12m ) + call mpas_pool_get_array(sfc_input,'lai_modis' , lai_modis ) + !updates the surface background albedo for the current date as a function of the monthly-mean !surface background albedo valid on the 15th day of the month, if config_sfc_albedo is true: if(config_sfc_albedo) then @@ -108,15 +121,20 @@ subroutine physics_update_surface(current_date,config_sfc_albedo,mesh,sfc_input) call monthly_interp_to_date(nCellsSolve,current_date,greenfrac,vegfra) call monthly_min_max(nCellsSolve,greenfrac,shdmin,shdmax) +!updates the leaf area index for the current date as a function of the monthly-mean MODIS LAI +!valid on the 15th day of the month. + call monthly_interp_to_date(nCellsSolve,current_date,lai12m,lai_modis) + end subroutine physics_update_surface !================================================================================================================= - subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_physics) + subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,configs,sfc_input,diag_physics) !================================================================================================================= !input arguments: type(dm_info),intent(in):: dminfo type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: configs logical,intent(in):: config_frac_seaice !inout arguments: @@ -127,13 +145,16 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys integer,pointer:: nCellsSolve,nSoilLevels integer,pointer:: isice,iswater - real(kind=RKIND),dimension(:),pointer :: sfc_albbck,sst,snow,tmn,tsk,vegfra,xice,seaice + real(kind=RKIND),dimension(:),pointer :: sfc_albbck,sst,snow,tmn,tsk,vegfra,xice,seaice,lai_modis real(kind=RKIND),dimension(:),pointer :: snowc,snowh real(kind=RKIND),dimension(:,:),pointer:: tslb,sh2o,smois real(kind=RKIND),dimension(:),pointer:: sfc_albedo,sfc_emiss,sfc_emibck real(kind=RKIND),dimension(:),pointer:: xicem,xland +!local pointers: + character(len=StrKIND),pointer:: config_lsm_scheme + !local variables: integer:: icheck integer:: iCell,iSoil @@ -146,6 +167,8 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_lsm_scheme',config_lsm_scheme) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) @@ -155,6 +178,7 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) call mpas_pool_get_array(sfc_input,'landmask' ,landmask ) call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) + call mpas_pool_get_array(sfc_input,'lai_modis' ,lai_modis ) call mpas_pool_get_array(sfc_input,'sfc_albbck',sfc_albbck) call mpas_pool_get_array(sfc_input,'sst' ,sst ) call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) @@ -216,11 +240,12 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys nb_to_land = nb_to_land + 1 !... sea-ice points are converted to land points: - ivgtyp(iCell) = isice - isltyp(iCell) = 16 - vegfra(iCell) = 0._RKIND - xland(iCell) = 1._RKIND - tmn(iCell) = 271.4_RKIND + ivgtyp(iCell) = isice + isltyp(iCell) = 16 + vegfra(iCell) = 0._RKIND + lai_modis(iCell) = 0._RKIND + xland(iCell) = 1._RKIND + tmn(iCell) = 271.4_RKIND do iSoil = 1, nSoilLevels tslb(iSoil,iCell) = tsk(iCell) @@ -241,11 +266,12 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys nb_to_ocean = nb_to_ocean + 1 !land points turn to water points: - ivgtyp(iCell) = iswater - isltyp(iCell) = 14 - vegfra(iCell) = 0._RKIND - xland(iCell) = 2._RKIND - tmn(iCell) = sst(iCell) + ivgtyp(iCell) = iswater + isltyp(iCell) = 14 + vegfra(iCell) = 0._RKIND + lai_modis(iCell) = 0._RKIND + xland(iCell) = 2._RKIND + tmn(iCell) = sst(iCell) snowc(iCell) = 0 snow(iCell) = 0.0_RKIND @@ -270,9 +296,15 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys if(xland(iCell) >= 1.5_RKIND) then tsk(iCell) = sst(iCell) - do iSoil = 1, nSoilLevels - tslb(iSoil,iCell) = 273.16 - enddo + if(trim(config_lsm_scheme) .eq. "px") then + do iSoil = 1, nSoilLevels + tslb(iSoil,iCell) = sst(iCell) + enddo + else + do iSoil = 1, nSoilLevels + tslb(iSoil,iCell) = 273.16 + enddo + endif endif enddo !call mpas_log_write('') @@ -567,6 +599,74 @@ subroutine physics_update_deepsoiltemp(LeapYear,dt,julian_in,mesh,sfc_input,diag end subroutine physics_update_deepsoiltemp +!================================================================================================== + subroutine physics_update_soilndg(dminfo,mesh,configs,sfc_input,diag_physics,itimestep) +!================================================================================================== + +!input arguments: + type(dm_info),intent(in) :: dminfo + type(mpas_pool_type),intent(in):: mesh + integer,intent(in) :: itimestep + type(mpas_pool_type),intent(in):: configs + +!inout arguments: + type(mpas_pool_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: diag_physics + +!local pointers: + logical,pointer:: config_do_restart + + integer,pointer:: nCellsSolve + + real(kind=RKIND),dimension(:),pointer :: t2anl,rh2anl,snoanl + real(kind=RKIND),dimension(:),pointer :: t2anl1,rh2anl1,snoanl1 + real(kind=RKIND),dimension(:),pointer :: t2anl2,rh2anl2,snoanl2 + +!local variables: + integer:: iCell + +!-------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + + call mpas_pool_get_array(sfc_input,'t2anl' ,t2anl ) + call mpas_pool_get_array(sfc_input,'rh2anl' ,rh2anl ) + call mpas_pool_get_array(sfc_input,'snoanl' ,snoanl ) + + call mpas_pool_get_array(diag_physics,'t2anl1',t2anl1) + call mpas_pool_get_array(diag_physics,'t2anl2',t2anl2) + call mpas_pool_get_array(diag_physics,'rh2anl1',rh2anl1) + call mpas_pool_get_array(diag_physics,'rh2anl2',rh2anl2) + call mpas_pool_get_array(diag_physics,'snoanl1',snoanl1) + call mpas_pool_get_array(diag_physics,'snoanl2',snoanl2) + +! call mpas_log_write('') +! call mpas_log_write('--- enter subroutine physics_update_soilndg:') + + if(itimestep .eq. 1 .and. .not. config_do_restart) then + do iCell = 1, nCellsSolve + t2anl1(iCell) = t2anl(iCell) + t2anl2(iCell) = t2anl(iCell) + rh2anl1(iCell) = rh2anl(iCell) + rh2anl2(iCell) = rh2anl(iCell) + snoanl1(iCell) = snoanl(iCell) + snoanl2(iCell) = snoanl(iCell) + enddo + else + do iCell = 1, nCellsSolve + t2anl1(iCell) = t2anl2(iCell) + t2anl2(iCell) = t2anl(iCell) + rh2anl1(iCell) = rh2anl2(iCell) + rh2anl2(iCell) = rh2anl(iCell) + snoanl1(iCell) = snoanl2(iCell) + snoanl2(iCell) = snoanl(iCell) + enddo + endif + + end subroutine physics_update_soilndg + !================================================================================================================= end module mpas_atmphys_update_surface !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 28c72579f5..2193e11f3a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -54,6 +54,8 @@ module mpas_atmphys_vars ! * added the variables qvrad_p,qcrad_p,qirad_p, and qsrad_p which are the water vapor,cloud water,cloud ice, ! and snow mixing ratios local to the calculation of the cloud fraction, and used in the radiation codes. ! Laura D. Fowler (laura@ucar.edu) / 2016-07-08. +! * added P-X LSM and soil nudging arrays and control variables. +! Robert C. Gilliam (gilliam.robert@epa.gov) / 2016-09-09. ! * added the variables rqvften and rthften which are the forcing tendencies needed to run the "new" Tiedtke ! parameterization of convection. ! Laura D. Fowler (laura@ucar.edu) / 2016-09-20. @@ -107,6 +109,8 @@ module mpas_atmphys_vars ! * added local variables for the mass-weighted mean velocities for rain, cloud ice, snow, and graupel from the ! Thompson cloud microphysics scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-04-19. +! * added MODIS LAI and vegetation fraction, plus soil type fraction, arrays for P-X LSM. +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2018-08-28. ! * added the local variables cosa_p and sina_p needed in call to subroutine gwdo after updating module_bl_gwdo.F ! to that of WRF version 4.0.2 ! Laura D. Fowler (laura@ucar.edu) / 2019-01-30. @@ -204,7 +208,7 @@ module mpas_atmphys_vars znu_hyd_p !(pres_hyd_p / P0) needed in the Tiedtke convection scheme [Pa] !================================================================================================================= -!... variables related to ozone climatlogy: +!... variables related to ozone climatology: !================================================================================================================= real(kind=RKIND),dimension(:,:,:),allocatable:: & @@ -658,7 +662,9 @@ module mpas_atmphys_vars !albedos as functions of the land surface scheme. integer,public:: & - num_soils !number of soil layers [-] + num_soils, &!number of soil layers [-] + num_soilc, &!number of soil type categories [-] + num_landu !number of land use classes [-] integer,dimension(:,:),allocatable:: & isltyp_p, &!dominant soil type category [-] @@ -670,7 +676,9 @@ module mpas_atmphys_vars smcrel_p, &!soil moisture threshold below which transpiration starts to stress [-] sh2o_p, &!unfrozen soil moisture content [volumetric fraction] smois_p, &!soil moisture [volumetric fraction] - tslb_p !soil temperature [K] + tslb_p, &!soil temperature [K] + soiltypf_p, &!fractional soil type category [-] + landusef_p !fractional land use class [-] real(kind=RKIND),dimension(:,:),allocatable:: & acsnom_p, &!accumulated melted snow [kg m-2] @@ -678,14 +686,14 @@ module mpas_atmphys_vars canwat_p, &!canopy water [kg m-2] chklowq_p, &!surface saturation flag [-] grdflx_p, &!ground heat flux [W m-2] - lai_p, &!leaf area index [-] + lai_p, &!leaf area index [m2 m-2] noahres_p, &!residual of the noah land-surface scheme energy budget [W m-2] potevp_p, &!potential evaporation [W m-2] qz0_p, &!specific humidity at znt [kg kg-1] rainbl_p, &! sfcrunoff_p, &!surface runoff [m s-1] - shdmin_p, &!minimum areal fractional coverage of annual green vegetation [-] - shdmax_p, &!maximum areal fractional coverage of annual green vegetation [-] + shdmin_p, &!minimum areal fractional coverage of annual green vegetation [%] + shdmax_p, &!maximum areal fractional coverage of annual green vegetation [%] smstav_p, &!moisture availability [-] smstot_p, &!total moisture [m3 m-3] snopcx_p, &!snow phase change heat flux [W m-2] @@ -695,7 +703,29 @@ module mpas_atmphys_vars swdown_p, &!downward shortwave flux at the surface [W m-2] udrunoff_p, &!sub-surface runoff [m s-1] tmn_p, &!soil temperature at lower boundary [K] - vegfra_p, &!vegetation fraction [-] + vegfra_p, &!vegetation fraction [%] + rs_p, &!Stomatal resistance for P-X LSM [-] + ra_p, &!Aerodynamic resistance for P-X LSM [-] + imperv_p, &!Impervious surface fraction for P-X LSM [%] + canfra_p, &!Canopy fraction for P-X LSM [%] + vegpx_p, &!Pleim-Xiu fractional landuse weighted veg fraction [%] + lai_modis_p, &!leaf area index from MODIS [m2 m-2] + lai_px_p, &!Computed leaf area index for P-X LSM [m2 m-2] + wwlt_px_p, &!Computed soil wilting point for P-X LSM [m3 m-3] + wfc_px_p, &!Computed soil field capacity for P-X LSM [m3 m-3] + wsat_px_p, &!Computed soil saturation for P-X LSM [m3 m-3] + clay_px_p, &!Aggregated soil clay fraction for P-X LSM [-] + csand_px_p, &!Aggregated soil coarse sand fraction for P-X LSM [-] + fmsand_px_p, &!Aggregated soil fine-medium sand fraction for P-X LSM [-] + t2anl_p, &!2-m temperature analysis at current timestep [K] + t2anl1_p, &!2-m temperature analysis prior read interval from soilndg file [K] + t2anl2_p, &!2-m temperature analysis next read interval from soilndg file [K] + rh2anl_p, &!2-m RH analysis at current timestep [%] + rh2anl1_p, &!2-m RH analysis prior read interval from soilndg file [%] + rh2anl2_p, &!2-m RH analysis next read interval from soilndg file [%] + snoanl_p, &!Snow analysis at current timestep [kg m-2] + snoanl1_p, &!Snow analysis prior read interval from soilndg file [kg m-2] + snoanl2_p, &!Snow analysis next read interval from soilndg file [kg m-2] z0_p !background roughness length [m] real(kind=RKIND),dimension(:,:),allocatable:: & diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index b470771cc2..7a48659995 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -37,6 +37,8 @@ OBJS = \ module_sf_noahlsm_glacial_only.o \ module_sf_noah_seaice.o \ module_sf_noah_seaice_drv.o \ + module_sf_pxlsm.o \ + module_sf_pxlsm_data.o \ module_sf_oml.o \ module_sf_sfclay.o \ module_sf_urban.o @@ -96,6 +98,10 @@ module_sf_noah_seaice_drv.o: \ module_sf_noah_seaice.o: \ module_sf_noahlsm.o +module_sf_pxlsm.o: \ + module_sf_pxlsm_data.o \ + ../mpas_atmphys_constants.o + clean: $(RM) *.f90 *.o *.mod @# Certain systems with intel compilers generate *.i files diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm.F new file mode 100644 index 0000000000..d53b0f0733 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm.F @@ -0,0 +1,2179 @@ +!=============================================================================== +!module_sf_pxlsm.F was originally adapted from ./phys/module_sf_pxlsm.F from +!WRF version 3.8.1 for use in MPAS. +!Jon Pleim (pleim.jon@epa.gov) / 2016-04. +! +!additional modifications to source code for MPAS: +! * Brought up to date with module_sf_pxlsm.F from WRF v4.1.3 as basis, and +! generalized for use in both the MPAS and WRF models. +! Jerold A. Herwehe (herwehe.jerry@epa.gov) / 2019-11-25 +! +!=============================================================================== +! +MODULE module_sf_pxlsm + + USE module_sf_pxlsm_data +#if defined(mpas) + USE mpas_atmphys_constants + USE mpas_atmphys_utilities, only: physics_message,physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#define WRITE_MESSAGE(M) call physics_message( M ) +#else + USE module_model_constants + USE module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#define WRITE_MESSAGE(M) call wrf_message( M ) + INTEGER, PARAMETER :: NSOLD=20 + REAL, PARAMETER :: RD = 287.04, CPD = 1004.67, & + CPH2O = 4.218E+3, CPICE = 2.106E+3, & + LSUBF = 3.335E+5, SIGMA = 5.67E-8, & + ROVCP = RD / CPD + + REAL, PARAMETER :: RIC = 0.25 ! critical Richardson number + REAL, PARAMETER :: DENW = 1000.0 ! water density in KG/M3 + REAL, PARAMETER :: PI = 3.1415926 +#endif + + REAL, PARAMETER :: CRANKP = 0.5 ! CRANK-NIC PARAMETER + REAL, PARAMETER :: TAUINV = 1.0 / 86400.0 ! 1/1DAY(SEC) + REAL, PARAMETER :: T2TFAC = 1.0 / 10.0 ! Bottom soil temp response factor + REAL, PARAMETER :: PR0 = 0.95 + REAL, PARAMETER :: CZO = 0.032 + REAL, PARAMETER :: OZO = 1.E-4 + +CONTAINS +! + +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + SUBROUTINE pxlsm(DZ8W, QV3D, T3D, TH3D, RHO, & + PSFC, GSW, GLW, RAINBL, EMISS, & +#if defined(mpas) + ITIMESTEP,RESTART,NSOIL,ANAL_INTERVALC, & +#else + ITIMESTEP,CURR_SECS,NSOIL,DT,ANAL_INTERVAL, & +#endif + XLAND, XICE, ALBEDO, & + SNOALB, SMOIS, TSLB, MAVAIL, TA2, & + QA2, QSFC, DZS, PSIH, & +#if defined(mpas) + LANDUSEF,SOILCBOT,VEGFRA,VEGF_PX,IVGTYP, & +#else + LANDUSEF,SOILCBOT,VEGFRA,VEGF_PX, & +#endif + ISLTYP,RA,RS,LAI,IMPERV,CANFRA,NLCAT,NSCAT, & + HFX,QFX,LH,TSK,SST,ZNT,CANWAT, & + GRDFLX,SHDMIN,SHDMAX, & +#if defined(mpas) + SNOWC,PBLH,RMOL,UST,DTBL, & +#else + SNOWC,PBLH,RMOL,UST,CAPG,DTBL, & +#endif + T2_NDG_OLD, T2_NDG_NEW, & + Q2_NDG_OLD, Q2_NDG_NEW, & + SN_NDG_OLD, SN_NDG_NEW, SNOW, SNOWH,SNOWNCV,& + T2OBS, Q2OBS, PXLSM_SMOIS_INIT, & + PXLSM_SOIL_NUDGE, & + pxlsm_modis_veg, & + LAI_PX, & + WWLT_PX, WFC_PX, WSAT_PX, & + CLAY_PX, CSAND_PX, FMSAND_PX, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +!------------------------------------------------------------------------- +! THIS MODULE CONTAINS THE PLEIM-XIU LAND-SURFACE MODEL (PX-LSM). +! IT IS DESIGNED TO SIMULATE CHARACTERISTICS OF THE LAND SURFACE AND +! VEGETATION AND EXCHANGE WITH THE PLANETARY BOUNDARY LAYER (PBL). THE +! SOIL MOISTURE MODEL IS BASED ON THE ISBA SCHEME DEVELOPED BY NOILHAN +! AND PLANTON (1989) AND JACQUEMIN AND NOILHAN (1990) AND INCLUDES +! PROGNOSTIC EQUATIONS FOR SOIL MOISTURE AND SOIL TEMPERATURE IN TWO +! LAYERS (1 CM AND 1 M) AS WELL AS CANOPY WATER CONTENT. SURFACE +! MOISTURE FLUXES ARE MODELED BY 3 PATHWAYS: SOIL EVAPORATION, CANOPY +! EVAPORATION, AND VEGETATIVE EVAPOTRANSPIRRATION. +! EVAPOTRANSPIRATION DIRECTLY FROM THE ROOT ZONE SOIL LAYER IS MODELED +! VIA A CANOPY RESISTANCE ANALOG ALGORITHM WHERE STOMATAL CONDUCTANCE +! IS CONTROLLED BY SOLAR RADIATION, AIR TEMPERATURE, AIR HUMIDITY, AND +! ROOT ZONE SOIL MOISTURE. REQUIRED VEGETATION CHARACTERISTICS DERIVED +! FROM THE USGS LANDUSE DATA INCLUDE: LEAF AREA INDEX, FRACTIONAL VEGETATION +! COVERAGE, ROUGHNESS LENGTH, AND MINIMUM STOMATAL RESISTANCE. AN INDIRECT +! NUDGING SCHEME ADJUSTS SOIL MOISTURE ACCORDING TO DIFFERENCES BETWEEN +! MODELED TEMPERATURE AND HUMIDITY AND ANALYSED SURFACE FIELDS. +! +! References: +! Pleim and Xiu, 1995: Development and testing of a surface flux and planetary +! boundary layer model for application in mesoscale models. +! J. Appl. Meteoro., Vol. 34, 16-32. +! Xiu and Pleim, 2001: Development of a land surface model. Part I: Application +! in a mesoscale meteorological model. J. Appl. Meteoro., +! Vol. 40, 192-209. +! Pleim and Xiu, 2003: Development of a land surface model. Part II: Data +! assimilation. J. Appl. Meteoro., Vol. 42, 1811-1822. +! +! Pleim and Gilliam, 2009: An Indirect Data Assimilation Scheme for Deep Soil Temperature in the +! Pleim-Xiu Land Surface Model. J. Appl. Meteor. Climatol., 48, 1362-1376. +! +! Gilliam and Pleim, 2010: Performance assessment of new land-surface and planetary boundary layer +! physics in the WRF-ARW. Journal of Applied Meteorology and Climatology, 49, 760-774. +! REVISION HISTORY: +! AX 4/2005 - developed the initial WRF version based on the MM5 PX LSM +! RG 2/2008 - Completed testing of the intial working version of PX LSM, released in WRFV3.0 early 2008 +! DW 8/2011 - Landuse specific versions of PX (USGS/NLCD/MODIS) were unified into a single code with +! landuse characteristics defined in module_sf_pxsfclay.F. +! RG 12/2011 - Basic code clean, removed commented out debug statements, lined up columns, etc. +! RG 01/2012 - Removed FIRSTIME Logic that computes PX Landuse characteristics at first time step only. This resulted +! in different solutions when OpenMP was used and would not work with moving domains. +! RG 08/2012 - Added CURR_SECS variable in argument list as replacement for PX internal CURRTIME internally comp var. +! This is neccessary for PX to correctly interpolate analyses for soil nudging. In this same calculation +! logic was added for cases where user does not specify the analysis interval, or no analysis interval is +! relevant as in the no PX soil nudging via namelist (pxlsm_soil_nudge = 0). Prior to this fix the default +! analysis interval was zero, so if not speficied a divide by zero was the result. Also, changes were made to +! ensure PX LSM will work with not only MODIS and USGS, but also both the 40 and 50 class NLCD-MODIS data. +! Also, coupled module_sf_pxlsm_data.F was updated so landuse characteristics across datasets are more +! consistent. Albedo for NLCD two grassland categories were lowered from 23 and 25 to 18 and 19. +! For the NLCD40 and NLCD50 roughness and leaf area were made consistent between the US NLCD and +! outside US MODIS datasets. Prior, US boundaries created boundaries of roughness and LAI. +! RG 10/2014 - Wetlands soil moisture treatment. Grid cell soil moisture cannot fall less than fraction of a grid +! cells wetland area * soil saturation (e.g., SMOIS of cell with 50% wetlands cannot fall below 50% of WSAT) +! - Both soil levels are initialized using MAVAIL (Soil moisture availability) instead of just layer 2. +! - Veg Cv (heat capacity) changed from 8x10-6 to 1.2x10-5 (K-M2/J) +! - Alternate empirical stomatal function of PAR (F1) to better replicate photosynthesis-conductance models. +! The main effect is to reduce stomatal conductance for low PAR. +! - Snow albedo is now computed using fractional land-use weighting. Values for each land-use class +! are defined like other PX landuse parameters in module_sf_pxlsm_data.F. These are based on values +! used by NOAH LSM MODIS in VEGPARM.TBL (MAXALB), but tuned to better match satellite values in maxsnowalb +! dataset. Tuning reduced the MAXALB for all forest classes from values in the 50-60% range to 30-40% range. +! These static values are more representative of albedo after snow has melted of fallen from trees. These +! values were also cross verified with http://www.globalbedo.org/global.php +! - USGS 28 category added as an option +! - Impervious surface and canopy fraction data can be used if processed (otherwise 0% so no impact) +! to alter surface heat capacity (See SURFPX subroutine for details) in urban areas and refine +! LAI and VEGF_PX estimations (see VEGELAND subroutine). +! JP 12/2015 - Surface water vapor mixing ratio calculation added for land surface, which is passed to PX-SFCLAY +! for use over all non-water and non-frozen surfaces. +! - PAR function and impact on transpiration modified according to Echer et al.(2015). See P-X LSM documentation +! for full reference. These act to reduce moisture bias near surface during PBL transition. +! JP 11/2017 - Updated vegetation table for different land cover types. Added in WRFv4.0. +! LR 11/2017 - Update for MODIS vegetation: many changes in soil properties. Added in WRFv4.1. +! (Ran et al., 2016 JGR-atmosphere, Ran et al. 2017 in preparation) +! JP 12/2018 - revised soil type categories (ISTI) to conform to WRF soil type input data +! soil types Sand through Clay are now 1-12 rather than 1-11 +! JP 12/2021 - Added new pathway for evaporation from the ground in the vegetated fraction of the grid cell. +! +!-------------------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------------------- +! ARGUMENT LIST: +! +!... Inputs: +!-- DZ8W dz between full levels (m) +!-- QV3D 3D mixing ratio +!-- T3D Temperature (K) +!-- TH3D Theta (K) +!-- RHO 3D dry air density (kg/m^3) + +!-- PSFC surface pressure (Pa) +!-- GSW downward short wave flux at ground surface (W/m^2) +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- RAINBL Timestep rainfall +!-- EMISS surface emissivity (between 0 and 1) + +!-- ITIMESTEP time step number +!-- NSOIL number of soil layers +!-- DT time step (second) (WRF only) +!-- CURR_SECS time on model domain in seconds, universal WRF variable +!-- ANAL_INTERVAL Interval of analyses used for soil moisture and temperature nudging +!-- ANAL_INTERVALC Interval of analyses used for soil nudging MPAS time character + +!-- XLAND land mask (1 for land, 2 for water) +!-- XICE Sea ice +!-- ALBEDO surface albedo with snow cover effects +!-- SNOALB Albedo of snow + +!-- SMOIS total soil moisture content (volumetric fraction) +!-- TSLB soil temp (K) +!-- MAVAIL Moisture availibility of soil +!-- TA2 2-m temperature +!-- QA2 2-m mixing ratio + +!-- SVPT0 constant for saturation vapor pressure (K) +!-- SVP1 constant for saturation vapor pressure (kPa) +!-- SVP2 constant for saturation vapor pressure (dimensionless) +!-- SVP3 constant for saturation vapor pressure (K) + +!-- DZS thicknesses of soil layers +!-- PSIH similarity stability function for heat + +!-- LANDUSEF Landuse fraction +!-- SOILCBOT Bottom soil fraction +!-- VEGFRA Vegetation fraction (%) +!-- VEGF_PX Veg fraction recomputed and used by PX LSM +!-- ISLTYP Soil type + +!-- RA Aerodynamic resistence +!-- RS Stomatal resistence +!-- LAI read in leaf area index (weighted according to fractional landuse) +!-- ZNT rougness length +!-- QSFC Sat. water vapor mixing ratio at the surface interface + +!-- IMPERV Fraction (percent) of grid cell that is impervious surface (concrete/road/non-veg) +!-- CANFRA Fraction (percent) of grid cell that is covered with tree canopy + +!-- NLCAT Number of landuse categories +!-- NSCAT Number of soil categories + +!-- HFX net upward heat flux at the surface (W/m^2) +!-- QFX net upward moisture flux at the surface (kg/m^2/s) +!-- LH net upward latent heat flux at surface (W/m^2) +!-- TSK surface skin temperature (K) +!-- SST sea surface temperature +!-- CANWAT Canopy water (mm) + +!-- GRDFLX Ground heat flux +!-- SFCEVP Evaportation from surface +!-- SHDMIN Minimum annual vegetation fraction for each grid cell (%) +!-- SHDMAX Maximum annual vegetation fraction for each grid cell (%) + +!-- SNOWC flag indicating snow coverage (1 for snow cover) +!-- PBLH PBL height (m) +!-- RMOL 1/L Reciprocal of Monin-Obukhov length +!-- UST u* in similarity theory (m/s) +!-- CAPG heat capacity for soil (J/K/m^3) +!-- DTBL time step of boundary layer calls + +!-- T2_NDG_OLD Analysis temperature prior to current time +!-- T2_NDG_NEW Analysis temperature ahead of current time +!-- Q2_NDG_OLD Analysis mixing ratio prior to current time +!-- Q2_NDG_NEW Analysis mixing ratio ahead of current time + +!-- SN_NDG_OLD Analysis snow water prior to current time +!-- SN_NDG_NEW Analysis snow water ahead of current time +!-- SNOW Snow water equivalent +!-- SNOWH Physical snow depth +!-- SNOWNCV Time step accumulated snow + +!-- T2OBS Analysis temperature interpolated from prior and next in time analyses +!-- Q2OBS Analysis moisture interpolated from prior and next in time analyses +!-- PXLSM_SMOIS_INIT Flag to intialize deep soil moisture to a value derived from moisture availability +!-- PXLSM_SOIL_NUDGE Flag to use soil moisture and temperature nudging in the PX LSM; +! This is typically done for the first simulation. +!-- pxlsm_modis_veg Use MODIS vegetation option: 1 yes, 0 no +!-- LAI_PX LAI used for PX (m^2/m^2) +!-- WWLT_PX Computed soil wilting point for PX (m^3/m^3) +!-- WFC_PX Computed soil field capacity for PX (m^3/m^3) +!-- WSAT_PX Computed soil saturation for PX (m^3/m^3) +!-- CLAY_PX Aggregated soil clay fraction for PX +!-- CSAND_PX Aggregated soil coarse sand fraction for PX +!-- FMSAND_PX Aggregated soil fine-medium sand fraction for PX +!-- RESTART Flag for restart run and to make sure soil moisture is not reinitialized + +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!... Outputs: + + IMPLICIT NONE + +!.......Arguments +#if defined(mpas) +! DECLARATIONS - CHARACTER + CHARACTER (LEN = 8), INTENT(IN) :: ANAL_INTERVALC + +#endif +! DECLARATIONS - INTEGER + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: NSOIL, ITIMESTEP, NLCAT, NSCAT, & +#if defined(mpas) + PXLSM_SMOIS_INIT, PXLSM_SOIL_NUDGE +#else + ANAL_INTERVAL, PXLSM_SMOIS_INIT, PXLSM_SOIL_NUDGE +#endif + + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ISLTYP +#if defined(mpas) + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IVGTYP +#endif + +! DECLARATIONS - REAL +#if defined(mpas) + REAL, INTENT(IN ) :: DTBL +#else + REAL, INTENT(IN ),OPTIONAL :: curr_secs + + REAL, INTENT(IN ) :: DT,DTBL +#endif + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: RHO, & + T3D, TH3D, DZ8W, QV3D + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: DZS + REAL, DIMENSION( ims:ime , 1:NSOIL, jms:jme ), INTENT(INOUT) :: SMOIS, TSLB + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: RA, RS, LAI, ZNT, QSFC + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: GRDFLX, TSK, TA2, QA2 + + REAL, DIMENSION( ims:ime , 1:NLCAT, jms:jme ), INTENT(IN):: LANDUSEF + REAL, DIMENSION( ims:ime , 1:NSCAT, jms:jme ), INTENT(IN):: SOILCBOT + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN) :: PSFC, GSW, GLW, RAINBL, & + SHDMIN, SHDMAX, & + PBLH, RMOL, SNOWNCV, & + UST, MAVAIL, SST, EMISS + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN) :: T2_NDG_OLD, T2_NDG_NEW, & + Q2_NDG_OLD, Q2_NDG_NEW, & + SN_NDG_OLD, SN_NDG_NEW + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: T2OBS, Q2OBS + +#if defined(mpas) + LOGICAL, INTENT(IN ) :: RESTART + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: CANWAT, QFX, HFX, LH, & +#else + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: CAPG,CANWAT, QFX, HFX, LH, & +#endif + PSIH,VEGFRA, VEGF_PX, SNOW, SNOALB, & + SNOWH, SNOWC, ALBEDO, XLAND, XICE, & + IMPERV, CANFRA + + INTEGER, OPTIONAL, INTENT(IN) :: pxlsm_modis_veg + + REAL, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, INTENT(OUT) :: LAI_PX, WWLT_PX, WFC_PX, WSAT_PX, & + CLAY_PX, CSAND_PX, FMSAND_PX + +!------------------------------------------------------------------------- +! ---------- Local Variables -------------------------------- + + + !---- PARAMETERS + INTEGER, PARAMETER :: NSTPS = 11 ! max. soil types + REAL, PARAMETER :: DTPBLX = 40.0 ! Max PX timestep = 40 sec + + + !---- INTEGERS + INTEGER :: KWAT + INTEGER, DIMENSION( 1: NSTPS ) :: JP +#if defined(mpas) + INTEGER:: J, I, K, NS, NUDGE, ISTI, DOMLU + INTEGER:: NTSPS, IT, HH, MM, SS, CURR_SECS, ANAL_INTERVAL + + !------------------------------------------------------------------- + ! MPAS Incomplete.... Moved local until added to namelist or output + REAL, DIMENSION( ims:ime, jms:jme ) :: CAPG + REAL, DIMENSION( ims:ime, 1:NLCAT, jms:jme ) :: LANDUSEFL + REAL, DIMENSION( 1:NSCAT ) :: SOILCBOTL + !------------------------------------------------------------------- +#else + INTEGER:: J, I, NS, NUDGE, ISTI + INTEGER:: NTSPS, IT +#endif + + !---- REALS + REAL, DIMENSION( ims:ime, jms:jme ) :: XLAI, XLAIMN, RSTMIN, & + XVEG, XVEGMN, XSNUP, & + XALB, XSNOALB, WETFRA + + REAL, DIMENSION( ims:ime, jms:jme ) :: RADNET, EG, ER, ETR, QST + + REAL:: SFCPRS,TA1,DENS1,QV1,ZLVL,SOLDN,LWDN, & + EMISSI,PRECIP,THETA1,VAPPRS,QSBT, & + WG,W2,WR,TG,T2,USTAR,MOLX,Z0, & + RAIR,CPAIR,IFLAND,ISNOW, & + ES,QSS,BETAP, & + RH2_OLD, RH2_NEW, T2_OLD, T2_NEW, & + CORE, CORB, TIME_BETWEEN_ANALYSIS, & + RH2OBS, HU, SNOBS, & + FWSAT,FWFC,FWWLT,FB,FCGSAT,FJP,FAS, & +#if defined(mpas) + PI, G, CPD, LUCHECK, & +#endif + FWRES, FC3, FCLAY, FCSAND, FFMSAND, & + FSEAS, T2I, HC_SNOW, SNOW_FRA,SNOWALB, & + QST12,ZFUNC,ZF1,ZA2,QV2, DT_FDDA, & + FC2R,FC1SAT, DTPBL, RAW + + CHARACTER (LEN = 6) :: LAND_USE_TYPE + CHARACTER (LEN = 512) :: message + +!------------------------------------------------------------------------- +!-------------------------------Executable starts here-------------------- +! +#if defined(mpas) + ! Variables added to make code more like WRF version + PI = pii + G = gravity + CPD = cp + + ! New MPAS Code. Convert MPAS Char string of soilndg interval to + READ(ANAL_INTERVALC(1:2),'(i)') HH + READ(ANAL_INTERVALC(4:5),'(i)') MM + READ(ANAL_INTERVALC(7:8),'(i)') SS + ANAL_INTERVAL = (HH * 3600) + (MM * 60) + (SS) + + ! Determine Landuse Dataset by the number of categories + IF (NLCAT == 40) THEN + LAND_USE_TYPE = 'NLCD40' + ELSE IF (NLCAT == 20) THEN + LAND_USE_TYPE = 'MODIS' + ELSE IF (NLCAT == 24) THEN + LAND_USE_TYPE = 'USGS' + ELSE + WRITE_MESSAGE ('P-X LSM error. Number of landuse categories not consistent with known') + WRITE(message,*) 'landuse datasets. Only MODIS20, USGS24, and NLCD40 allowed. Number input:',NLCAT + WRITE_MESSAGE(message) + FATAL_ERROR('Error: Unknown Land Use Category') + END IF +#else + ! Determine Landuse Dataset by the number of categories + IF (NLCAT == 50) THEN + LAND_USE_TYPE = 'NLCD50' + ELSE IF (NLCAT == 40) THEN + LAND_USE_TYPE = 'NLCD40' + ELSE IF (NLCAT == 20) THEN + LAND_USE_TYPE = 'MODIS' + ELSE IF (NLCAT == 21) THEN + LAND_USE_TYPE = 'MODIS' + ELSE IF (NLCAT == 24) THEN + LAND_USE_TYPE = 'USGS' + ELSE IF (NLCAT == 28) THEN + LAND_USE_TYPE = 'USGS28' + ELSE + FATAL_ERROR("Error: Unknown Land Use Category") + END IF +#endif + + IF (ITIMESTEP .EQ. 1) THEN +#if defined(mpas) + WRITE(message,*) 'Landuse dataset used in PX: ',LAND_USE_TYPE,' with',NLCAT,' categories' + WRITE_MESSAGE(message) + WRITE(message,*) 'P-X soil nudging interval, MPAS format = ',ANAL_INTERVALC + WRITE_MESSAGE(message) + WRITE(message,*) 'P-X soil nudging interval in seconds = ',ANAL_INTERVAL + WRITE_MESSAGE(message) + WRITE(message,*) 'P-X soil nudging switch (0/1):',PXLSM_SOIL_NUDGE + WRITE_MESSAGE(message) + WRITE(message,*) 'P-X soil moisture initialization switch (0/1):',PXLSM_SMOIS_INIT + WRITE_MESSAGE(message) + WRITE(message,*) 'Soil layer thickness dzs(1) and dzs(2):',DZS(1),DZS(2) + WRITE_MESSAGE(message) + WRITE(message,*) 'Restart run:',RESTART + WRITE_MESSAGE(message) +#else + WRITE(message,*) 'PX LSM will use the ' // TRIM(LAND_USE_TYPE) // ' landuse tables' + WRITE_MESSAGE(message) + PRINT *, 'The analysis interval for surface soil and temp nudging = ',ANAL_INTERVAL,'sec.' +#endif + ENDIF + + !----------------------------------------------------------------------------------- + ! Kill WRF if user specifies soil nudging but provides no analysis interval, then provide helpful message. + IF (ANAL_INTERVAL .LE. 0.0 .AND. PXLSM_SOIL_NUDGE .EQ. 1) THEN + WRITE_MESSAGE('PX LSM Error: The User specified analysis interval is zero or negative.') + WRITE_MESSAGE('If the PX LSM is used with soil nudging (pxlsm_soil_nudge=1) a wrfsfdda_d0* file is required.') + WRITE_MESSAGE('Make sure these files are present and') + WRITE_MESSAGE('Check the namelist to ensure sgfdda_interval_m is set to proper sfc analysis interval') + STOP + ENDIF + !----------------------------------------------------------------------------------- + !--- Compute time relatve to old and new analysis time for timestep interpolation + IF(PXLSM_SOIL_NUDGE .EQ. 1) THEN +#if defined(mpas) + CURR_SECS = (ITIMESTEP-1) * DTBL ! FOR MPAS + TIME_BETWEEN_ANALYSIS = MOD(CURR_SECS,ANAL_INTERVAL) +#else + DT_FDDA = ANAL_INTERVAL * 1.0 ! Convert DT of Analysis to real + TIME_BETWEEN_ANALYSIS = MOD(CURR_SECS,DT_FDDA) +#endif + IF (TIME_BETWEEN_ANALYSIS .EQ. 0.0) THEN + CORB = 1.0 + CORE = 0.0 + ELSE +#if defined(mpas) + CORE = TIME_BETWEEN_ANALYSIS / ANAL_INTERVAL +#else + CORE = TIME_BETWEEN_ANALYSIS / DT_FDDA +#endif + CORB = 1.0 - CORE + ENDIF + ENDIF +#if defined(mpas) + + !-- Test LANDUSEF input array for population. If a cell has zero landuse fraction, + ! LANDUSEF is empty, so default to dominant landuse via IVGTYP. If LANDUSEF + ! is not empty, use fractional landuse input. LANDUSEFL is local fractional + ! landuse. + DO J = jts,jte + DO I = its,ite + LUCHECK = SUM(LANDUSEF(I,:,J)) + DO K = 1,NLCAT + IF(LUCHECK .EQ. 0.0) THEN + LANDUSEFL(I,K,J) = 0.0 + ELSE + LANDUSEFL(I,K,J) = LANDUSEF(I,K,J) + ENDIF + ENDDO + IF(LUCHECK .EQ. 0.0) THEN + DOMLU = IVGTYP(I,J) + LANDUSEFL(I,DOMLU,J) = 1.0 + ENDIF + ENDDO + ENDDO + +#endif + !----------------------------------------------------------------------------------- + ! Compute vegetation and land-use characteristics by land-use fraction weighting + ! These parameters include LAI, VEGF, ZNT, ALBEDO, SNOALB, RS, etc. +#if defined(mpas) + CALL VEGELAND(LANDUSEFL, VEGFRA, SHDMIN, SHDMAX, NLCAT, & +#else + CALL VEGELAND(LANDUSEF, VEGFRA, SHDMIN, SHDMAX, NLCAT, & +#endif + ZNT,XLAI,XLAIMN,RSTMIN,XVEG,XVEGMN,XSNUP, & + XLAND, XALB,XSNOALB,WETFRA,IMPERV,CANFRA, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, LAND_USE_TYPE, & + KWAT ) + !----------------------------------------------------------------------------------- + + !----------------------------------------------------------------------------------- + ! Main loop over individual grid cells + DO J = jts,jte + DO I = its,ite + + IFLAND = XLAND(I,J) + + ! Compute soil properties via weighting of fractional components + IF (IFLAND .LT. 1.5 ) THEN + + !--------------------------------------------------------- +#if defined(mpas) + DO K = 1,NSCAT + SOILCBOTL(K) = SOILCBOT(I,K,J) + ENDDO + CALL SOILPROP (RESTART, SOILCBOTL, & +#else + CALL SOILPROP (SOILCBOT(I,:,J), & +#endif + ITIMESTEP, MAVAIL(I,J), & + PXLSM_SMOIS_INIT, & + FWSAT,FWFC,FWWLT,FCLAY,FCSAND,FFMSAND, & + FB,FCGSAT, & + FJP,FAS,FC2R,FC1SAT,FWRES, FC3, ISTI, & + SMOIS(I,1,J), SMOIS(I,2,J) ) + !---------------------------------------------------------- + !---------------------------------------------------------- + ISLTYP(I,J) = ISTI + ELSE + ISLTYP(I,J) = 14 ! STATSGO type for water + + !-- added for MODIS model + FWWLT = 0.1 + FWFC = 1.0 + FWSAT = 1.0 + + FCLAY = 0.0 + FCSAND = 0.0 + FFMSAND = 0.0 + !-- end + + ENDIF + + !-- added for MODIS model + WWLT_PX(I,J) = FWWLT + WFC_PX(I,J) = FWFC + WSAT_PX(I,J) = FWSAT + + CLAY_PX(I,J) = FCLAY * 0.01 ! percent to fraction + CSAND_PX(I,J) = FCSAND * 0.01 + FMSAND_PX(I,J) = FFMSAND * 0.01 + !-- end + + !-- Variables Sub. SURFPX needs + SFCPRS = PSFC(i,j) / 1000.0 ! surface pressure in cb + TA1 = T3D(i,1,j) ! air temperature at first layer + DENS1 = RHO(I,1,J) ! air density at first layer + QV1 = QV3D(i,1,j) ! water vapor mixing ratio at first layer + QV2 = QV3D(i,2,j) + ZLVL = 0.5 * DZ8W(i,1,j) ! thickness of lowest half level + ZF1 = DZ8W(i,1,j) + ZA2 = ZF1 + 0.5 * DZ8W(i,2,j) + + LWDN = GLW(I,J) ! longwave radiation + EMISSI = EMISS(I,J) ! emissivity + PRECIP = MAX ( 1.0E-3*RAINBL(i,j)/DTBL,0.0) ! accumulated precip. rate during DT (=dtpbl) + ! convert RAINBL from mm to m for PXLSM + WR = 1.0E-3*CANWAT(I,J) ! convert CANWAT from mm to m for PXLSM + THETA1 = TH3D(i,1,j) ! potential temp at first layer + SNOBS = SNOW(I,J) ! Set snow cover to existing model value + ! this is overwritten below if snow analysis is available + ! otherwise snow cover remains constant through simulation + + IF(PXLSM_SOIL_NUDGE .EQ. 1) THEN + !-- 2 m Temp and RH for Nudging + T2_OLD = T2_NDG_OLD(I,J) + T2_NEW = T2_NDG_NEW(I,J) +#if defined(mpas) + RH2_OLD = Q2_NDG_OLD(I,J) * 0.01 ! convert incoming RH from % to fraction + RH2_NEW = Q2_NDG_NEW(I,J) * 0.01 ! convert incoming RH from % to fraction +#else + VAPPRS = SVP1 * EXP(SVP2 * (T2_OLD - SVPT0) / ( T2_OLD - SVP3)) + QSBT = EP_2 * VAPPRS / (SFCPRS - VAPPRS) + RH2_OLD = Q2_NDG_OLD(I,J) / QSBT + VAPPRS = SVP1 * EXP(SVP2 * (T2_NEW - SVPT0) / (T2_NEW - SVP3)) + QSBT = EP_2 * VAPPRS / (SFCPRS - VAPPRS) + RH2_NEW = Q2_NDG_NEW(I,J) / QSBT +#endif + RH2OBS = CORB * RH2_OLD + CORE * RH2_NEW + T2OBS(I,J) = CORB * T2_OLD + CORE * T2_NEW + Q2OBS(I,J) = CORB * Q2_NDG_OLD(I,J) + CORE * Q2_NDG_NEW(I,J) + SNOBS = CORB * SN_NDG_OLD(I,J) + CORE * SN_NDG_NEW(I,J) + ENDIF + + USTAR = MAX(UST(I,J),0.005) + + IF (IFLAND .GE. 1.5) THEN ! if over water + ZNT(I,J) = CZO * UST(I,J) * UST(I,J) / G + OZO + ENDIF + + Z0 = ZNT(I,J) + CPAIR = CPD * (1.0 + 0.84 * QV1) ! J/(K KG) + + ! Set WRF Snow albedo to PX snow albedo based on fractional landuse + ! Snow albedo for each landuse class is defined in module_sf_pxlsm_data.F + SNOALB(I,J) = XSNOALB(I,J) + !------------------------------------------------------------- + ! Compute fractional snow area and snow albedo + CALL PXSNOW (ITIMESTEP, SNOBS, SNOWNCV(I,J), SNOW(I,J), & + SNOWH(I,J), XSNUP(I,J), XALB(i,j), & + SNOALB(I,J), & + HC_SNOW, SNOW_FRA, SNOWC(I,J), ALBEDO(I,J) ) + !------------------------------------------------------------- + + !------------------------------------------------------------- + ! Sea Ice from analysis and water cells that are very cold, but more than 50% water + ! are converted to ice/snow for more reasonable treatment. + IF( (XICE(I,J).GE.0.5) .OR. & + (SST(I,J).LE.270.0.AND.XLAND(I,J).GE.1.50) ) THEN + XLAND(I,J) = 1.0 + IFLAND = 1.0 + ZNT(I,J) = 0.001 ! Ice + SMOIS(I,1,J) = 1.0 ! FWSAT + SMOIS(I,2,J) = 1.0 ! FWSAT + XICE(I,J) = 1.0 + ALBEDO(I,J) = 0.7 + SNOWC(I,J) = 1.0 + SNOW_FRA = 1.0 + VEGF_PX(I,J) = 0.0 + LAI_PX(I,J) = 0.0 + LAI(I,J) = 0.0 + ENDIF + !------------------------------------------------------------- + + !------------------------------------------------------------- + !-- Note that when IFGROW = 0 is selected in Vegeland then max and min + !-- LAI and Veg are the same + T2I = TSLB(I,2,J) + FSEAS = AMAX1(1.0 - 0.015625 * (290.0 - T2I) ** 2,0.0) + IF (T2I .GE. 290.0) FSEAS = 1.0 + + !get PX table vegetation + LAI_PX(I,J) = XLAIMN(I,J) + FSEAS*(XLAI(I,J) - XLAIMN(I,J)) + VEGF_PX(I,J) = XVEGMN(I,J) + FSEAS*(XVEG(I,J) - XVEGMN(I,J)) + +!... use MODIS LAI and VEGFRA from wrflowinp + IF ( pxlsm_modis_veg .EQ. 1 ) THEN + + ! get LAI for vegetated area + IF ( VEGFRA(I,J) .GT. 0.0 ) THEN + LAI_PX(I,J) = LAI(I,J) / ( VEGFRA(I,J) / 100.0) + ELSE + LAI_PX(I,J) = 0.0 + ENDIF + + VEGF_PX(I,J) = VEGFRA(I,J) / 100.0 + + !vegF is just for the land + IF ( LANDUSEF(I,KWAT,J) .LT. 1.0 ) THEN + VEGF_PX(I,J) = VEGF_PX(I,J) / (1.0 - LANDUSEF(I,KWAT,J)) + ELSE + VEGF_PX(I,J) = 0.0 + ENDIF + + ENDIF + + LAI_PX(I,J) = MIN(LAI_PX(I,J), 8.0) + LAI_PX(I,J) = MAX(LAI_PX(I,J), 0.0001) + + VEGF_PX(I,J) = MIN(VEGF_PX(I,J), 1.0) + VEGF_PX(I,J) = MAX(VEGF_PX(I,J), 0.0001) + +!... END OF MODIS LAI and FPAR + + + ! Ensure veg algorithms not used for water + IF (IFLAND .GE. 1.5) THEN + VEGF_PX(I,J) = 0.0 + LAI_PX(I,J) = 0.0 + ENDIF + !------------------------------------------------------------- + + + SOLDN = GSW(I,J) / (1.0 - ALBEDO(I,J)) ! downward shortwave radiaton + ISNOW = SNOWC(I,J) + + + NUDGE=PXLSM_SOIL_NUDGE +#if defined(mpas) + ! Changed for MPAS since array dimensions are 1 x NCELLS + !IF ( J .LE. 2 .OR. J .GE. (jde-1) ) NUDGE=0 + !IF ( I .LE. 2 .OR. I .GE. (ide-1) ) NUDGE=0 +#else + IF ( J .LE. 2 .OR. J .GE. (jde-1) ) NUDGE=0 + IF ( I .LE. 2 .OR. I .GE. (ide-1) ) NUDGE=0 +#endif + + IF ( RMOL(I,J) .GT. 0.0 ) THEN + MOLX = AMIN1(1/RMOL(I,J),1000.0) + ELSE IF ( RMOL(I,J) .LT. 0.0 ) THEN + MOLX = AMAX1(1/RMOL(I,J),-1000.0) + ELSE + MOLX = 1000 + ENDIF + + ZFUNC = ZF1 * (1.0 - ZF1 / MAX(100.,PBLH(I,J))) ** 2 + QST12 = KARMAN * ZFUNC*(QV2-QV1) / (ZA2-ZLVL) + + + !------------------------------------------------------------- + !-- LSM sub-time loop too prevent dt > 40 sec +#if defined(mpas) + NTSPS = INT(DTBL / (DTPBLX + 0.000001) + 1.0) ! Changed from DT to DTBL in case not called every tmestep + DTPBL = DTBL / NTSPS ! JP 5/16 +#else + NTSPS = INT(DT / (DTPBLX + 0.000001) + 1.0) + DTPBL = DT / NTSPS +#endif + + DO IT=1,NTSPS + + !... SATURATION VAPOR PRESSURE (MB) + IF ( TSLB(I,1,J) .LE. SVPT0 ) THEN ! For ground that is below freezing + ES = SVP1 * EXP(22.514 - 6.15E3 / TSLB(I,1,J)) ! cb + ELSE + ES = SVP1 * EXP(SVP2 * (TSLB(I,1,J) - SVPT0) / (TSLB(I,1,J) - SVP3)) + ENDIF + QSS = ES * 0.622 / (SFCPRS - ES) + + !... beta method, Lee & Pielke (JAM,May1992) + BETAP = 1.0 + IF (IFLAND .LT. 1.5 .AND. ISNOW .LT. 0.5 .AND. SMOIS(I,1,J) .LE. FWFC) THEN + BETAP = 0.25 * (1.0 - COS(SMOIS(I,1,J) / FWFC * PI)) ** 2 + ENDIF + + !------------------------------------------------------------------------- + CALL SURFPX (DTPBL, IFLAND, SNOWC(I,J), NUDGE, XICE(I,J), & !in + SOLDN, GSW(I,J), LWDN, EMISSI, ZLVL, & !in + MOLX, Z0, USTAR, & !in + SFCPRS, DENS1, QV1, QSS, TA1, & !in + THETA1, PRECIP, & !in + CPAIR, PSIH(I,J), & !in + RH2OBS,T2OBS(I,J), & !in + VEGF_PX(I,J), ISTI, LAI_PX(I,J), IMPERV(I,J), CANFRA(I,J),& !in + BETAP, RSTMIN(I,J), HC_SNOW, SNOW_FRA, WETFRA(I,J), & !in + FWWLT, FWFC, FWRES, FCGSAT, FWSAT, FB, & !in ! Soil model updates - JEP 12/14 + FC1SAT,FC2R,FAS,FJP,FC3,DZS(1),DZS(2),QST12, & !in + RADNET(I,J), GRDFLX(I,J), HFX(I,J), QFX(I,J), LH(I,J), & !out + EG(I,J), ER(I,J), ETR(I,J), & !out + QST(I,J), CAPG(I,J), RS(I,J), RA(I,J), & !out + TSLB(I,1,J), TSLB(I,2,J), & !out + SMOIS(I,1,J), SMOIS(I,2,J), WR, & + TA2(I,J), QA2(I,J), LAND_USE_TYPE,I,J ) + !------------------------------------------------------------------------- + + END DO ! Time internal PX time loop + + IF (IFLAND .GE. 1.5) THEN + TSK(I,J) = SST(I,J) ! Skin temp set to sea surface temperature for open water + ELSE + TSK(I,J) = TSLB(I,1,J) ! Skin temp set to 1 cm soil temperature in PX for now + ENDIF + CANWAT(I,J) = WR * 1000. ! convert WR back to mm for CANWAT + RAW = RA(I,J) + 4.503 / USTAR + QSFC(I,J) = QFX(I,J) * RAW / DENS1 + QV1 + + ENDDO + ENDDO + +!------------------------------------------------------ + END SUBROUTINE pxlsm +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + + +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + SUBROUTINE VEGELAND( landusef, vegfra, & + shdmin, shdmax, & + nlcat, znt, xlai, & + xlaimn, rstmin, xveg, xvegmn, xsnup, xland, & + xalb, xsnoalb, wetfra, imperv, canfra, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + LAND_USE_TYPE, KWAT_OUT ) +!------------------------------------------------------------------------- +! +! CALLED FROM Sub. bl_init in module_physics.init.F +! +! THIS PROGRAM PROCESSES THE USGS LANDUSE DATA +! WHICH HAS BEEN GRIDDED BY THE WPS SYSTEM +! AND PRODUCES 2-D FIELDS OF LU RELATED PARAMETERS +! FOR USE IN THE PX SURFACE MODEL +! +! +! REVISION HISTORY: +! AX Oct 2004 - developed WRF version based on VEGELAND in the MM5 PX LSM +! RG Dec 2006 - revised for WRFV2.1.2 +! JP Dec 2007 - revised for WRFV3 - removed IFGROW options +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + + IMPLICIT NONE +!... + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER , INTENT(IN) :: NLCAT + + REAL, DIMENSION( ims:ime , 1:NLCAT, jms:jme ), INTENT(IN) :: LANDUSEF + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: VEGFRA, SHDMIN, SHDMAX + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZNT, IMPERV, CANFRA + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: XLAI, XLAIMN, RSTMIN, XALB, & + XVEG, XVEGMN, XSNUP, XLAND, & + WETFRA, XSNOALB + + INTEGER, INTENT(OUT) :: KWAT_OUT + + CHARACTER (LEN = 6), INTENT(IN) :: LAND_USE_TYPE + + +!... local variables + + INTEGER :: ITF, JTF, K, J, I + REAL :: SUMLAI, SUMLMN, SUMRSI, SUMLZ0, SUMVEG, SUMVMN, & + ALAI, VEGF, SUMSNUP, SUMALB, SUMSNOALB + + REAL :: VFMX, VFMN, VSEAS, FAREA, FWAT, ZNOTC, FCAN, FIMP, FORFRA, EXTFOR + REAL, DIMENSION( NLCAT ) :: LAIMX, LAIMN, Z0, VEG, VEGMN, SNUP, ALB, SNOALB + + REAL, PARAMETER :: ZNOTCMN = 5.0 ! CM, MIN Zo FOR CROPS + REAL, PARAMETER :: ZNOTCMX = 15.0 ! CM, MAX Zo FOR CROPS + + REAL, SAVE, DIMENSION(:), POINTER :: RSMIN, Z00, VEG0, VEGMN0, LAI0, & + LAIMN0, SNUP0, ALBF, SNOALBF + + CHARACTER (LEN = 512) :: message + + !---- INITIALIZE PARAMETERS + INTEGER, SAVE :: KWAT, LIMIT1, LIMIT2 + + ! Initialize LU characteristics by LU Dataset + IF (LAND_USE_TYPE == 'USGS') THEN + KWAT = 16 + RSMIN => RSMIN_USGS + Z00 => Z00_USGS + VEG0 => VEG0_USGS + VEGMN0 => VEGMN0_USGS + LAI0 => LAI0_USGS + LAIMN0 => LAIMN0_USGS + SNUP0 => SNUP0_USGS + ALBF => ALBF_USGS + SNOALBF=> SNOALB_USGS + LIMIT1 = 2 + LIMIT1 = 6 + ELSE IF (LAND_USE_TYPE == 'USGS28') THEN + KWAT = 16 + RSMIN => RSMIN_USGS28 + Z00 => Z00_USGS28 + VEG0 => VEG0_USGS28 + VEGMN0 => VEGMN0_USGS28 + LAI0 => LAI0_USGS28 + LAIMN0 => LAIMN0_USGS28 + SNUP0 => SNUP0_USGS28 + ALBF => ALBF_USGS28 + SNOALBF=> SNOALB_USGS28 + LIMIT1 = 2 + LIMIT1 = 6 + ELSE IF (LAND_USE_TYPE == 'NLCD50') THEN + KWAT = 1 + RSMIN => RSMIN_NLCD50 + Z00 => Z00_NLCD50 + VEG0 => VEG0_NLCD50 + VEGMN0 => VEGMN0_NLCD50 + LAI0 => LAI0_NLCD50 + LAIMN0 => LAIMN0_NLCD50 + SNUP0 => SNUP0_NLCD50 + ALBF => ALBF_NLCD50 + SNOALBF=> SNOALB_NLCD50 + LIMIT1 = 20 + LIMIT1 = 43 + ELSE IF (LAND_USE_TYPE == 'NLCD40') THEN + KWAT = 17 + RSMIN => RSMIN_NLCD40 + Z00 => Z00_NLCD40 + VEG0 => VEG0_NLCD40 + VEGMN0 => VEGMN0_NLCD40 + LAI0 => LAI0_NLCD40 + LAIMN0 => LAIMN0_NLCD40 + SNUP0 => SNUP0_NLCD40 + ALBF => ALBF_NLCD40 + SNOALBF=> SNOALB_NLCD40 + LIMIT1 = 20 + LIMIT1 = 43 + ELSE IF (LAND_USE_TYPE == 'MODIS') THEN + KWAT = 17 + RSMIN => RSMIN_MODIS + Z00 => Z00_MODIS + VEG0 => VEG0_MODIS + VEGMN0 => VEGMN0_MODIS + LAI0 => LAI0_MODIS + LAIMN0 => LAIMN0_MODIS + SNUP0 => SNUP0_MODIS + ALBF => ALBF_MODIS + SNOALBF=> SNOALB_MODIS + LIMIT1 = 12 + LIMIT1 = 14 + END IF + + KWAT_OUT = KWAT + !-------------------------------------------------------------------- + DO J = jts,jte + DO I = its,ite + XLAI(I,J) = 0.0 + XLAIMN(I,J) = 0.0 + RSTMIN(I,J) = 9999.0 + XVEG(I,J) = 0.0 + XVEGMN(I,J) = 0.0 + XSNUP(I,J) = 0.0 + XALB(I,J) = 0.0 + XSNOALB(I,J)= 0.0 + + ! Code that may be needed in case these arrays are not intialized + ! with zero by real.exe when not defined by GEOGRID or present + ! in met_em* files + !IMPERV(I,J) = AMAX1(0.0001,IMPERV(I,J)) + !CANFRA(I,J) = AMAX1(0.0001,CANFRA(I,J)) + + ENDDO + ENDDO + !-------------------------------------------------------------------- + + DO J = jts,jte + DO I = its,ite + !-- Initialize 2 and 3-D veg parameters to be caculated + DO K=1,NLCAT + LAIMX(K) = LAI0(K) + LAIMN(K) = LAIMN0(K) + Z0(K) = Z00(K) + VEG(K) = VEG0(K) + VEGMN(K) = VEGMN0(K) + SNUP(K) = SNUP0(K) + ALB(K) = ALBF(K) + SNOALB(K)= SNOALBF(K) + ENDDO + + !-- INITIALIZE SUMS + SUMLAI = 0.0 + SUMLMN = 0.0 + SUMRSI = 0.0 + SUMLZ0 = 0.0 + SUMVEG = 0.0 + SUMVMN = 0.0 + ALAI = 0.0 + SUMSNUP = 0.0 + SUMALB = 0.0 + SUMSNOALB = 0.0 + + !-- ESTIMATE CROP EMERGANCE DATE FROM VEGFRAC + VFMX = SHDMAX(I,J) + VFMN = SHDMIN(I,J) + VEGF = VEGFRA(I,J) + + !-- Computations for VEGETATION CELLS ONLY + IF(VFMX.GT.0.0.AND.LANDUSEF(I,KWAT,J).LT.1.00) THEN + VSEAS = VEGF/VFMX + IF(VSEAS.GT.1.0.OR.VSEAS.LT.0.0) THEN + VSEAS = MIN(VSEAS,1.0) + VSEAS = MAX(VSEAS,0.0) + ENDIF + + ZNOTC = ZNOTCMN * (1-VSEAS) + ZNOTCMX * VSEAS ! Zo FOR CROPS + DO K = 1, NLCAT + IF (LAND_USE_TYPE == 'MODIS') THEN + !-- USE THE VEGFRAC DATA ONLY FOR CROPS + IF (K.EQ.12 .OR. K.EQ.14) THEN + LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS + LAIMN(K) = LAIMX(K) + VEG(K) = VEGMN0(K) * (1-VSEAS) + VEG0(K) * VSEAS + VEGMN(K) = VEG(K) + !-- SEASONALLY VARY Zo FOR MODIS DryCrop (k=12) + IF (K .EQ. 12) THEN + Z0(K) = ZNOTC + !-- CrGrM (k=14) USE AVG WITH GRASS AND FOREST + ELSE IF (K .EQ.14) THEN + Z0(K) = 0.5 * (ZNOTC + Z00(K)) + ENDIF + ENDIF + ELSE IF (LAND_USE_TYPE == 'NLCD50') THEN + !-- USE THE VEGFRAC DATA ONLY FOR CROPS + IF (K.EQ.20 .OR. K.EQ.43 .OR. K.EQ.45) THEN + LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS + LAIMN(K) = LAIMX(K) + VEG(K) = VEGMN0(K) * (1-VSEAS) + VEG0(K) * VSEAS + VEGMN(K) = VEG(K) + !-- SEASONALLY VARY Zo FOR DryCrop (k=20) OR Irigated Crop (k=43) OR Mix Crop (k=4) + IF (K.EQ.20 .OR. K.EQ.43) THEN + Z0(K) = ZNOTC + !-- CrNatM (k=45) USE AVG WITH GRASS AND FOREST + ELSE IF (K.EQ.45) THEN + Z0(K) = 0.5 * (ZNOTC + Z00(K)) + ENDIF + ENDIF + ELSE IF (LAND_USE_TYPE == 'NLCD40') THEN + !-- USE THE VEGFRAC DATA ONLY FOR CROPS + IF (K.EQ.12 .OR. K.EQ.14 .OR. K.EQ.38) THEN + LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS + LAIMN(K) = LAIMX(K) + VEG(K) = VEGMN0(K) * (1-VSEAS) + VEG0(K) * VSEAS + VEGMN(K) = VEG(K) + !-- SEASONALLY VARY Zo FOR Crop (k=12 for MODIS or 38 for NLCD) + IF (K.EQ.12 .OR. K.EQ.38) THEN + Z0(K) = ZNOTC + !-- CrNatM (k=14) USE AVG WITH GRASS AND FOREST + ELSE IF (K.EQ.14) THEN + Z0(K) = 0.5 * (ZNOTC + Z00(K)) + ENDIF + ENDIF + ELSE IF (LAND_USE_TYPE == 'USGS') THEN + !-- USE THE VEGFRAC DATA ONLY FOR CROPS + IF (K .GE. 2 .AND. K .LE. 6) THEN + LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS + LAIMN(K) = LAIMX(K) + VEG(K) = VEGMN0(K) * (1-VSEAS) + VEG0(K) * VSEAS + VEGMN(K) = VEG(K) + !-- SEASONALLY VARY Zo FOR DryCrop (k=2) OR Irigated Crop (k=3) OR Mix Crop (k=4) + IF (K .GE. 2 .AND. K .LE. 4) THEN + Z0(K) = ZNOTC + !-- CrGrM (k=5) or CrWdM (k=6) USE AVG WITH GRASS AND FOREST + ELSE IF (K .GE.5 .AND. K .LE. 6) THEN + Z0(K) = 0.5 * (ZNOTC + Z00(K)) + ENDIF + ENDIF + ELSE IF (LAND_USE_TYPE == 'USGS28') THEN + !-- USE THE VEGFRAC DATA ONLY FOR CROPS + IF (K .GE. 2 .AND. K .LE. 6) THEN + LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS + LAIMN(K) = LAIMX(K) + VEG(K) = VEGMN0(K) * (1-VSEAS) + VEG0(K) * VSEAS + VEGMN(K) = VEG(K) + !-- SEASONALLY VARY Zo FOR DryCrop (k=2) OR Irigated Crop (k=3) OR Mix Crop (k=4) + IF (K .GE. 2 .AND. K .LE. 4) THEN + Z0(K) = ZNOTC + !-- CrGrM (k=5) or CrWdM (k=6) USE AVG WITH GRASS AND FOREST + ELSE IF (K .GE.5 .AND. K .LE. 6) THEN + Z0(K) = 0.5 * (ZNOTC + Z00(K)) + ENDIF + ENDIF + + END IF + + ENDDO + + ENDIF !-- IF cell is vegetation + + !------------------------------------- + !-- LOOP THROUGH LANDUSE Fraction and compute totals + DO K = 1, NLCAT + FAREA = LANDUSEF(I,K,J) + SUMLAI = SUMLAI + LAIMX(K) * FAREA + SUMLMN = SUMLMN + LAIMN(K) * FAREA + ALAI = ALAI + FAREA + SUMRSI = SUMRSI + FAREA * LAIMX(K) / RSMIN(K) + SUMLZ0 = SUMLZ0 + FAREA * ALOG(Z0(K)) + SUMVEG = SUMVEG + FAREA * VEG(K) + SUMVMN = SUMVMN + FAREA * VEGMN(K) + SUMSNUP = SUMSNUP+ FAREA * SNUP(K) + SUMALB = SUMALB + FAREA * ALB(K) + SUMSNOALB= SUMSNOALB + FAREA * SNOALB(K) + ENDDO + + FWAT = LANDUSEF(I,KWAT,J) + !-- CHECK FOR WATER + IF (FWAT .GE. 0.50) THEN ! Changed WRFV3.7 + XLAI(I,J) = LAIMX(KWAT) + XLAIMN(I,J) = LAIMN(KWAT) + RSTMIN(I,J) = RSMIN(KWAT) + ZNT(I,J) = Z0(KWAT) + XVEG(I,J) = VEG(KWAT) + XVEGMN(I,J) = VEGMN(KWAT) + XSNUP(I,J) = SNUP(KWAT) + XALB(I,J) = ALB(KWAT) + XSNOALB(I,J)= SNOALB(KWAT) + ELSE + IF (FWAT .GT. 0.10) THEN + ALAI = ALAI - FWAT + SUMLZ0 = SUMLZ0 - FWAT * ALOG(Z0(KWAT)) + ENDIF + XLAI(I,J) = SUMLAI / ALAI + XLAIMN(I,J) = SUMLMN / ALAI + RSTMIN(I,J) = SUMLAI / SUMRSI + ZNT(I,J) = EXP(SUMLZ0/ALAI) + XVEG(I,J) = SUMVEG / ALAI + XVEGMN(I,J) = SUMVMN / ALAI + XSNUP(I,J) = SUMSNUP + XALB(I,J) = SUMALB + XSNOALB(I,J)= SUMSNOALB + ENDIF + + IF (FWAT .GT. 0.50) THEN + ZNT(I,J) = Z0(KWAT) + XALB(I,J) = ALB(KWAT) + XSNOALB(I,J)= SNOALB(KWAT) + ENDIF + + !-- Compute wetlands fraction for proper MMLUIN data set + !-- Note: if LU categories change, these hard coded indicies must be updated + IF (LAND_USE_TYPE == 'USGS') THEN + WETFRA(I,J) = LANDUSEF(I,17,J)+LANDUSEF(I,18,J) + ELSE IF (LAND_USE_TYPE == 'USGS28') THEN + WETFRA(I,J) = LANDUSEF(I,17,J)+LANDUSEF(I,18,J) + ELSE IF (LAND_USE_TYPE == 'NLCD50') THEN + WETFRA(I,J) = LANDUSEF(I,22,J)+LANDUSEF(I,23,J)+LANDUSEF(I,27,J)+LANDUSEF(I,28,J)+LANDUSEF(I,42,J) + ELSE IF (LAND_USE_TYPE == 'NLCD40') THEN + WETFRA(I,J) = LANDUSEF(I,39,J)+LANDUSEF(I,40,J)+LANDUSEF(I,11,J) + ELSE IF (LAND_USE_TYPE == 'MODIS') THEN + WETFRA(I,J) = LANDUSEF(I,11,J) + END IF + + ZNT(I,J) = ZNT(I,J) * 0.01 !CONVERT TO M + XVEG(I,J) = XVEG(I,J) * 0.01 !CONVERT TO FRAC + XVEGMN(I,J) = XVEGMN(I,J) * 0.01 + XLAND(I,J) = 1.0 + FWAT + XALB(I,J) = XALB(I,J) * 0.01 + XSNOALB(I,J)= XSNOALB(I,J) * 0.01 + + !-------Adjustment according to CANFRA and IMPERV fo NLCD40 only ----------- + FIMP = IMPERV(I,J) * 0.01 + FCAN = CANFRA(I,J) * 0.01 + IF (LAND_USE_TYPE == 'NLCD40') THEN + XVEG(I,J) = MIN(XVEG(I,J),1.0-FIMP) + XVEGMN(I,J) = MIN(XVEGMN(I,J),1.0-FIMP) + XVEG(I,J) = MAX(XVEG(I,J),FCAN) + XVEGMN(I,J) = MAX(XVEGMN(I,J),FCAN) + + FORFRA = LANDUSEF(I,39,J)+LANDUSEF(I,30,J)+LANDUSEF(I,29,J)+LANDUSEF(I,28,J) + EXTFOR = FCAN - FORFRA + IF (EXTFOR.GE.0.01) THEN + XLAI(I,J) = LAIMX(30) * EXTFOR + XLAI(I,J) * (1-EXTFOR) + XLAIMN(I,J) = LAIMN(30) * EXTFOR + XLAIMN(I,J) * (1-EXTFOR) + ENDIF + ENDIF + !-------------------------------------------------------------------------- + + ENDDO + ENDDO + !-------------------------------------------------------------------- + + END SUBROUTINE vegeland + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, SOLDN, GSW, & !in + LWDN, EMISSI, Z1, MOL, ZNT, UST, PSURF, DENS1, & !in + QV1, QSS, TA1, THETA1, PRECIP, CPAIR, PSIH, & !in + RH2OBS, T2OBS, VEGFRC, ISTI,LAI,IMPERV,CANFRA,BETAP, & !in + RSTMIN, HC_SNOW, SNOW_FRA, WETFRA, WWLT, WFC, & !in + WRES, CGSAT, WSAT, B, C1SAT, C2R, AS, JP, C3, DS1, & !in + DS2, QST12, & !in + RADNET, GRDFLX, HFX, QFX, LH, EG, ER, ETR, & !out + QST, CAPG, RS, RA, TG, T2, WG, W2, WR, & !out + TA2, QA2, LAND_USE_TYPE, I, J ) !out + +!------------------------------------------------------------------------------ +! +! FUNCTION: +! THIS SUBROUTINE COMPUTES SOIL MOISTURE AND TEMPERATURE TENDENCIES +! BY SOLVING THE PROGNOSTIC EQUATIONS IN PX95. +! +! SUBROUTINES CALLED: +! SUB. QFLUX compute the soil and canopy evaporation, and transpiration +! SUB. SMASS compute nudging coefficients for soil moisture and temp nudging +! +! ARGUMENTS: +! DTPBL: TIME STEP OF THE MINOR LOOP FOR THE LAND-SURFACE/PBL MODEL +! IFLAND: INDEX WHICH INDICATES THE TYPE OF SURFACE,=1,LAND;=2,SEA +! ISNOW: SNOW (=1) OR NOT (=0) +! NUDGE: SWITCH FOR SOIL MOISTURE NUDGING +! SOLDN: SHORT-WAVE RADIATION +! LWDN: LONG-WAVE RADIATION +! EMISSI: EMISSIVITY +! Z1: HEIGHT OF THE LOWEST HALF LAYER +! MOL: MONIN-OBUKOV LENGH (M) +! ZNT: ROUGHNESS LENGTH (M) +! UST: FRICTION VELOCITY (M/S) +! TST: Turbulent moisture scale +! RA: AERODYNAMIC RESISTENCE +! PSURF: P AT SURFACE (CB) +! DENS1: AIR DENSITY AT THE FIRST HALF LAYER +! QV1: Air humidity at first half layer +! QSS: Saturation mixing ratio at ground +! TA1: Air temperature at first half layer +! THETA1: Potential temperature at first half layer +! PRECIP: Precipitation rate in m/s +! STBOLT: STEFAN BOLTZMANN'S CONSTANT +! KARMAN: VON KARMAN CONSTANT +! CPAIR: Specific heat of moist air (M^2 S^-2 K^-1) +! PSIH Similarity stability function for heat +! TAUINV: 1/1DAY(SEC) +! VEGFRC: Vegetation coverage +! ISTI: soil type +! LAI: Leaf area index +! IMPERV: Percentage of IMPERVIOUS Fraction +! CANFRA: Percentage of Canopy/Tree Fraction +! BETAP: Coefficient for bare soil evaporation +! WETFRA: Fraction of Wetlands area +! T2OBS: Observed temperature at SCREEN HT (K) +! RH2OBS: Observed relative humidity at SCREEN HT (fraction) +! RSTMIN Minimum Stomatol resistence +!... Outputs from SURFPX +! RADNET: Net radiation +! HFX: SENSIBLE HEAT FLUX (W / M^2) +! QFX: TOTAL EVAP FLUX (KG / M^2 S) +! GRDFLX: Ground heat flux (W / M^2) +! QST: Turbulent moisture scale +! CAPG: THERMAL CAPACITY OF GROUND SLAB (J/M^2/K) +! RS: Surface resistence +! RA: Surface aerodynamic resistence +! EG: evaporation from ground (bare soil) +! ER: evaporation from canopy +! ETR: transpiration from vegetation +! TA2: diagnostic 2-m temperature from surface layer and lsm +! +!... Updated variables in this subroutine +! TG: Soil temperature at first soil layer +! T2: Soil temperature in root zone +! WG: Soil moisture at first soil layer +! W2: Soil moisture at root zone +! WR: Canopy water content in m +! +! REVISION HISTORY: +! AX 2/2005 - developed WRF version based on the MM5 PX LSM +! +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + IMPLICIT NONE + +!.......Arguments + +!.. Integer + INTEGER , INTENT(IN) :: ISTI, NUDGEX, I, J + +!... Real + REAL , INTENT(IN) :: DTPBL, DS1, DS2 + REAL , INTENT(IN) :: IFLAND, ISNOW, XICE1 + REAL , INTENT(IN) :: SOLDN, GSW, LWDN, EMISSI, Z1 + REAL , INTENT(IN) :: ZNT + REAL , INTENT(IN) :: PSURF, DENS1, QV1, QSS, TA1, THETA1, PRECIP + REAL , INTENT(IN) :: CPAIR + REAL , INTENT(IN) :: VEGFRC, LAI, IMPERV, CANFRA + REAL , INTENT(IN) :: RSTMIN, HC_SNOW, SNOW_FRA, WETFRA + REAL , INTENT(IN) :: WWLT, WFC, WRES, CGSAT, WSAT, B, C1SAT, C2R, AS, JP, C3 + REAL , INTENT(IN) :: RH2OBS,T2OBS + REAL , INTENT(IN) :: QST12 + + REAL , INTENT(OUT) :: RADNET, EG, ER, ETR + REAL , INTENT(OUT) :: QST, CAPG, RS, TA2, QA2 + + REAL , INTENT(INOUT) :: TG, T2, WG, W2, WR, UST, RA, BETAP + REAL , INTENT(INOUT) :: GRDFLX, QFX, HFX, LH, PSIH, MOL + + CHARACTER (LEN = 6), INTENT(IN) :: LAND_USE_TYPE + +!... Local Variables + +!... Real +#if defined(mpas) + REAL :: PI, ROVCP, DENW +#endif + REAL :: HF, LV, CQ4, WETSAT, SM2 + REAL :: RAH, RAW, ET, W2CG, CG, CT, SOILFLX, CPOT, THETAG + REAL :: ZOL, ZOBOL, ZNTOL, Y, Y0, PSIH15, YNT + REAL :: WGNUDG, W2NUDG, ALPH1, ALPH2, BET1, BET2, T1P5 + REAL :: CQ1, CQ2, CQ3, COEFFNP1, COEFFN, TSNEW, TSHLF, T2NEW + REAL :: ROFF, WRMAX, PC, DWR, PNET, TENDWR, WRNEW + REAL :: COF1, CFNP1WR, CFNWR, PG, FASS + REAL :: TENDW2, W2NEW, W2HLF, W2REL, C1, C2, WEQ, CFNP1, CFN, WGNEW + REAL :: ALN10, TMP1, TMP2, TMP3, AA, AB, TST, RBH, CTVEG + REAL :: QST1,PHIH,PSIOB + REAL :: T2NUD, T2NUDF + REAL :: VAPPRS, QSBT, RH2MOD, IMF, VEGF, SOILF + REAL :: RSOIL, LDRY, DP + REAL :: C1MAX,ZZA,ZZB,ZDEL,ZLY,ZA,ZB,ZY2 + REAL :: RINC, HCAN + + CHARACTER (LEN = 512) :: message + +!... Parameters + REAL :: ZOBS, GAMAH, BETAH, SIGF, BH, CT_SNOW, CT_IMPERV + + REAL, PARAMETER :: CV = 1.2E-5 ! K-M2/J Note: Update from 8E-6 10/14 Jon Pleim + + PARAMETER (ZOBS = 1.5) ! height for observed screen temp., (m) + PARAMETER (BH = 15.7) + PARAMETER (GAMAH = 16. ) !11.6) + PARAMETER (BETAH = 5.0 ) !8.21) + PARAMETER (SIGF = 0.5) ! rain interception see LSM (can be 0-1) + REAL, PARAMETER :: DWAT = 0.2178 ! [cm^2 / s] at 273.15K + !-------------------------------------------------------------------- + ! OLD PX legacy value from MM5 ... unknown origin PARAMETER (CT_SNOW = 5.54E-5) + ! New value of CT_SNOW calibrated using multilayer soil model where csnow=6.9E5 J/(m3 K) + ! from NCAR (WRFV3.2 -WRFV3.6.1) CSM PARAMETER (CT_SNOW = 2.0E-5) + PARAMETER (CT_SNOW = 2.0E-5) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CS for concrete/asphalt/road material (http://www.engineeringtoolbox.com/specific-heat-capacity-d_391.html) + ! cs_imperv = 920 J kg-1 K-1 + ! CS for asphalt and concrete from 0.1785 to 0.20 cal g-1 K-1 (http://pages.towson.edu/morgan/files/Impervious.pdf) + ! the values above translate to ~750 to 850 J kg-1 K-1 + ! + ! CAPG used for WRF urban physics ranges from 1.0E6 for roof and building walls to 1.4E6 J m-3 K-1 for roads/urban ground + ! Using these values to back out CS along with 0.15 m thickness 1.4E6 J m-3 K-1 * 0.15 m = 2.1E5 J m-2 K-1 + ! inverse of the value above gives CT_IMPERV value of 1/0.000021 = 4.762E-6 K m2 J-1 + + ! The middle value will be used for now. 850 J kg-1 K-1. This needs to be converted from J/K per kg to area using + ! the approxiate concrete/asphalt density and layer thickness or represenative thickness. For starters (12/2011) + ! well not use the PX first layer thickness, but representative thickness of most roads/parkinglots/buildings. + ! for now welll use 6 inches or about 15 cm or 0.15 m. Density of concrete (normal) from + ! Dorf, Richard. Engineering Handbook. New York: CRC Press, 1996. is ~2400 kg m-3. + ! Using these values 850 J kg-1 K-1 * 2400 kg m-3 * 0.15 m = 3.06E5 J m-2 K-1 or in CT form (inverse) 3.268E-6 K m2 J-1 + ! If you look at the range of possible values considering density differences of concrete/asphalt/etc + ! Values can range from 2.5 to 6.0 E-6 + PARAMETER (CT_IMPERV = 3.268E-6) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#if defined(mpas) + PI = pii + ROVCP = rcp + DENW = rho_w +#endif + ALN10 = ALOG(10.0) + RADNET = SOLDN - (EMISSI *(STBOLT *TG **4 - LWDN)) ! NET RADIATION + !-------------------------------------------------------------------- + CPOT = (100.0 / PSURF) ** ROVCP ! rcp is global constant(module_model_constants) + THETAG = TG * CPOT + + ZOL = Z1/MOL + ZOBOL = ZOBS/MOL + ZNTOL = ZNT/MOL + + !----------------------------------------------------------------------------------------- + IF (MOL .LT. 0.0) THEN + Y = ( 1.0 - GAMAH * ZOL ) ** 0.5 + Y0 = ( 1.0 - GAMAH * ZOBOL ) ** 0.5 + YNT = ( 1.0 - GAMAH * ZNTOL ) ** 0.5 + PSIH15 = 2.0 * ALOG((Y + 1.0) / (Y0 + 1.0)) + PSIH = 2.0 * ALOG((Y + 1.0) / (YNT + 1.0)) + PSIOB = 2.0 * ALOG((Y0 + 1.0) / (YNT + 1.0)) + PHIH = 1.0 / Y + ELSE + IF ((ZOL - ZNTOL) .LE. 1.0) THEN + PSIH = -BETAH*(ZOL-ZNTOL) + ELSE + PSIH = 1.-BETAH-(ZOL-ZNTOL) + ENDIF + IF ((ZOBOL - ZNTOL) .LE. 1.0) THEN + PSIOB = -BETAH * (ZOBOL - ZNTOL) + ELSE + PSIOB = 1.0 - BETAH - (ZOBOL - ZNTOL) + ENDIF + PSIH15 = PSIH - PSIOB + IF (ZOL .LE. 1.0) THEN + PHIH = 1.0 + BETAH * ZOL + ELSE + PHIH = BETAH + ZOL + ENDIF + ENDIF + !----------------------------------------------------------------------------------------- + !-- ADD RA AND RB FOR HEAT AND MOISTURE + !... RB FOR HEAT = 5 /UST + !... RB FOR WATER VAPOR = 5*(0.599/0.709)^2/3 /UST = 4.503/UST + RA = PR0* ( ALOG(Z1/ZNT) - PSIH )/(KARMAN*UST) + RAH = RA + 5.0 / UST + RAW = RA + 4.503 / UST + IF (IFLAND .LT. 1.5 .AND. XICE1 .LT. 0.5) THEN + LDRY = 1.75*DS1*(EXP((1.-WG/WSAT)**5)-1.)/1.718 ! 1.75 cm is the layer thickness used by S&Z09 + DP = DWAT*1.E-4 * WSAT**2 * (1.-WRES/WSAT)**(2.+3./B) + RSOIL = LDRY/DP + ELSE + RSOIL = 0.0 + ENDIF + !-------------------------------------------------------------------- + ! Compute soil moisture layer 2 that considers fraction of saturated + ! wetlands. If 100% of cell is wetland, soil moisture can be no lower + ! than full soil saturation. If half wetland, no less than half saturated + IF (IFLAND .LT. 1.5) THEN + WETSAT = 1.00 * WSAT ! Wetlands soil moisture + SM2 = (WETFRA * WETSAT) ! + W2 = AMAX1(SM2, W2) ! In case that W2 > Field capacity (heavy precip), use wetter W2 + ENDIF + + !-------------------------------------------------------------------- + ! In-canopy resistance - Erisman et al (1994) + HCAN = ZNT * 10.0 + RINC = 14.0 * LAI* HCAN / UST + + !-------------------------------------------------------------------- + !-- COMPUTE MOISTURE FLUX + CALL QFLUX( DENS1, QV1, TA1, SOLDN, RAW, QSS, & + VEGFRC, ISNOW, ISTI, IFLAND, LAI, BETAP, & + WG, W2, WR, & + RSTMIN, WWLT, WFC, RSOIL, RINC, & + EG, ER, ETR, CQ4, RS, FASS) + !-------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! Compute Total evaporation (ET) from various modes of moisture flux + ET = EG + ER + ETR + QST = -ET / (DENS1 * UST) + + LV = 2.83E6 !-- LATENT HEAT OF SUBLIMATION AT 0C FROM STULL(1988) + IF (ISNOW .LT. 0.5 .AND. TG .GT. 273.15) & + LV = (2.501 - 0.00237 * (TG - 273.15)) * 1.E6 !-- FROM STULL(1988) in J/KG + + QFX = ET + LH = LV * QFX + !----------------------------------------------------------------------------------------- + + !----------------------------------------------------------------------------------------- + ! Surface sensible heat flux + TST = (THETA1 - THETAG ) / (UST*RAH) + HF = UST * TST + HFX = AMAX1(-DENS1 * CPAIR * HF, -250.0) ! using -250. from MM5 + !----------------------------------------------------------------------------------------- + + !----------------------------------------------------------------------------------------- + ! Compute the diagnosed 2m Q and T consistent with PX LSM + QST1 = 0.5*(QST+QST12/PHIH) + TA2 = (THETAG + TST * (PR0 / KARMAN * (ALOG(ZOBS / ZNT) - PSIOB)+5.))/CPOT + QA2 = QV1 - QST1 * PR0/ KARMAN * (ALOG(Z1 / ZOBS) - PSIH15) + + IF (QA2 .LE. 0.0) QA2 = QV1 + + !-- Relative humidity + VAPPRS = SVP1 * EXP(SVP2 * (TA2 - SVPT0) / (TA2 - SVP3)) + QSBT = EP_2 * VAPPRS / (PSURF - VAPPRS) + RH2MOD = QA2 / QSBT + !----------------------------------------------------------------------------------------- + IF (IFLAND .LT. 1.5) THEN + W2CG = AMAX1(W2,WWLT) + CG = CGSAT * 1.0E-6 * (WSAT/ W2CG) ** & + (0.5 * B / ALN10) + ! IMPERVIOUS weighting scheme -- Subtract highly accurate impervious fraction from cell + ! remainder is split between ground and vegetation. CT is a weighted fractional average. + ! Snow CT is then applied for final heat capacity + IMF = AMAX1(0.0,IMPERV/100.0) + VEGF = (1.0 - IMF) * VEGFRC + SOILF= (1.0 - IMF) * (1.0 - VEGFRC) + CT = 1./( IMF/CT_IMPERV + VEGF/CV + SOILF/CG) + CT = 1./(SNOW_FRA/CT_SNOW + (1-SNOW_FRA)/CT) + CAPG = 1.0/CT + + SOILFLX = 2.0 * PI * TAUINV * (TG - T2) + GRDFLX = SOILFLX / CT + ENDIF + !----------------------------------------------------------------------------------------- + + !-------------------------------------------------------------------- + !-- ASSIMILATION --- COMPUTE SOIL MOISTURE NUDGING FROM TA2 and RH2 + !-------COMPUTE ASSIMILATION COEFFICIENTS FOR ALL I + IF (IFLAND .LT. 1.5) THEN + IF (NUDGEX .EQ. 0) THEN !-- NO NUDGING CASE + WGNUDG = 0.0 + W2NUDG = 0.0 + T2NUD = 0.0 + ELSE !-- NUDGING CASE + + CALL SMASS (ISTI, FASS, SOLDN, VEGFRC, RA, WWLT, WFC, & + ALPH1, ALPH2, BET1, BET2, T2NUDF) + + !--COMPUTE SOIL MOISTURE NUDGING + WGNUDG = ALPH1 * (T2OBS - TA2) + ALPH2 * (RH2OBS - RH2MOD) * 100 !NUDGING W2 FOR NON-VEG + W2NUDG = BET1 * (T2OBS - TA2) + BET2 * (RH2OBS - RH2MOD) * 100 + IF (W2 .GE. WFC) W2NUDG = AMIN1(W2NUDG,0.0) + IF (W2 .LE. WWLT) W2NUDG = AMAX1(W2NUDG,0.0) + IF (W2 .GE. WFC) WGNUDG = AMIN1(WGNUDG,0.0) + IF (W2 .LE. WWLT) WGNUDG = AMAX1(WGNUDG,0.0) + T2NUD = T2NUDF * (T2OBS - TA2) + ENDIF + ENDIF + !----------------------------------------------------------------------------------------- + + !----------------------------------------------------------------------------------------- + !-- Compute new values for TS,T2,WG,W2 and WR. No change over ice or water (XLAND > 1) + IF (IFLAND .LT. 1.5) THEN + !-- SOLVE BY CRANK-NIC -- TENDTS=CT*(RADNET-HFX-QFX)-SOILFLX + !-- Calculate the coefficients for implicit calculation of TG + CQ1 = (1.0 - 0.622 * LV * CRANKP / (r_d * TG)) * QSS + CQ2 = 0.622 * LV * QSS * CRANKP / (r_d * TG * TG) + CQ3 = DENS1 * (1.0 - VEGFRC) / (RAW + RSOIL) + COEFFNP1 = 1.0 + DTPBL * CRANKP * (4.0 * EMISSI * STBOLT * TG ** 3 & + * CT + DENS1 * CPAIR / RAH * CPOT * CT + 2.0 * PI & + * TAUINV ) + DTPBL * (CT * LV * CQ2 * (CQ3 + CQ4)) + COEFFN = CT * (GSW + EMISSI * (STBOLT * (4.0 * CRANKP - 1.0) & + * TG*TG*TG*TG + LWDN) & !NET RAD + + DENS1 * CPAIR / RAH * (THETA1 - (1.0 - CRANKP) * THETAG) & + - LV * (CQ3 * (CQ1 - QV1) + CQ4 * (CQ1 - QV1))) & !SFC HEAT FLUX + - 2.0 * PI * TAUINV * ((1.0 - CRANKP) * TG - T2) !SOIL FLUX + TSNEW = (TG + DTPBL * COEFFN) / COEFFNP1 + !-- FOR SNOW COVERED SURFACE TEMPERATURE IS NOT MORE THAN ZERO + IF (XICE1 .GT. 0.5) TSNEW = AMIN1(TSNEW,273.15) ! Re-added Jan 2010 to keep ice surface at or below freezing (J. Pleim) + TSHLF = 0.5 * ( TSNEW + TG) + T2NEW = (T2 + DTPBL * TAUINV * T2TFAC * (TSHLF - (1 - CRANKP) * T2) & + + DTPBL*T2NUD) & ! Added deep temperature nudging + / (1.0 + DTPBL * TAUINV * T2TFAC * CRANKP) + !-- REPLACE OLD with NEW Value + TG = TSNEW + T2 = T2NEW + ENDIF + !----------------------------------------------------------------------------------------- + + !----------------------------------------------------------------------------------------- + ! Compute new subsurface soil and canopy moisture values DENS1. No change required over ocean. + IF (IFLAND .LT. 1.5 .AND. XICE1 .LT. 0.5) THEN + !-- Compute WR + ROFF = 0.0 + WRMAX = 0.2E-3 * VEGFRC * LAI ! max. WRMAX IN m + + IF (WRMAX .GT. 0.0) THEN + !-- PC is precip. intercepted by veg.(M/S) + PC = VEGFRC * SIGF * PRECIP + DWR = (WRMAX - WR) / DTPBL ! the tendency to reach max. + PNET = PC - ER/ DENW ! residual of precip. and evap. + IF (PNET .GT. DWR) THEN + ROFF = PNET - DWR + PC = PC - ROFF + ENDIF + IF (QSS .LT. QV1) THEN + TENDWR = PC - ER / DENW + WRNEW = WR + DTPBL * TENDWR + ELSE + COF1 = DENS1 / DENW * VEGFRC * (QSS - QV1) / RAW + !-- using delta=wr/wrmax + CFNP1WR = 1.0 + DTPBL * COF1 * CRANKP / WRMAX + CFNWR = PC - COF1 * (1.0 - CRANKP) * WR / WRMAX + WRNEW = (WR + DTPBL * CFNWR) / CFNP1WR + ENDIF + ELSE + PC = 0.0 + WRNEW = 0.0 + ENDIF + !--------------------------------------------- + !-- Compute W2 + PG = DENW * (PRECIP - PC) ! PG is precip. reaching soil (PC already including ROFF) + TENDW2 = 1.0 / (DENW * DS2) * (PG - EG - ETR) & + - C3/DS2 * TAUINV * AMAX1(0.0,(W2 - WFC)) & + + (W2NUDG + WGNUDG) / DS2 ! NUDGING + W2NEW = W2 + DTPBL * TENDW2 + W2NEW = AMIN1(W2NEW,WSAT) + W2NEW = AMAX1(W2NEW,WRES) !0.05) !Limei 08/02/2017 + W2HLF = 0.5 * (W2 + W2NEW) + !.. new values + W2 = W2NEW + WR = AMIN1(WRMAX,WRNEW) + ENDIF + !----------------------------------------------------------------------------------------- + + !----------------------------------------------------------------------------------------- + ! Compute new surface soil moisture values (WR). + IF (IFLAND .LT. 1.5 .AND. XICE1 .LT. 0.5) THEN ! over ocean no change to wg w2,wr + !-- FOR SNOW COVERED SURFACE, ASSUME SURFACE IS SATURATED AND + ! WG AND W2 ARE NOT CHANGED + IF (ISNOW .GT. 0.5) THEN + WG = WSAT + ELSE + W2REL = W2HLF / WSAT + IF (WG .GT. WWLT) THEN + C1 = DS1*C1SAT * (WSAT / WG) ** (0.5 * B + 1.0) + ELSE ! revise C1 for wg < wilting point Noilhan & Mahfouf (1996) + ZY2 = C1SAT * (WSAT / WWLT) ** (0.5 * B + 1.0) + C1MAX = (1.19*WWLT - 5.09)*TG - 146.*WWLT + 1786. + C1MAX = MAX(MAX(C1MAX,ZY2),10.) +!* Giard-Bazile formulation (resolution of a second order equation) +! + ZLY = LOG( C1MAX/10.) + ZZA = - LOG( ZY2 /10.) + ZZB = 2. * WWLT * ZLY + ZDEL= 4. * (ZLY+ZZA) * ZLY * WWLT**2 + ZA = (-ZZB+SQRT(ZDEL)) / (2.*ZZA) + ZB = ZA**2 / ZLY + C1 = DS1*C1MAX * EXP(-(WG-ZA)**2/ZB) + ENDIF + + C2 = C2R * W2HLF / (WSAT - W2HLF + 1.E-11) + IF (W2HLF .GE. WSAT) THEN + WEQ = WSAT + ELSE + WEQ = W2HLF - AS * WSAT * W2REL ** JP * & + (1.0 - W2REL ** (8.0 * JP)) + ENDIF + + !.... The diffusion method in Sakaguchi and Zeng [2009] (JGR-Atmos.) + CFNP1 = 1.0 + DTPBL * C2 * TAUINV * CRANKP + CFN = C1 / (DENW * DS1) * (PG - EG) - C2 * TAUINV * & + ((1.0 - CRANKP) * WG - WEQ) + WGNUDG/ DS1 + + WGNEW = AMAX1((WG + DTPBL * CFN) / CFNP1, WRES ) !0.001) ! Limei 08/02/2017 + !-- NEW VALUES + WG = AMIN1(WGNEW,WSAT) + + ENDIF !endif for ISNOW + ENDIF !endif for XLAND + + END SUBROUTINE surfpx +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + SUBROUTINE QFLUX (DENS1, QV1, TA1, RG, RAW, QSS, & ! in + VEGFRC, ISNOW, ISTI, IFLAND, LAI, BETAP, & ! in + WG, W2, WR, & ! in + RSTMIN, WWLT, WFC, RSOIL, RINC, & ! in + EG, ER, ETR, CQ4, RS, FASS) ! out + +!------------------------------------------------------------------------- +! +! FUNCTION: +! THIS SUBROUTINE COMPUTES EVAPORATION FROM BARE SOIL (EG) AND FROM +! THE WET PART OF CANOPY (ER) AND TRANSPIRATION FROM THE DRY PART OF +! CANOPY (ETR). +! +! REVISION HISTORY: +! A. Xiu Oct 2004 - adapted from the PX LSM in MM5 for the WRF system +! R. Gilliam Dec 2006 - Completed WRF V2.1.2 implementation +! +!------------------------------------------------------------------------- +! QFLUX ARGUMENT LIST: +!------------------------------------------------------------------------- +! INPUTS: +!-- DENS1 air density at first layer +!-- QV1 air humidity at first layer +!-- TA1 air temperature at first layer +!-- RG shortwave radition reaching the ground +!-- RAW RA+RB for moisture +!-- QSS saturation mixing ratio at ground +!-- VEGFRC vegetation coverage +!-- ISNOW if snow on the ground +!-- ISTI soil type +!-- IFLAND if land (=1) or water (=2) +!-- LAI leaf area index +!-- BETAP +!-- WG soil moisture at first soil layer +!-- W2 soil moisture at root zone +!-- WR Canopy water +! +! OUTPUTS FROM QFLUX: +!-- EG evaporation from ground (bare soil) +!-- ER evaporation from canopy +!-- ETR transpiration from vegetation +!-- CQ4 +!-- RS surface resistence +!-- FASS parameter for soil moisture nudging +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + + IMPLICIT NONE + +! DECLARATIONS - INTEGER + INTEGER , INTENT(IN) :: ISTI + +! DECLARATIONS - REAL + REAL , INTENT(IN) :: ISNOW, IFLAND + REAL , INTENT(IN) :: DENS1, QV1, TA1, RG, RAW, QSS, & + VEGFRC, LAI, & + WG, W2, WR, RSTMIN + REAL , INTENT(INOUT):: BETAP, RSOIL + REAL, INTENT(IN) :: WWLT, WFC, RINC + + REAL , INTENT(OUT) :: EG, ER, ETR, CQ4, RS, FASS + +!... Local Variables + +!... Real + REAL :: WRMAX, DELTA, SIGG, RADL, RADF, W2AVAIL, W2MXAV + REAL :: FTOT, F1, F2, F3, F4 + REAL :: FSHELT, GS, GA, FX + REAL :: PAR, F1MAX + + +!... Parameters + REAL, PARAMETER :: RSMAX = 5000.0 ! s/m + REAL, PARAMETER :: FTMIN = 0.0000001 ! m/s + REAL, PARAMETER :: F3MIN = 0.25 + +! +!... for water surface, no canopy evaporation and transpiration + ER = 0.0 + ETR = 0.0 + CQ4 = 0.0 + +!... GROUND EVAPORATION (DEPOSITION) + IF (QSS .LT. QV1) RSOIL = 0.0 + EG = DENS1 * (QSS - QV1) * ((1.0 - VEGFRC) / (RAW + RSOIL) + VEGFRC/(RAW + RINC + RSOIL)) + +!... CANOPY + IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0) THEN + WRMAX = 0.2E-3 * VEGFRC * LAI ! in unit m + IF (WR .LE. 0.0) THEN + DELTA = 0.0 + ELSE + DELTA = WR / WRMAX ! referred to SiB model + ENDIF + + IF (QSS .GE. QV1) THEN + SIGG = DELTA + ELSE + SIGG = 1.0 + ENDIF + + ER = DENS1 * VEGFRC * SIGG * (QSS - QV1) / RAW + ENDIF + !!--------------------------------------------------------------------- + + !-- TRANSPIRATION + !!--------------------------------------------------------------------- + IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0) THEN + + !!!-RADIATION + IF (RSTMIN .GT. 130.0) THEN + F1MAX = 1.-0.02*LAI !Echer2015 Trees + ELSE + F1MAX = 1.-0.07*LAI !Echer2015 crops/grass + ENDIF + PAR = 0.45 * RG * 4.566 ! converted from W/m2 to umoles/m2/s (1/.219) Echer2015 + F1 = F1MAX*(1.0-exp(-0.0017*PAR)) !Echer2015 + F1 = AMAX1(F1,RSTMIN / RSMAX) + + !!!-SOIL MOISTURE + W2AVAIL = W2 - WWLT + W2MXAV = WFC - WWLT + F2 = 1.0 / (1.0 + EXP(-5.0 * ( W2AVAIL / W2MXAV - & + (W2MXAV / 3.0 + WWLT)))) ! according JP, 9/94 + + !-AIR TEMP + !... according to Avissar (1985) and AX 7/95 + IF (TA1 .LE. 302.15) THEN + F4 = 1.0 / (1.0 + EXP(-0.41 * (TA1 - 282.05))) + ELSE + F4 = 1.0 / (1.0 + EXP(0.5 * (TA1 - 314.0))) + ENDIF + + FTOT = LAI * F1 * F2 * F4 + ENDIF + + !!--------------------------------------------------------------------- + IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0) THEN + FSHELT = 1.0 ! go back to NP89 + GS = FTOT / (RSTMIN * FSHELT) + GA = 1.0 / RAW + !-- Compute humidity effect according to RH at leaf surf + F3 = 0.5 * (GS - GA + SQRT(GA * GA + GA * GS * & + (4.0 * QV1 / QSS - 2.0) + GS * GS)) / GS + F3 = AMIN1(AMAX1(F3,F3MIN),1.0) + RS = 1.0 / (GS * F3) + + !--- Compute Assimilation factor for soil moisture nudging - jp 12/94 + !-- Note that the 30 coef is to result in order 1 factor for max + IF (RG .LT. 0.00001) THEN ! do not nudge during night + FX = 0.0 + ELSE + FX = 30.0 * F1 * F4 * LAI / (RSTMIN * FSHELT) + ENDIF + + FASS = FX + ETR = DENS1 * VEGFRC * (1.0 - SIGG) * (QSS - QV1) / (RAW + RS) + !..... CQ4 is used for the implicit calculation of TG in SURFACE + CQ4 = DENS1 * VEGFRC * ((1.0 - SIGG) / (RAW + RS) + SIGG / RAW) + ENDIF + + END SUBROUTINE qflux +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + SUBROUTINE SMASS (ISTI, FASS, RG, VEGFRC, RA, & !in + WWLT, WFC, & !in + ALPH1, ALPH2, BET1, BET2, T2NUDF ) !out +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------------------------------ +! SMASS COMPUTES SOIL MOISTURE NUDGING COEFFICIENTS +!------------------------------------------------------------------------------------------ +! +!.........Arguments + INTEGER, PARAMETER :: NSCAT = 16 ! max. soil types + + INTEGER, INTENT(IN) :: ISTI + REAL, INTENT(IN) :: FASS, RG, VEGFRC, RA + REAL, INTENT(IN) :: WWLT, WFC + REAL, INTENT(OUT) :: ALPH1, ALPH2, BET1, BET2, T2NUDF + + +!........Local variables + +!... Real + REAL :: FBET, FALPH, FRA, FTEXT + +!... Parameters + REAL, PARAMETER :: A1MAX = -10.E-5, A2MAX = 1.E-5 ! m/K, m for 6hr period + REAL, PARAMETER :: B1MAX = -10.E-3, B2MAX = 1.E-3 ! m/K, m (Bouttier et al 1993) + REAL, PARAMETER :: TASSI = 4.6296E-5 ! 1/6hr in 1/sec + REAL, PARAMETER :: RAMIN = 10.0 ! 0.1 s/cm + REAL, PARAMETER :: WFCX = 0.243 ! middle of WFC range + REAL, PARAMETER :: WWLTX = 0.169 ! middle of WWLT range + + + FBET = FASS + FALPH = RG / 1370.0 +!--TEXTURE FACTOR NORMALIZED BY LOAM (IST=5) + FRA = RAMIN / RA ! scale by aerodynamic resistance + FTEXT = TASSI * (WWLT + WFC) / (WWLTX + WFCX) * FRA + + ALPH1 = A1MAX * FALPH * (1.0 - VEGFRC) * FTEXT + ALPH2 = A2MAX * FALPH * (1.0 - VEGFRC) * FTEXT + BET1 = B1MAX * FBET * VEGFRC * FTEXT + BET2 = B2MAX * FBET * VEGFRC * FTEXT + T2NUDF= 1.0E-5 * ( VEGFRC*MAX((1.0 - 5.0 * FALPH),0.0) + (1-VEGFRC) ) ! T2 Nudging at night and day for non-veg frac - jp 10/30/14 + + END SUBROUTINE smass +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ +#if defined(mpas) + SUBROUTINE SOILPROP (RESTART,SOILCBOT,ITIMESTEP, MAVAIL, & ! IN +#else + SUBROUTINE SOILPROP (SOILCBOT,ITIMESTEP, MAVAIL, & ! IN +#endif + PXLSM_SMOIS_INIT, & ! IN + FWSAT,FWFC,FWWLT,FCLAY,FCSAND, & ! OUT + FFMSAND,FB,FCGSAT, & ! OUT + FJP,FAS,FC2R,FC1SAT,FWRES,FC3,ISTI, & ! OUT + WG, W2 ) ! OUT + !------------------------------------------------------------------------ + ! SOILPROP COMPUTES SOIL PARAMETERS FOR BOTH BOTTOM AND TOP LAYERS + ! USING FRACTIONAL SOIL TYPE. AN OPTION IS AVAILABLE TO + ! COMPUTE THE SOIL PARAMETERS USING FRACTIONAL INFORMATION, + ! OR TO JUST USE SOIL PARAMETERS OF THE DOMINANT SOIL TYPE + !------------------------------------------------------------------------ + !-- SOIL PARAMETERS ARE SPECIFIED BY SOIL TYPE: + ! # SOIL TYPE WSAT WFC WWLT B CGSAT JP AS C2R C1SAT WRES + ! _ _________ ____ ___ ____ ____ _____ ___ ___ ___ _____ ____ + ! 1 SAND .395 .135 .068 4.05 3.222 4 .387 3.9 .082 0.020 + ! 2 LOAMY SAND .410 .150 .075 4.38 3.057 4 .404 3.7 .098 0.035 + ! 3 SANDY LOAM .435 .195 .114 4.90 3.560 4 .219 1.8 .132 0.041 + ! 4 SILT LOAM .485 .255 .179 5.30 4.418 6 .105 0.8 .153 0.015 + ! 5 SILT .485 .255 .179 5.30 4.418 6 .105 0.8 .153 0.015 + ! 6 LOAM .451 .240 .155 5.39 4.111 6 .148 0.8 .191 0.027 + ! 7 SND CLY LM .420 .255 .175 7.12 3.670 6 .135 0.8 .213 0.068 + ! 8 SLT CLY LM .477 .322 .218 7.75 3.593 8 .127 0.4 .385 0.040 + ! 9 CLAY LOAM .476 .325 .250 8.52 3.995 10 .084 0.6 .227 0.075 + ! 10 SANDY CLAY .426 .310 .219 10.40 3.058 8 .139 0.3 .421 0.109 + ! 11 SILTY CLAY .482 .370 .283 10.40 3.729 10 .075 0.3 .375 0.056 + ! 12 CLAY .482 .367 .286 11.40 3.600 12 .083 0.3 .342 0.090 + !------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + IMPLICIT NONE + + !.........Arguments + INTEGER, PARAMETER :: NSCAT = 16 ! max. soil types + INTEGER, PARAMETER :: NSCATMIN = 16 ! min. soil types + +#if defined(mpas) + LOGICAL, INTENT(IN) :: RESTART +#endif + INTEGER, INTENT(IN) :: ITIMESTEP, PXLSM_SMOIS_INIT + REAL, INTENT(IN) :: MAVAIL + REAL, DIMENSION(1:NSCAT), INTENT(IN) :: SOILCBOT + REAL, INTENT(OUT) :: FWSAT,FWFC,FWWLT,FCLAY, & + FCSAND,FFMSAND,FB,FCGSAT, & + FJP,FAS,FC2R,FC1SAT,FWRES,FC3 + REAL, INTENT(INOUT):: W2, WG + INTEGER, INTENT(OUT) :: ISTI + +!........Local variables + CHARACTER*4, AVCLASS + CHARACTER*4, DIMENSION( 1: NSCAT ) :: TEXID +!... Integer + INTEGER:: S +!... Real + REAL:: TFRACBOT, CFRAC, SUMCSND, SUMFMSND, SUMCLY, & + AVS, AVCS, AVFMS, AVC, AVSLT, & + SSMPOT, DSMPOT ! saturated and air-dry soil matric potential + + REAL, DIMENSION( 1: NSCATMIN ) :: CSAND, FMSAND, CLAY +!.......... DATA statement for SOIL PARAMETERS for the 11 soil types +!...........Follow Menut et al., 2013 JGR + DATA CSAND /46.0,40.0,29.0, 0.0, 0.0, & + 0.0,29.0, 0.0, 0.0, 0.0, & + 0.0, 0.0, 0.0, 0.0,46.0, & + 0.0/ + DATA FMSAND /46.0,40.0,29.0,17.0,10.0, & + 43.0,29.0,10.0,32.0,52.0, & + 6.0,22.0,43.0,43.0,46.0, & + 32.0/ + + DATA CLAY / 3.0, 4.0,10.0,13.0, 5.0, & + 18.0,27.0,34.0,34.0,42.0, & + 47.0,58.0,18.0,18.0, 3.0, & + 34.0/ + + DATA TEXID/'Sand','Lsan','Sloa','Sill','Silt', & + 'Loam','Sclo','Sicl','Cllo','Sacl', & + 'Sicy','Clay','Ormt','Wate','Bedr', & + 'Othe'/ +!-- Removed soil parameter lookup table data since these parameters are now computed analytically (Noilhan and Mahfouf 1996) + + DSMPOT = -1.0E7 ! mm air-dry water matric potential +! +!-------------------------------Executable starts here-------------------- + +! Compute soil characteristics by sand (coarse and fine-medium) and clay fraction + + CFRAC = 0.0 + SUMCSND = 0.0 + SUMFMSND = 0.0 + SUMCLY = 0.0 + TFRACBOT = 0.0 + + DO S = 1,NSCAT + + TFRACBOT = TFRACBOT + SOILCBOT(S) + SUMCSND = SUMCSND + CSAND(S) * SOILCBOT(S) + SUMFMSND = SUMFMSND + FMSAND(S) * SOILCBOT(S) + SUMCLY = SUMCLY + CLAY(S) * SOILCBOT(S) + + IF (SOILCBOT(S) .GE. CFRAC) THEN ! Find Dominant Category and fraction + ISTI = S + CFRAC = SOILCBOT(S) + ENDIF + + ENDDO + + + IF (TFRACBOT .GT. 0.001) THEN + AVCS = SUMCSND / TFRACBOT + AVFMS = SUMFMSND / TFRACBOT + AVS = AVCS + AVFMS + + AVC = SUMCLY / TFRACBOT + AVSLT = 100.0 - AVS - AVC + + IF (AVS .GT. (85.+ 0.5*AVC)) THEN + AVCLASS = 'Sand' + ISTI = 1 + ELSE IF (AVS .GT. (70.+ AVC)) THEN + AVCLASS = 'Lsan' + ISTI = 2 + ELSE IF ((AVC .LT. 20. .AND. AVS .GT. 52.) & + .OR. (AVC .LE. 7.5 .AND. AVSLT .LT. 50.)) THEN + AVCLASS = 'Sloa' + ISTI = 3 + ELSE IF (AVC .LT. 35. .AND. AVS .GT. 45. .AND. AVSLT .LT. 28.) THEN + AVCLASS = 'Sclo' + ISTI = 7 + ELSE IF (AVC .GE. 35. .AND. AVS .GT. 45.) THEN + AVCLASS = 'Sacl' + ISTI = 10 + ELSE IF (AVC .LT. 27.0 .AND. AVSLT .LT. 50.) THEN + AVCLASS = 'Loam' + ISTI = 6 + ELSE IF (AVC .LT. 12. .AND. AVSLT .GT. 80.) THEN + AVCLASS = 'Silt' + ISTI = 5 + ELSE IF (AVC .LT. 27.) THEN + AVCLASS = 'Sill' + ISTI = 4 + ELSE IF (AVC .LT. 40. .AND. AVS .GT. 20.) THEN + AVCLASS = 'Cllo' + ISTI = 9 + ELSE IF (AVC .LT. 40.) THEN + AVCLASS = 'Sicl' + ISTI = 8 + ELSE IF (AVSLT .GE. 40.) THEN + AVCLASS = 'Sicy' + ISTI = 11 + ELSE + AVCLASS = 'Clay' + ISTI = 12 + ENDIF + ELSE + ! set no soil to 9 - clay loam + ISTI = 9 + AVCLASS = TEXID(ISTI) + + AVCS = CSAND(ISTI) + AVFMS = FMSAND(ISTI) + AVS = AVCS + AVFMS + + AVC = CLAY(ISTI) + AVSLT = 100.0 - AVS - AVC + + ENDIF + + FCSAND = AVCS + FFMSAND = AVFMS + FCLAY = AVC + + ! Continuous formulation of secondary soil parameters (Noilhan and Mahfouf 1996) + FWSAT = (-1.08 * AVS + 494.305) * 1.0E-3 + FWWLT = 37.1342E-3 * SQRT(AVC) + FWFC = 89.0467E-3 * AVC**0.3496 + FB = 0.137 * AVC + 3.501 + FCGSAT= -1.557E-2 * AVS - 1.441E-2 * AVC + 4.7021 + FC1SAT= (5.58 * AVC + 84.88) * 1.0E-2 + FC2R = 13.815 * AVC**(-0.954) + FC3 = 5.327 * AVC **(-1.043) + FAS = 732.42E-3 * AVC **(-0.539) + FJP = 0.134 * AVC + 3.4 + FWRES = 0.00123 * AVC - 0.00066 * AVSLT + 0.0405 !J. Pleim fitted function + FWRES = AMAX1(FWRES, 0.01) !L. Ran set minimum + + ! Compute W2 using soil moisture availability if pxlsm_smois_init (in namelist) is not zero +#if defined(mpas) + IF ( (ITIMESTEP .EQ. 1) .AND. (PXLSM_SMOIS_INIT .EQ. 1) .AND. (.NOT. RESTART) ) THEN +#else + IF (ITIMESTEP .EQ. 1 .AND. PXLSM_SMOIS_INIT .GT. 0) THEN +#endif + WG = FWWLT + (0.5*(FWSAT+FWFC) - FWWLT) * MAVAIL + W2 = FWWLT + (0.5*(FWSAT+FWFC) - FWWLT) * MAVAIL + ENDIF + + END SUBROUTINE soilprop +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + SUBROUTINE PXSNOW (ITIMESTEP, ASNOW, CSNOW, SNOW, & + SNOWH, SNUP, & + ALB, SNOALB, & + HC_SNOW, SNOW_FRA, SNOWC, SNOWALB) +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ +! Pleim-Xiu LSM Simple Snow model +!--------------------------------------------------------------------------------------------------- +! ITIMESTEP -- Model time step index +! ASNOW -- Analyzed snow water equivalent (mm) +! CSNOW -- Current snow water equivalent (mm) +! SNOW -- Snow water equivalent in model (mm) +! SNOWH -- Physical snow depth (m) +! SNUP -- Physical snow depth (landuse dependent) where when below, snow cover is fractional +! +! HC_SNOW -- Heat capacity of snow as a function of depth +! SNOW_FRA -- Factional snow area +! IFSNOW -- Snow flag +! SNOWALB -- Snow albedo +!--------------------------------------------------------------------------------------------------- + + IMPLICIT NONE + +!--- Arguments + REAL, PARAMETER :: W2SN_CONV = 10.0 + REAL, PARAMETER :: CS_SNOWPACK = 2092.0 + REAL, PARAMETER :: SALP = 2.6 +!----------------------------------------------- + INTEGER, INTENT(IN) :: ITIMESTEP + REAL, INTENT(IN) :: ASNOW, CSNOW, SNUP, ALB, SNOALB + REAL, INTENT(INOUT) :: SNOW, SNOWH, SNOWC + REAL, INTENT(OUT) :: HC_SNOW, SNOW_FRA, SNOWALB +!------------------------------------------------------------------------------------ + + +!----------------------------------------------- +! Local variables + !... Real + REAL:: CONV_WAT2SNOW, CSNOWW, RHO_SNOWPACK, & + LIQSN_RATIO, SNEQV, RSNOW +#if defined(mpas) + REAL:: DENW +#endif +!----------------------------------------------- +#if defined(mpas) + DENW = rho_w +#endif + + SNEQV = ASNOW*0.001 ! Snow water in meters + RHO_SNOWPACK = 450 ! Snowpack density (kg/m3), this should be computed in the future + LIQSN_RATIO = DENW/RHO_SNOWPACK ! Ratio of water density and snowpack density + + CONV_WAT2SNOW = LIQSN_RATIO/1000 ! Conversion factor for snow liquid equiv. (mm) to snowpack (m) + + SNOW = ASNOW ! Set snow water to analysis value for now, implement a nudging scheme later + SNOWH = SNOW * CONV_WAT2SNOW ! Conversion of snow water (mm) to snow depth (m) + + + ! Is snow cover now present. The limit is 0.45 mm of water eqivalent or about 2 inches snow depth + SNOWC = 0.0 + IF (SNOWH .GT. 0.005) SNOWC = 1.0 + + HC_SNOW = RHO_SNOWPACK * CS_SNOWPACK * SNOWH + + IF (SNEQV .LT. SNUP) THEN + RSNOW = SNEQV / SNUP + SNOW_FRA = 1. - ( EXP ( - SALP * RSNOW) - RSNOW * EXP ( - SALP)) + ELSE + SNOW_FRA = 1.0 + END IF + + SNOWC = SNOW_FRA + + SNOWALB = ALB + SNOWC*(SNOALB-ALB) + + END SUBROUTINE pxsnow +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +END MODULE module_sf_pxlsm + diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm_data.F b/src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm_data.F new file mode 100644 index 0000000000..e9def75186 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_pxlsm_data.F @@ -0,0 +1,639 @@ +!WRF:MODEL_LAYER:PHYSICS +! +! RG 10/2014 - Added LU-based SNOALB that is used for LU fraction weighted value if specificed. +! +! + +MODULE module_sf_pxlsm_data + +!***************************************************************************** +! MODIS-ONLY (1XX)/MODIS (2XX) LU characterization ... +!------------------------------------------------------------------------------- +!Index Rstmin Zo Mxfr MnFr MxLA MnLA SNUP ALB SNOALB +! 1 175. 100. 93. 93. 5.5 3.5 0.08 12. 30. Evergreen Needleleaf Forest +! 2 120. 90. 92. 92. 6.0 3.5 0.08 12. 30. Evergreen Broadleaf Forest +! 3 175. 100. 60. 60. 3.0 1.5 0.08 14. 30. Deciduous Needleleaf Forest +! 4 200. 100. 91. 91. 6.0 1.5 0.08 16. 40. Deciduous Broadleaf Forest' +! 5 200. 100. 92. 92. 5.5 2.2 0.08 13. 35. Mixed Forest +! 6 200. 15. 40. 20. 1.5 1.0 0.03 22. 50. Closed Shrublands +! 7 200. 15. 40. 17. 1.5 1.3 0.035 20. 60. Open Shrublands +! 8 150. 25. 70. 60. 2.3 2.0 0.03 22. 50. Woody Savanna +! 9 120. 15. 70. 40. 1.5 0.5 0.04 20. 50. Savanna +!------------------------------------------------------------------------------- +! 10 100. 7. 50. 20. 1.5 0.5 0.04 19. 70. Grasslands +! 11 200 20. 65. 35. 2.5 1.0 0.08 15. 50. Perminent Wetlands +! 12 70. 10. 90. 20. 3.5 0.7 0.04 18. 66. Croplands +! 13 150. 80. 5. 5. 2.0 0.5 0.04 11. 46. Urban andBuilt-up' +! 14 100. 30. 80. 40. 3.5 1.0 0.04 18. 68. Cropland/Natural Vegetation Mosaic +! 15 9999. 1.2 0.1 0.1 0.1 0.1 0.02 60. 82. Snow and Ice +! 16 100. 5. 0.5 0.5 0.2 0.1 0.02 25. 75. Barren or Sparsely Vegetated +! 17 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 08. IGBP water +! 18 175. 30. 70. 50. 3.4 2.0 0.80 15. 45. wooded tundra +! 19 120. 15. 40. 20. 2.4 1.0 0.40 15. 50. mixed tundra +! 20 100. 10. 20. 5. 1.4 0.1 .015 25. 75. barren tundra +!------------------------------------------------------------------------------------ +!**************************************************************************************** +!**************************************************************************************** + REAL, DIMENSION(21), TARGET :: RSMIN_MODIS, Z00_MODIS, & + VEG0_MODIS, VEGMN0_MODIS, & + LAI0_MODIS, LAIMN0_MODIS, & + SNUP0_MODIS, ALBF_MODIS, & + SNOALB_MODIS + + DATA RSMIN_MODIS & + / 175.0, 120.0, 175.0, 200.0, 200.0, & + 200.0, 200.0, 150.0, 120.0, 100.0, & + 200.0, 70.0, 150.0, 100.0, 9999.0, & + 100.0, 9999.0, 175.0, 120.0, 100.0, 9999.0 / + + DATA Z00_MODIS & + / 100.0, 90.0, 100.0, 100.0, 100.0, & + 15.0, 15.0, 25.0, 15.0, 7.0, & + 20.0, 10.0, 80.0, 30.0, 1.2, & + 5.0, 0.1, 30.0, 15.0, 10.0, 0.1 / + + DATA VEG0_MODIS & + / 93.0, 92.0, 60.0, 91.0, 92.0, & + 40.0, 20.0, 70.0, 70.0, 50.0, & + 65.0, 90.0, 5.0, 80.0, 0.1, & + 0.5, 0.0, 70.0, 40.0, 20.0, 0.0 / + + DATA VEGMN0_MODIS & + / 93.0, 92.0, 60.0, 91.0, 92.0, & + 20.0, 10.0, 60.0, 40.0, 20.0, & + 35.0, 20.0, 5.0, 40.0, 0.1, & + 0.5, 0.0, 50.0, 20.0, 5.0, 0.0 / + + DATA LAI0_MODIS & + / 5.5, 6.0, 3.0, 6.0, 5.5, & + 1.5, 1.5, 2.3, 1.5, 1.5, & + 2.5, 3.5, 2.0, 3.5, 0.1, & + 0.2, 0.0, 3.4, 2.4, 1.4, 0.0 / + + DATA LAIMN0_MODIS & + / 3.5, 3.5, 1.5, 2.0, 2.5, & + 1.0, 1.3, 2.0, 1.5, 1.5, & + 2.0, 1.5, 1.5, 1.5, 0.1, & + 0.1, 0.0, 2.0, 1.0, 0.1, 0.0 / + + DATA SNUP0_MODIS & + / 0.08, 0.08, 0.08, 0.08, 0.08, & + 0.03, 0.035, 0.03, 0.04, 0.04, & + 0.08, 0.04, 0.04, 0.04, 0.02, & + 0.02, 0.01, 0.80, 0.40, 0.015, 0.01 / + + DATA ALBF_MODIS & + / 12.0, 12.0, 14.0, 16.0, 13.0, & + 22.0, 20.0, 22.0, 20.0, 19.0, & + 17.0, 18.0, 11.0, 18.0, 60.0, & + 25.0, 8.0, 15.0, 15.0, 25.0, 8.0 / + + DATA SNOALB_MODIS & + / 30.0, 30.0, 30.0, 40.0, 35.0, & + 50.0, 60.0, 50.0, 50.0, 70.0, & + 50.0, 66.0, 46.0, 68.0, 82.0, & + 75.0, 8.0, 45.0, 55.0, 75.0, 8.0 / + +!**************************************************************************************** +!**************************************************************************************** +! 50 CLASS NLCD (US only, cats 1-30)/MODIS (Outside US, cats 31-50) LU characterization +!--------------------------------------------------------------------------------------- +!Index Rstmin Zo Mxfr MnFr MxLA MnLA ALB SNOALB Cat Desc. +! 1 9999. 0.1 00. 00. 0.0 0.0 8 70. Open water +! 2 9999. 1.2 5. 02. 0.1 0.1 60 82. Perennial Ice/snow +! 3 120. 30. 90. 80. 3.0 1.0 12 60. Developed, Open space +! 4 120. 40. 70 60. 3.0 1.0 11 46. Developed, Low Intensity +! 5 140. 60. 40. 30. 3.0 1.0 10 43. Developed, Medium Intensity +! 6 160. 100. 15. 5. 3.0 1.0 10 40. Developed, High Intensity +! 7 100. 5. 20. 5. 1.0 0.5 20 75. Barren land +! 8 100. 5. 15. 5. 0.5 0.2 35 75. Unconsolidated Shore +! 9 200. 100. 95. 50. 5.0 1.0 15 40. Deciduous Forest +! 10 175. 100. 90. 80. 4.0 3.0 10 30. Evergreen Forest +!------------------------------------------------------------------------------- +! 11 200. 100. 95. 60. 5.0 2.0 13 35. Mixed Forest +! 12 200. 10. 50. 20. 2.0 1.0 20 65. Dwarf Scrub +! 13 200. 15. 75. 50. 2.5 1.0 20 60. Shrub/Scrub +! 14 100. 7. 85. 60. 2.5 1.0 19 70. Grassland/Herbaceous +! 15 100. 7. 80. 20. 2.0 1.0 23 60. Sedge/Herbaceous +! 16 100. 5. 80. 20. 1.0 1.0 20 60. Lichens +! 17 100. 5. 80. 20. 1.0 1.0 20 60. Moss +! 18 100. 5. 50. 20. 1.0 1.0 15 75. Tundra +! 19 80. 7. 95. 80. 3.0 1.0 18 68. Pasture/Hay' +! 20 70. 10. 95. 10. 3.0 0.5 18 66. Cultivated Crops +!------------------------------------------------------------------------------- +! 21 200. 55. 90. 80. 5.0 2.0 15 40. Woody Wetland +! 22 200. 80. 90. 80. 5.0 2.0 15 40. Palustrine Forested Wetland +! 23 164. 30. 90. 80. 3.0 1.0 15 50. Palustrine Scrub/Shrub Wetland +! 24 200. 60. 90. 80. 5.0 2.0 15 50. Estuarine Forested Wetland +! 25 164. 30. 90. 80. 3.0 1.0 15 50. Estuarine Scrub/Shrub Wetland +! 26 120. 11. 85. 40. 2.0 1.0 18 59. Emergent Herbaceous Wetland +! 27 120. 11. 85. 40. 2.0 1.0 18 59. Palustrine Emergent Wetland +! 28 120. 11. 85. 40. 2.0 1.0 18 59. Estuarine Emergent Wetland +! 29 100. 5. 60. 20. 1.0 0.5 10 50. Palustrine Aquatic Bed +! 30 100. 5. 60. 20. 1.0 0.5 10 50. Estuarine Aquatic Bed +!------------------------------------------------------------------------------- +! 31 9999. 0.1 00. 00. 0.0 0.0 8 8. Open water (mapped to 1) +! 32 175. 100. 90. 80. 4.0 3.0 12 30. Evergreen Needleleaf Forest +! 33 120. 90. 95. 85. 5.0 4.0 12 30. Evergreen Broadleaf Forest +! 34 175. 100. 95. 50. 5.0 1.0 14 40. Deciduous Needleleaf Forest +! 35 200. 100. 95. 50. 5.0 1.0 16 40. Deciduous Broadleaf Forest' +! 36 200. 100. 95. 60. 5.0 2.0 13 35. Mixed Forest +! 37 200. 15. 90. 50. 3.0 1.0 22 50. Closed Shrublands +! 38 200. 15. 75. 50. 2.5 1.0 20 60. Open Shrublands +! 39 150. 25. 80. 60. 2.5 1.0 22 50. Woody Savanna +! 40 120. 15. 70. 50 2.0 1.0 20 50. Savanna +!------------------------------------------------------------------------------- +! 41 100. 7. 85. 60. 2.5 1.0 19 70. Grasslands +! 42 160. 20. 75. 45. 3.0 1.0 14 59. Perminent Wetlands +! 43 70. 10. 95. 10. 3.0 0.5 18 66. Croplands +! 44 150. 80. 40. 20. 3.0 1.0 11 46. Urban andBuilt-up' +! 45 100. 30. 95. 40. 3.0 1.0 18 68. Cropland/Natural Vegetation Mosaic +! 46 9999. 1.2 5. 02. 0.1 0.1 60 82. Snow and Ice +! 47 100. 5. 20. 5. 1.0 0.5 25 75. Barren or Sparsely Vegetated +! 48 9999. 0.1 00. 00. 0.0 0.0 8 08. IGBP water +! 49 9999. 0.1 00. 00. 0.0 0.0 8 60. unclassified +! 50 9999. 0.1 00. 00. 0.0 0.0 8 75. fill value (normally ocean water) +!------------------------------------------------------------------------------------ + + REAL, DIMENSION(50), TARGET :: RSMIN_NLCD50, Z00_NLCD50, & + VEG0_NLCD50, VEGMN0_NLCD50, & + LAI0_NLCD50, LAIMN0_NLCD50, & + SNUP0_NLCD50, ALBF_NLCD50, & + SNOALB_NLCD50 + + DATA RSMIN_NLCD50 & + / 9999.0, 9999.0, 120.0, 120.0, 140.0, & + 160.0, 100.0, 100.0, 200.0, 175.0, & + 200.0, 200.0, 200.0, 100.0, 100.0, & + 100.0, 100.0, 100.0, 80.0, 70.0, & + 200.0, 200.0, 164.0, 200.0, 164.0, & + 120.0, 120.0, 120.0, 100.0, 100.0, & + 9999.0, 175.0, 120.0, 175.0, 200.0, & + 200.0, 200.0, 200.0, 150.0, 120.0, & + 100.0, 160.0, 70.0, 150.0, 100.0, & + 9999.0, 100.0, 9999.0, 9999.0, 9999.0 / + + DATA Z00_NLCD50 & + / 0.10, 1.20, 30.0, 40.0, 60.0, & + 100.0, 5.0, 5.0, 100.0, 100.0, & + 100.0, 10.0, 15.0, 7.0, 7.0, & + 5.0, 5.0, 5.0, 7.0, 10.0, & + 55.0, 80.0, 30.0, 60.0, 30.0, & + 11.0, 11.0, 11.0, 5.0, 5.0, & + 0.1, 100.0, 90.0, 100.0, 100.0, & + 100.0, 15.0, 15.0, 25.0, 15.0, & + 7.0, 20.0, 10.0, 80.0, 30.0, & + 1.2, 5.0, 0.1, 0.1, 0.1 / + + DATA VEG0_NLCD50 & + / 00.0, 5.0, 90.0, 70.0, 40.0, & + 15.0, 20.0, 15.0, 95.0, 90.0, & + 95.0, 50.0, 75.0, 85.0, 80.0, & + 80.0, 80.0, 50.0, 95.0, 95.0, & + 90.0, 90.0, 90.0, 90.0, 90.0, & + 85.0, 85.0, 85.0, 60.0, 60.0, & + 0.0, 90.0, 95.0, 95.0, 95.0, & + 95.0, 90.0, 75.0, 80.0, 70.0, & + 85.0, 75.0, 95.0, 40.0, 95.0, & + 5.0, 20.0, 0.0, 0.0, 0.0 / + + DATA VEGMN0_NLCD50 & + / 00.0, 2.0, 80.0, 60.0, 30.0, & + 05.0, 05.0, 5.0, 50.0, 80.0, & + 60.0, 20.0, 50.0, 60.0, 20.0, & + 20.0, 20.0, 20.0, 80.0, 10.0, & + 80.0, 80.0, 80.0, 80.0, 80.0, & + 40.0, 40.0, 40.0, 20.0, 20.0, & + 0.0, 80.0, 85.0, 50.0, 50.0, & + 60.0, 50.0, 50.0, 60.0, 50.0, & + 60.0, 45.0, 10.0, 20.0, 40.0, & + 2.0, 5.0, 0.0, 0.0, 0.0 / + + DATA LAI0_NLCD50 & + / 0.0, 0.1, 3.0, 3.0, 3.0, & + 3.0, 1.0, 0.5, 5.0, 4.0, & + 5.0, 2.0, 2.5, 2.5, 2.0, & + 1.0, 1.0, 1.0, 3.0, 3.0, & + 5.0, 5.0, 3.0, 5.0, 3.0, & + 2.0, 2.0, 2.0, 1.0, 1.0, & + 0.0, 4.0, 5.0, 5.0, 5.0, & + 5.0, 3.0, 2.5, 2.5, 2.0, & + 2.5, 3.0, 3.0, 3.0, 3.0, & + 0.1, 1.0, 0.0, 0.0, 0.0 / + + DATA LAIMN0_NLCD50 & + / 0.0, 0.1, 1.0, 1.0, 1.0, & + 1.0, 0.5, 0.2, 1.0, 3.0, & + 2.0, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 1.0, 1.0, 0.5, & + 2.0, 2.0, 1.0, 2.0, 1.0, & + 1.0, 1.0, 1.0, 0.5, 0.5, & + 0.0, 3.0, 4.0, 1.0, 1.0, & + 2.0, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 0.5, 1.0, 1.0, & + 0.1, 0.5, 0.0, 0.0, 0.0 / + + DATA SNUP0_NLCD50 & + / 0.01, 0.02, 0.04, 0.04, 0.04, & + 0.04, 0.02, 0.02, 0.08, 0.08, & + 0.08, 0.04, 0.04, 0.04, 0.01, & + 0.01, 0.01, 0.02, 0.04, 0.04, & + 0.08, 0.08, 0.04, 0.08, 0.04, & + 0.04, 0.06, 0.06, 0.02, 0.02, & + 0.08, 0.08, 0.08, 0.08, 0.08, & + 0.08, 0.03, 0.035, 0.03, 0.04, & + 0.04, 0.015, 0.04, 0.04, 0.04, & + 0.02, 0.02, 0.01, 0.01, 0.01 / + + DATA ALBF_NLCD50 & + / 8.0, 60.0, 12.0, 11.0, 10.0, & + 10.0, 20.0, 35.0, 15.0, 10.0, & + 13.0, 20.0, 20.0, 19.0, 23.0, & + 20.0, 20.0, 15.0, 18.0, 18.0, & + 15.0, 15.0, 15.0, 15.0, 15.0, & + 18.0, 18.0, 18.0, 10.0, 10.0, & + 8.0, 12.0, 12.0, 14.0, 16.0, & + 13.0, 22.0, 20.0, 22.0, 20.0, & + 19.0, 14.0, 18.0, 11.0, 18.0, & + 60.0, 25.0, 8.0, 8.0, 8.0 / + + DATA SNOALB_NLCD50 & + / 70.0, 82.0, 60.0, 46.0, 43.0, & + 40.0, 75.0, 75.0, 40.0, 30.0, & + 35.0, 65.0, 60.0, 70.0, 60.0, & + 60.0, 60.0, 75.0, 68.0, 66.0, & + 40.0, 40.0, 50.0, 50.0, 50.0, & + 59.0, 59.0, 59.0, 50.0, 50.0, & + 8.0, 30.0, 30.0, 40.0, 40.0, & + 35.0, 50.0, 60.0, 50.0, 50.0, & + 70.0, 59.0, 66.0, 46.0, 68.0, & + 82.0, 75.0, 8.0, 60.0, 75.0 / + +!**************************************************************************************** +!**************************************************************************************** + + +!**************************************************************************************** +!**************************************************************************************** +! 40 CLASS MODIS (Outside US, cats 1-20)/NLCD (US only, cats 21-40) LU characterization +!------------------------------------------------------------------------------- +!Index Rstmin Zo Mxfr MnFr MxLA MnLA SNUP ALB SNOALB +! 1 175. 100. 93. 93. 5.5 3.5 0.08 12. 30. Evergreen Needleleaf Forest +! 2 120. 90. 92. 92. 6.0 3.5 0.08 12. 30. Evergreen Broadleaf Forest +! 3 175. 100. 60. 60. 3.0 1.5 0.08 14. 30. Deciduous Needleleaf Forest +! 4 200. 100. 91. 91. 6.0 2.0 0.08 16. 40. Deciduous Broadleaf Forest' +! 5 200. 100. 92. 92. 5.5 2.5 0.08 13. 35. Mixed Forest +! 6 200. 15. 40. 20. 1.5 1.0 0.03 22. 50. Closed Shrublands +! 7 200. 15. 20. 10. 1.5 1.3 0.035 20. 60. Open Shrublands +! 8 150. 25. 70. 60. 2.3 2.0 0.03 22. 50. Woody Savanna +! 9 120. 15. 70. 40. 1.5 1.5 0.04 20. 50. Savanna +!------------------------------------------------------------------------------- +! 10 100. 7. 50. 20. 1.5 1.5 0.04 19. 70. Grasslands +! 11 200 20. 65. 35. 2.5 2.0 0.08 15. 50. Perminent Wetlands +! 12 70. 10. 90. 20. 3.5 1.5 0.04 18. 66. Croplands +! 13 150. 80. 5. 5. 2.0 1.5 0.04 11. 46. Urban andBuilt-up' +! 14 100. 30. 80. 40. 3.5 1.5 0.04 18. 68. Cropland/Natural Vegetation Mosaic +! 15 9999. 1.2 0.1 0.1 0.1 0.1 0.02 60. 82. Snow and Ice +! 16 100. 5. 0.5 0.5 0.2 0.1 0.02 25. 75. Barren or Sparsely Vegetated +! 17 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 08. IGBP water +! 18 175. 30. 70. 50. 3.4 2.0 0.80 15. 45. wooded tundra +! 19 120. 15. 40. 20. 2.4 1.0 0.40 15. 50. mixed tundra +! 20 100. 10. 20. 5. 1.4 0.1 .015 25. 75. barren tundra +! 21 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 08. Open water +! 22 9999. 1.2 0.1 0.1 0.1 0.1 0.02 60. 82. Perennial Ice/snow +! 23 120. 30. 25. 25. 5.5 1.7 0.04 16. 60. Developed, Open space +! 24 120. 80. 15. 15. 3.0 1.7 0.04 13. 46. Developed, Low Intensity +! 25 140. 120. 5. 5. 2.5 1.7 0.04 11. 43. Developed, Medium Intensity +! 26 160. 200. 1. 1. 2.5 2.0 0.04 10. 40. Developed, High Intensity +! 27 100. 5. 0.5 0.5 0.2 0.1 0.02 20. 75. Barren land +! 28 200. 100. 91. 91. 6.0 2.0 0.08 15. 40. Deciduous Forest +! 29 175. 100. 93. 93. 5.5 3.5 0.08 12. 30. Evergreen Forest +!------------------------------------------------------------------------------- +! 30 200. 100. 92. 92. 5.5 2.5 0.08 13. 35. Mixed Forest +! 31 200. 10. 15. 10. 1.0 1.0 0.04 20. 65. Dwarf Scrub +! 32 200. 15. 20. 10. 1.5 1.3 0.04 20. 60. Shrub/Scrub +! 33 100. 7. 50. 20. 2.0 1.5 0.04 19. 70. Grassland/Herbaceous +! 34 100. 7. 30. 20. 2.0 1.5 0.01 23. 60. Sedge/Herbaceous +! 35 100. 5. 20. 20. 1.0 1.0 0.01 20. 60. Lichens +! 36 100. 5. 20. 20. 1.0 1.0 0.01 20. 60. Moss +! 37 80. 7. 80. 10. 3.5 1.5 0.04 18. 68. Pasture/Hay' +! 38 70. 10. 90. 10. 4.0 1.5 0.04 18. 66. Cultivated Crops +!------------------------------------------------------------------------------- +! 39 200. 55. 92. 50. 5.5 2.2 0.08 15. 40. Woody Wetland +! 40 120. 11. 50. 30. 3.0 2.0 0.04 18. 50. Emergent Herbaceous Wetland +!------------------------------------------------------------------------------------ + + REAL, DIMENSION(40), TARGET :: RSMIN_NLCD40, Z00_NLCD40, & + VEG0_NLCD40, VEGMN0_NLCD40, & + LAI0_NLCD40, LAIMN0_NLCD40, & + SNUP0_NLCD40, ALBF_NLCD40, & + SNOALB_NLCD40 + + DATA RSMIN_NLCD40 & + / 175.0, 120.0, 175.0, 200.0, 200.0, & + 200.0, 200.0, 150.0, 120.0, 100.0, & + 200.0, 70.0, 150.0, 100.0, 9999.0, & + 100.0, 9999.0, 175.0, 120.0, 100.0, & + 9999.0, 9999.0, 120.0, 120.0, 140.0, & + 160.0, 100.0, 200.0, 175.0, 200.0, & + 200.0, 200.0, 100.0, 100.0, 100.0, & + 100.0, 80.0, 70.0, 200.0, 120.0 / + + DATA Z00_NLCD40 & + / 100.0, 90.0, 100.0, 100.0, 100.0, & + 15.0, 15.0, 25.0, 15.0, 7.0, & + 20.0, 10.0, 80.0, 30.0, 1.2, & + 5.0, 0.1, 30.0, 15.0, 10.0, & + 0.10, 1.20, 30.0, 80.0, 120.0, & + 200.0, 5.0, 100.0, 100.0, 100.0, & + 10.0, 15.0, 7.0, 7.0, 5.0, & + 5.0, 7.0, 10.0, 55.0, 11.0 / + + DATA VEG0_NLCD40 & + / 93.0, 92.0, 60.0, 91.0, 92.0, & + 40.0, 20.0, 70.0, 70.0, 50.0, & + 65.0, 90.0, 5.0, 80.0, 0.1, & + 0.5, 0.0, 70.0, 40.0, 20.0, & + 0.0, 0.1, 25.0, 15.0, 5.0, & + 1.0, 0.5, 91.0, 93.0, 92.0, & + 15.0, 20.0, 50.0, 30.0, 20.0, & + 20.0, 80.0, 90.0, 92.0, 50.0 / + + DATA VEGMN0_NLCD40 & + / 93.0, 92.0, 60.0, 91.0, 92.0, & + 20.0, 10.0, 60.0, 40.0, 20.0, & + 35.0, 20.0, 5.0, 40.0, 0.1, & + 0.5, 0.0, 50.0, 20.0, 5.0, & + 0.0, 0.1, 25.0, 15.0, 5.0, & + 1.0, 0.5, 91.0, 93.0, 92.0, & + 10.0, 10.0, 20.0, 20.0, 20.0, & + 20.0, 10.0, 10.0, 50.0, 30.0 / + + DATA LAI0_NLCD40 & + / 5.5, 6.0, 3.0, 6.0, 5.5, & + 1.5, 1.5, 2.3, 1.5, 1.5, & + 2.5, 3.5, 2.0, 3.5, 0.1, & + 0.2, 0.0, 3.4, 2.4, 1.4, & + 0.0, 0.1, 5.5, 3.0, 2.5, & + 2.5, 0.2, 6.0, 5.5, 5.5, & + 1.0, 1.5, 2.0, 2.0, 1.0, & + 1.0, 3.5, 4.0, 5.5, 3.0 / + + DATA LAIMN0_NLCD40 & + / 3.5, 3.5, 1.5, 2.0, 2.5, & + 1.0, 1.3, 2.0, 1.5, 1.5, & + 2.0, 1.5, 1.5, 1.5, 0.1, & + 0.1, 0.0, 2.0, 1.0, 0.1, & + 0.0, 0.1, 1.7, 1.7, 1.7, & + 2.0, 0.1, 2.0, 3.5, 2.5, & + 1.0, 1.3, 1.5, 1.5, 1.0, & + 1.0, 1.5, 1.5, 2.2, 2.0 / + + DATA SNUP0_NLCD40 & + / 0.08, 0.08, 0.08, 0.08, 0.08, & + 0.03, 0.035, 0.03, 0.04, 0.04, & + 0.08, 0.04, 0.04, 0.04, 0.02, & + 0.02, 0.01, 0.80, 0.40, 0.015, & + 0.01, 0.02, 0.04, 0.04, 0.04, & + 0.04, 0.02, 0.08, 0.08, 0.08, & + 0.04, 0.04, 0.04, 0.01, 0.01, & + 0.01, 0.04, 0.04, 0.08, 0.04 / + + DATA ALBF_NLCD40 & + / 12.0, 12.0, 14.0, 16.0, 13.0, & + 22.0, 20.0, 22.0, 20.0, 19.0, & + 17.0, 18.0, 11.0, 18.0, 60.0, & + 25.0, 8.0, 15.0, 15.0, 25.0, & + 8.0, 60.0, 12.0, 11.0, 10.0, & + 10.0, 20.0, 15.0, 12.0, 13.0, & + 20.0, 20.0, 19.0, 23.0, 20.0, & + 20.0, 18.0, 18.0, 15.0, 18.0 / + + DATA SNOALB_NLCD40 & + / 30.0, 30.0, 30.0, 40.0, 35.0, & + 50.0, 60.0, 50.0, 50.0, 70.0, & + 50.0, 66.0, 46.0, 68.0, 82.0, & + 75.0, 8.0, 45.0, 50.0, 75.0, & + 8.0, 82.0, 60.0, 46.0, 43.0, & + 40.0, 75.0, 40.0, 30.0, 35.0, & + 65.0, 60.0, 70.0, 60.0, 60.0, & + 60.0, 68.0, 66.0, 40.0, 50.0 / + +!**************************************************************************************** +!**************************************************************************************** +! USGS LU characterization +!--------------------------- +! Name Rstmin Zo Mxfr MnFr MxLA MnLA ALB SNOALB +! 1 Urban 150. 50. 40. 20. 2.0 0.5 15 46. Urban or Built-up Land +! 2 DrCrp 70. 10. 95. 15. 3.0 0.5 17 66. Dryland Cropland and Pasture +! 3 IrCrp 60. 10. 95. 10. 3.0 0.5 18 66. Irrigated Cropland and Pasture +! 4 MixCp 70. 10. 95. 15. 3.0 0.5 18 66. Mixed Dry/Irr Crop and Past +! 5 CrGrM 80. 10. 95. 35. 2.5 1.0 18 70. Grassland/Cropland Mosaic +! 6 CrWdM 180. 40. 95. 40. 4.0 1.5 16 50. Woodland/Cropland Mosaic +! 7 GrsLd 100. 7. 95. 70. 2.5 1.0 19 70. Grassland +! 8 ShrLd 200. 20. 70. 50. 3.0 1.0 22 50. Shrubland +! 9 ShrGr 150. 20. 85. 60. 3.0 1.0 20 60. Mixed Shrubland/Grassland +! 10 Savan 120. 20. 80. 60. 2.0 1.0 20 50. Savanna +! 11 DBFst 200. 50. 95. 50. 5.0 1.0 16 40. Broadleaf Deciduous Forest +! 12 DNFst 175. 50. 95. 50. 5.0 1.0 14 30. Deciduous Coniferous Forest +! 13 EBFst 120. 40. 95. 85. 5.0 4.0 12 30. Evergreen Broadleaf Forest (Palm?) +! 14 ENFst 175. 50. 90. 80. 4.0 3.0 12 30. Evergreen Coniferous Forest +! 15 MxFst 200. 50. 95. 60. 5.0 2.0 13 35. Mixed forest +! 16 Water 9999. 0.1 00. 00. 0.0 0.0 08 08. Water +! 17 HWtld 164. 15. 60. 40. 2.0 1.0 14 50. Herbaceous Wetland (none in east) +! 18 WWtld 200. 45. 90. 80. 5.0 3.0 14 40. Forested Wetlands (e.g. Everglades) +! 19 BarSp 100. 5. 10. 05. 0.5 0.2 25 75. Barren or Sparsely Vegetated +! 20 HrTun 150. 10. 20. 10. 1.0 0.5 15 55. Herbaceous Tundra +! 21 WdTun 200. 10. 30. 10. 1.0 0.5 15 60. Shrub and Brush Tundra +! 22 MxTun 150. 5. 20. 05. 1.0 0.5 15 60. Mixed Tundra +! 23 BGTun 100. 5. 5. 02. 0.1 0.1 25 75. Bare Ground Tundra +! 24 SnwIc 300. 5. 5. 02. 0.1 0.1 55 82. Perennial Snowfields or Glaciers +!----------------------------------------------------------------------------- + + REAL, DIMENSION(24), TARGET :: RSMIN_USGS, Z00_USGS, & + VEG0_USGS, VEGMN0_USGS, & + LAI0_USGS, LAIMN0_USGS, & + SNUP0_USGS, ALBF_USGS, & + SNOALB_USGS + + DATA RSMIN_USGS & + / 150.0, 70.0, 60.0, 70.0, 80.0, & + 180.0, 100.0, 200.0, 150.0, 120.0, & + 200.0, 175.0, 120.0, 175.0, 200.0, & + 9999.0, 164.0, 200.0, 100.0, 150.0, & + 200.0, 150.0, 100.0, 300.0 / + + DATA Z00_USGS & + / 50.0, 10.0, 10.0, 10.0, 10.0, & + 40.0, 7.0, 20.0, 20.0, 20.0, & + 50.0, 50.0, 40.0, 50.0, 50.0, & + 0.1, 15.0, 45.0, 5.0, 10.0, & + 10.0, 5.0, 5.0, 5.0 / + + DATA VEG0_USGS & + / 40.0, 95.0, 95.0, 95.0, 95.0, & + 95.0, 95.0, 70.0, 85.0, 80.0, & + 95.0, 95.0, 95.0, 90.0, 95.0, & + 0.00, 60.0, 90.0, 10.0, 20.0, & + 30.0, 20.0, 5.0, 5.0 / + + DATA VEGMN0_USGS & + / 20.0, 15.0, 10.0, 15.0, 35.0, & + 40.0, 70.0, 50.0, 60.0, 60.0, & + 50.0, 50.0, 85.0, 80.0, 60.0, & + 0.0, 40.0, 80.0, 5.0, 10.0, & + 10.0, 5.0, 2.0, 2.0 / + + DATA LAI0_USGS & + / 2.0, 3.0, 3.0, 3.0, 2.5, & + 4.0, 2.5, 3.0, 3.0, 2.0, & + 5.0, 5.0, 5.0, 4.0, 5.0, & + 0.0, 2.0, 5.0, 0.50, 1.0, & + 1.0, 1.0, 0.1, 0.1 / + + DATA LAIMN0_USGS & + / 0.50, 0.50, 0.50, 0.50, 1.0, & + 1.5, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 4.0, 3.0, 2.0, & + 0.0, 1.0, 3.0, 0.20, 0.50, & + 0.50, 0.50, 0.10, 0.10 / + + DATA SNUP0_USGS & + / 0.04, 0.04, 0.04, 0.04, 0.04, & + 0.04, 0.04, 0.03, 0.035, 0.04, & + 0.08, 0.08, 0.08, 0.08, 0.08, & + 0.01, 0.01, 0.01, 0.02, 0.02, & + 0.025, 0.025, 0.025, 0.02 / + + DATA ALBF_USGS & + / 15.0, 17.0, 18.0, 18.0, 18.0, & + 16.0, 19.0, 22.0, 20.0, 20.0, & + 16.0, 14.0, 12.0, 12.0, 13.0, & + 8.0, 14.0, 14.0, 25.0, 15.0, & + 15.0, 15.0, 25.0, 55.0 / + + DATA SNOALB_USGS & + / 46.0, 66.0, 66.0, 66.0, 70.0, & + 50.0, 70.0, 50.0, 60.0, 50.0, & + 40.0, 40.0, 40.0, 30.0, 35.0, & + 8.0, 50.0, 40.0, 75.0, 55.0, & + 60.0, 60.0, 75.0, 82.0 / + +!**************************************************************************************** +!**************************************************************************************** +!**************************************************************************************** +! USGS LU characterization +!--------------------------- +! Name Rstmin Zo Mxfr MnFr MxLA MnLA ALB SNOALB +! 1 Urban 150. 50. 40. 20. 2.0 0.5 15 46. Urban or Built-up Land +! 2 DrCrp 70. 10. 95. 15. 3.0 0.5 17 66. Dryland Cropland and Pasture +! 3 IrCrp 60. 10. 95. 10. 3.0 0.5 18 66. Irrigated Cropland and Pasture +! 4 MixCp 70. 10. 95. 15. 3.0 0.5 18 66. Mixed Dry/Irr Crop and Past +! 5 CrGrM 80. 10. 95. 35. 2.5 1.0 18 70. Grassland/Cropland Mosaic +! 6 CrWdM 180. 40. 95. 40. 4.0 1.5 16 50. Woodland/Cropland Mosaic +! 7 GrsLd 100. 7. 95. 70. 2.5 1.0 19 70. Grassland +! 8 ShrLd 200. 20. 70. 50. 3.0 1.0 22 50. Shrubland +! 9 ShrGr 150. 20. 85. 60. 3.0 1.0 20 60. Mixed Shrubland/Grassland +! 10 Savan 120. 20. 80. 60. 2.0 1.0 20 50. Savanna +! 11 DBFst 200. 50. 95. 50. 5.0 1.0 16 40. Broadleaf Deciduous Forest +! 12 DNFst 175. 50. 95. 50. 5.0 1.0 14 30. Deciduous Coniferous Forest +! 13 EBFst 120. 40. 95. 85. 5.0 4.0 12 30. Evergreen Broadleaf Forest (Palm?) +! 14 ENFst 175. 50. 90. 80. 4.0 3.0 12 30. Evergreen Coniferous Forest +! 15 MxFst 200. 50. 95. 60. 5.0 2.0 13 35. Mixed forest +! 16 Water 9999. 0.1 00. 00. 0.0 0.0 08 08. Water +! 17 HWtld 164. 15. 60. 40. 2.0 1.0 14 50. Herbaceous Wetland (none in east) +! 18 WWtld 200. 45. 90. 80. 5.0 3.0 14 40. Forested Wetlands (e.g. Everglades) +! 19 BarSp 100. 5. 10. 05. 0.5 0.2 25 75. Barren or Sparsely Vegetated +! 20 HrTun 150. 10. 20. 10. 1.0 0.5 15 55. Herbaceous Tundra +! 21 WdTun 200. 10. 30. 10. 1.0 0.5 15 60. Shrub and Brush Tundra +! 22 MxTun 150. 5. 20. 05. 1.0 0.5 15 60. Mixed Tundra +! 23 BGTun 100. 5. 5. 02. 0.1 0.1 25 75. Bare Ground Tundra +! 24 SnwIc 300. 5. 5. 02. 0.1 0.1 55 82. Perennial Snowfields or Glaciers +! 25 playa 100. 5. 10. 05. 0.5 0.2 25 75. Playa +! 26 lava 100. 5. 10. 05. 0.5 0.2 25 75. Lava +! 27 sand 100. 5. 10. 05. 0.5 0.2 25 75. White Sand +! 28 nana 100. 5. 10. 05. 0.5 0.2 25 75. Unassigned +!----------------------------------------------------------------------------- + + REAL, DIMENSION(28), TARGET :: RSMIN_USGS28, Z00_USGS28, & + VEG0_USGS28, VEGMN0_USGS28, & + LAI0_USGS28, LAIMN0_USGS28, & + SNUP0_USGS28, ALBF_USGS28, & + SNOALB_USGS28 + + DATA RSMIN_USGS28 & + / 150.0, 70.0, 60.0, 70.0, 80.0, & + 180.0, 100.0, 200.0, 150.0, 120.0, & + 200.0, 175.0, 120.0, 175.0, 200.0, & + 9999.0, 164.0, 200.0, 100.0, 150.0, & + 200.0, 150.0, 100.0, 300.0, 100.0, & + 100.0, 100.0, 100.0 / + + DATA Z00_USGS28 & + / 50.0, 10.0, 10.0, 10.0, 10.0, & + 40.0, 7.0, 20.0, 20.0, 20.0, & + 50.0, 50.0, 40.0, 50.0, 50.0, & + 0.1, 15.0, 45.0, 5.0, 10.0, & + 10.0, 5.0, 5.0, 5.0, 5.0, & + 5.0, 5.0, 5.0 / + + DATA VEG0_USGS28 & + / 40.0, 95.0, 95.0, 95.0, 95.0, & + 95.0, 95.0, 70.0, 85.0, 80.0, & + 95.0, 95.0, 95.0, 90.0, 95.0, & + 0.00, 60.0, 90.0, 10.0, 20.0, & + 30.0, 20.0, 5.0, 5.0, 5.0, & + 5.0, 5.0, 5.0 / + + DATA VEGMN0_USGS28 & + / 20.0, 15.0, 10.0, 15.0, 35.0, & + 40.0, 70.0, 50.0, 60.0, 60.0, & + 50.0, 50.0, 85.0, 80.0, 60.0, & + 0.0, 40.0, 80.0, 5.0, 10.0, & + 10.0, 5.0, 2.0, 2.0, 2.0, & + 2.0, 2.0, 2.0 / + + DATA LAI0_USGS28 & + / 2.0, 3.0, 3.0, 3.0, 2.5, & + 4.0, 2.5, 3.0, 3.0, 2.0, & + 5.0, 5.0, 5.0, 4.0, 5.0, & + 0.0, 2.0, 5.0, 0.50, 1.0, & + 1.0, 1.0, 0.1, 0.1, 0.1, & + 0.1, 0.1, 0.1 / + + DATA LAIMN0_USGS28 & + / 0.50, 0.50, 0.50, 0.50, 1.0, & + 1.5, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 4.0, 3.0, 2.0, & + 0.0, 1.0, 3.0, 0.20, 0.50, & + 0.50, 0.50, 0.10, 0.10, 0.10, & + 0.10, 0.10, 0.10 / + + DATA SNUP0_USGS28 & + / 0.04, 0.04, 0.04, 0.04, 0.04, & + 0.04, 0.04, 0.03, 0.035, 0.04, & + 0.08, 0.08, 0.08, 0.08, 0.08, & + 0.01, 0.01, 0.01, 0.02, 0.02, & + 0.025, 0.025, 0.025, 0.02, 0.02, & + 0.02, 0.02, 0.02 / + + DATA ALBF_USGS28 & + / 15.0, 17.0, 18.0, 18.0, 18.0, & + 16.0, 19.0, 22.0, 20.0, 20.0, & + 16.0, 14.0, 12.0, 12.0, 13.0, & + 8.0, 14.0, 14.0, 25.0, 15.0, & + 15.0, 15.0, 25.0, 55.0, 25.0, & + 10.0, 50.0, 50.0 / + + DATA SNOALB_USGS28 & + / 46.0, 66.0, 66.0, 66.0, 70.0, & + 50.0, 70.0, 50.0, 60.0, 50.0, & + 40.0, 40.0, 40.0, 30.0, 35.0, & + 8.0, 50.0, 40.0, 75.0, 55.0, & + 60.0, 60.0, 75.0, 82.0, 75.0, & + 75.0, 75.0, 75.0 / + +!**************************************************************************************** +!**************************************************************************************** + +END MODULE module_sf_pxlsm_data diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 7bc8d53146..8c270e40fd 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -36,6 +36,10 @@ description="The number of first-guess atmospheric layers"/> + + + 8 = surface field (SST, sea-ice) update file for use with real-data simulations, \newline + 9 = lateral boundary conditions update file for use with real-data simulations, \newline + 10 = P-X soil nudging update file for use with real-data simulations, \newline + 13 = CAM-MPAS 3-d grid with specified topography and zeta levels" + possible_values="1 -- 10, or 13"/> + + + + + possible_values="`USGS' or `MODIFIED_IGBP_MODIS_NOAH' or `NLCD40'"/> + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -392,13 +503,17 @@ + + + + @@ -488,13 +603,17 @@ + + + + @@ -547,10 +666,15 @@ + + + + + @@ -561,6 +685,8 @@ + + + + + + + + + + + + - + + + @@ -755,16 +901,19 @@ - + - - - + + + + + + @@ -1106,7 +1262,7 @@ description="geopotential height vertically interpolated from first guess" packages="met_stage_out"/> - @@ -1114,10 +1270,34 @@ description="background surface albedo" packages="met_stage_out"/> + + + + + + + + + + + + + + domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + + ! Defined in mpas_init_atm_surface.F + call init_atm_case_soilndg(domain, domain % dminfo, stream_manager, mesh, fg, state, block_ptr % dimensions, block_ptr % configs) + block_ptr => block_ptr % next + end do + else if (config_init_case == 13 ) then call mpas_log_write(' CAM-MPAS grid ') @@ -369,9 +383,9 @@ subroutine init_atm_setup_case(domain, stream_manager) else - call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write(' Only test cases 1 through 9 and 13 are currently supported.', messageType=MPAS_LOG_ERR) - call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_CRIT) + call mpas_log_write(' ************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Only test cases 1 through 10 and 13 are currently supported.', messageType=MPAS_LOG_ERR) + call mpas_log_write(' ************************************************************', messageType=MPAS_LOG_CRIT) end if @@ -453,7 +467,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs) real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, str - real (kind=RKIND) :: es, xnutr, znut, ptemp + real (kind=RKIND) :: es, xnutr, znut, ptemp real (kind=RKIND), dimension(nVertLevels + 1 ) :: sh, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm @@ -1964,7 +1978,7 @@ subroutine init_atm_case_mtn_wave(mesh, nCells, nVertLevels, state, diag, config real (kind=RKIND) :: um, vm,rcp, rcv real (kind=RKIND) :: temp, pres, a_scale - real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, z_edge, z_edge3 + real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, z_edge, z_edge3 integer, dimension(nCells, 2) :: next_cell logical, parameter :: terrain_smooth = .false. @@ -2600,7 +2614,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two real (kind=RKIND) :: target_z - integer :: iCell, iCell1, iCell2 , iEdge, i, k, nz, cell1, cell2 + integer :: iCell, iCell1, iCell2 , iEdge, i, k, nz, itr, itrp, cell1, cell2 integer, pointer :: nCellsSolve, nz1 integer :: nInterpPoints, ndims @@ -2647,7 +2661,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND) :: p0 - real (kind=RKIND) :: etavs, ztemp, zd, zt, dz, str + real (kind=RKIND) :: etavs, ztemp, zd, zt, dz, str, grd, kfrac real (kind=RKIND) :: es, rs, xnutr, znut, rcv @@ -2676,6 +2690,24 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), pointer :: config_ztop logical, pointer :: config_tc_vertical_grid character (len=StrKIND), pointer :: config_specified_zeta_levels + logical, pointer :: config_spline_vertical_grid + real (kind=RKIND), pointer :: config_spline_x1 + real (kind=RKIND), pointer :: config_spline_y1 + real (kind=RKIND), pointer :: config_spline_x2 + real (kind=RKIND), pointer :: config_spline_y2 + real (kind=RKIND), pointer :: config_spline_x3 + real (kind=RKIND), pointer :: config_spline_y3 + real (kind=RKIND), pointer :: config_spline_x4 + real (kind=RKIND), pointer :: config_spline_y4 + real (kind=RKIND), pointer :: config_spline_x5 + real (kind=RKIND), pointer :: config_spline_y5 + real (kind=RKIND), pointer :: config_spline_x6 + real (kind=RKIND), pointer :: config_spline_y6 + real (kind=RKIND), pointer :: config_spline_x7 + real (kind=RKIND), pointer :: config_spline_y7 + real (kind=RKIND), pointer :: config_spline_x8 + real (kind=RKIND), pointer :: config_spline_y8 + logical, pointer :: config_EPA_vertical_grid logical, pointer :: config_use_spechumd integer, pointer :: config_nfglevels integer, pointer :: config_nfgsoillevels @@ -2705,6 +2737,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:), pointer :: rho real (kind=RKIND), dimension(:,:), pointer :: relhum real (kind=RKIND), dimension(:,:), pointer :: spechum + real (kind=RKIND), dimension(:,:), pointer :: ozone real (kind=RKIND), dimension(:,:), pointer :: ru real (kind=RKIND), dimension(:,:), pointer :: rw real (kind=RKIND), dimension(:), pointer :: precipw @@ -2715,6 +2748,8 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:), pointer :: uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: psfc + real (kind=RKIND), dimension(:), pointer :: hgttrop + real (kind=RKIND), dimension(:), pointer :: ptrop real (kind=RKIND), dimension(:), pointer :: skintemp real (kind=RKIND), dimension(:), pointer :: snow real (kind=RKIND), dimension(:), pointer :: snowc @@ -2724,6 +2759,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:), pointer :: t_fg real (kind=RKIND), dimension(:,:), pointer :: rh_fg real (kind=RKIND), dimension(:,:), pointer :: sh_fg + real (kind=RKIND), dimension(:,:), pointer :: o3_fg real (kind=RKIND), dimension(:,:), pointer :: gfs_z real (kind=RKIND), dimension(:,:), pointer :: p_fg real (kind=RKIND), dimension(:,:), pointer :: st_fg @@ -2734,11 +2770,36 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state logical :: too_many_fg_levs integer :: level_value - ! For outputting surface fields u10, v10, q2, rh2, and t2m from first-guess data + ! For outputting surface fields q2, rh2, and t2m from first-guess data real (kind=RKIND), dimension(:), pointer :: q2 real (kind=RKIND), dimension(:), pointer :: rh2 real (kind=RKIND), dimension(:), pointer :: t2m + ! For cubic spline definition of air quality layer thickness profile + integer, parameter :: nprof = 8 + real (kind=RKIND), dimension(nprof) :: & + xx, &!< x-dimension control point for cubic spline interpolation + yy !< y-dimension control point for cubic spline interpolation + real (kind=RKIND), parameter :: & + cadj = 0.3, &!< layer thickness adjustment coefficient + ctol = 0.001 !< tolerance for layer fit to model top + real (kind=RKIND), dimension(nprof) :: & + ya, &!< Thickness scaled to match model top + y2ndDer, &!< 2nd derivative at nodes of layer profile definition + acoef !< Tridiagonal decomposition factor + real (kind=RKIND) :: & + thick, &!< Interpolated layer thickness + zint, &!< Height for interpolation + ptef, &!< Profile top error factor + adj, &!< Thickness adjustment factor + xRatio, &!< X-dimension scale for interpolation + tvar, &!< temporary variable + aa, &!< temporary variable + bb, &!< temporary variable + cc !< temporary variable + real (kind=RKIND), dimension(nVertLevels+1) :: zwtemp + integer :: nlayerint, klo, khi, ncount + character (len=StrKIND) :: errstring call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) @@ -2751,6 +2812,24 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_pool_get_config(configs, 'config_ztop', config_ztop) call mpas_pool_get_config(configs, 'config_tc_vertical_grid', config_tc_vertical_grid) call mpas_pool_get_config(configs, 'config_specified_zeta_levels', config_specified_zeta_levels) + call mpas_pool_get_config(configs, 'config_EPA_vertical_grid', config_EPA_vertical_grid) + call mpas_pool_get_config(configs, 'config_spline_vertical_grid', config_spline_vertical_grid) + call mpas_pool_get_config(configs, 'config_spline_x1', config_spline_x1) + call mpas_pool_get_config(configs, 'config_spline_y1', config_spline_y1) + call mpas_pool_get_config(configs, 'config_spline_x2', config_spline_x2) + call mpas_pool_get_config(configs, 'config_spline_y2', config_spline_y2) + call mpas_pool_get_config(configs, 'config_spline_x3', config_spline_x3) + call mpas_pool_get_config(configs, 'config_spline_y3', config_spline_y3) + call mpas_pool_get_config(configs, 'config_spline_x4', config_spline_x4) + call mpas_pool_get_config(configs, 'config_spline_y4', config_spline_y4) + call mpas_pool_get_config(configs, 'config_spline_x5', config_spline_x5) + call mpas_pool_get_config(configs, 'config_spline_y5', config_spline_y5) + call mpas_pool_get_config(configs, 'config_spline_x6', config_spline_x6) + call mpas_pool_get_config(configs, 'config_spline_y6', config_spline_y6) + call mpas_pool_get_config(configs, 'config_spline_x7', config_spline_x7) + call mpas_pool_get_config(configs, 'config_spline_y7', config_spline_y7) + call mpas_pool_get_config(configs, 'config_spline_x8', config_spline_x8) + call mpas_pool_get_config(configs, 'config_spline_y8', config_spline_y8) call mpas_pool_get_config(configs, 'config_use_spechumd', config_use_spechumd) call mpas_pool_get_config(configs, 'config_nfglevels', config_nfglevels) call mpas_pool_get_config(configs, 'config_nfgsoillevels', config_nfgsoillevels) @@ -2815,6 +2894,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_pool_get_array(diag, 'surface_pressure', surface_pressure) call mpas_pool_get_array(diag, 'relhum', relhum) call mpas_pool_get_array(diag, 'spechum', spechum) + call mpas_pool_get_array(diag, 'ozone', ozone) call mpas_pool_get_array(diag, 'ru', ru) call mpas_pool_get_array(diag, 'rw', rw) @@ -2851,6 +2931,8 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_pool_get_array(fg, 'st_fg', st_fg) call mpas_pool_get_array(fg, 'sm_fg', sm_fg) call mpas_pool_get_array(fg, 'psfc', psfc) + call mpas_pool_get_array(fg, 'ptrop', ptrop) + call mpas_pool_get_array(fg, 'hgttrop', hgttrop) call mpas_pool_get_array(fg, 'skintemp', skintemp) call mpas_pool_get_array(fg, 'snow', snow) call mpas_pool_get_array(fg, 'snowc', snowc) @@ -2860,6 +2942,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_pool_get_array(fg, 't', t_fg) call mpas_pool_get_array(fg, 'rh', rh_fg) call mpas_pool_get_array(fg, 'sh', sh_fg) + call mpas_pool_get_array(fg, 'o3', o3_fg) call mpas_pool_get_array(fg, 'gfs_z', gfs_z) call mpas_pool_get_array(fg, 'p', p_fg) @@ -3043,6 +3126,127 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state if (k > 1) dzw(k-1) = zw(k)-zw(k-1) end do + else if (config_spline_vertical_grid) then + + call mpas_log_write('Setting up vertical levels using a cubic spline fit') + + zt = config_ztop + xx(1) = config_spline_x1 + yy(1) = config_spline_y1 + xx(2) = config_spline_x2 + yy(2) = config_spline_y2 + xx(3) = config_spline_x3 + yy(3) = config_spline_y3 + xx(4) = config_spline_x4 + yy(4) = config_spline_y4 + xx(5) = config_spline_x5 + yy(5) = config_spline_y5 + xx(6) = config_spline_x6 + yy(6) = config_spline_y6 + xx(7) = config_spline_x7 + yy(7) = config_spline_y7 + xx(8) = config_spline_x8 + yy(8) = config_spline_y8 + +! Set up cubic spline definition of layer thickness vertical profile + y2ndDer(1)=0.0 + y2ndDer(nprof)=0.0 + acoef(1)=0.0 + ya(1:nprof) = yy(1:nprof) + + do i=2,nprof-1 + xRatio=(xx(i)-xx(i-1))/(xx(i+1)-xx(i-1)) + tvar=1.0/(2.0+xRatio*y2ndDer(i-1)) + y2ndDer(i)=tvar*(xRatio-1.0) + acoef(i) = tvar*(6.0*((ya(i+1)-ya(i))/(xx(i+1)-xx(i)) & + -(ya(i)-ya(i-1))/(xx(i)-xx(i-1)))/(xx(i+1)-xx(i-1)) & + -xRatio*acoef(i-1)) + enddo + + do i=nprof-1,1,-1 + y2ndDer(i)=y2ndDer(i)*y2ndDer(i+1)+acoef(i) + enddo + +! Loop to set layer interface heights from air quality profile + ptef = 0. + zwtemp(1)= 0. + ncount = 0 + do while(abs(1.0-ptef) > ctol) + zwtemp(2) = ya(1) + zint = ya(1) + nlayerint = 2 + do while (nlayerint.lt.nz) + klo=1 + khi=nprof + do while (khi-klo.gt.1) + k=(khi+klo)/2 + if(xx(k).gt.zint)then + khi=k + else + klo=k + endif + enddo + cc=xx(khi)-xx(klo) + aa=(xx(khi)-zint)/cc + bb=(zint-xx(klo))/cc + thick=aa*ya(klo)+bb*ya(khi)+((aa**3-aa)*y2ndDer(klo)+ & + (bb**3-bb)*y2ndDer(khi))*(cc**2)/6. + zint = zint+thick + nlayerint = nlayerint+1 + zwtemp(nlayerint) = zint + enddo + if(ptef.eq.0.) then + ptef = zt/zint + if(ptef > 1.5) then + call mpas_log_write('*** Significant layer inflation required ***') + call mpas_log_write('*** You may want to use more layers ***') + call mpas_log_write('*** and/or a lower model top ***') + else if(ptef < 0.6) then + call mpas_log_write('*** Significant layer deflation required ***') + call mpas_log_write('*** You may want to use fewer layers ***') + call mpas_log_write('*** and/or a higher model top ***') + endif + else + ptef = zt/zint + endif + call mpas_log_write('Using first layer, ptef = $r $r',realArgs=(/ya(1),ptef/)) + ncount = ncount+1 + if(ncount > 20) then + call mpas_log_write('*** ERROR: layer adjustment failure ***') + call mpas_log_write(' *** Iteration did not converge ***') + call mpas_dmpar_global_abort('****************************************************************************', deferredAbort=.true.) + call mpas_dmpar_global_abort('ERROR: Aborted while setting up vertical levels for Air Quality applications', deferredAbort=.true.) + call mpas_dmpar_global_abort('****************************************************************************') + endif + adj = 1.0+(cadj*(ptef-1.0)) + ya(1:nprof) = ya(1:nprof)*adj + y2ndDer(1:nprof) = y2ndDer(1:nprof)*adj + enddo + +! Now make minor adjustment to layers to fit within specified top + do k=1,nz + zw(k) = zwtemp(k)*ptef + enddo + call mpas_log_write('Layers for Air Quality applications generated') + call mpas_log_write('Number of layers and Model top = $i $r',intArgs=(/nz1/),realArgs=(/zt/)) + call mpas_log_write('Adjusted bottom layer thickness (m) = $r',realArgs=(/zw(2)/)) + call mpas_log_write('') + + else if (config_EPA_vertical_grid) then + + call mpas_log_write('Setting up vertical levels as in MPAS 4.0 and earlier, but') + call mpas_log_write('*** Using custom layer definition ***') + + str = 3. + grd = 0.03 + zt = config_ztop + + do k=1,nz + kfrac = real(k-1)/real(nz1) + zw(k) = zt*((1-grd)*kfrac**str+grd*kfrac) + if (k > 1) dzw(k-1) = zw(k)-zw(k-1) + end do + ! ! Otherwise, use the vertical level configuration from MPAS v2.0 ! @@ -3402,9 +3606,12 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state trim(field % field) == 'TT' .or. & trim(field % field) == 'RH' .or. & trim(field % field) == 'SPECHUMD' .or. & + trim(field % field) == 'O3' .or. & trim(field % field) == 'GHT' .or. & trim(field % field) == 'PMSL' .or. & trim(field % field) == 'PSFC' .or. & + trim(field % field) == 'PTROP' .or. & + trim(field % field) == 'HGTTROP' .or. & trim(field % field) == 'SOILHGT' .or. & trim(field % field) == 'SM000010' .or. & trim(field % field) == 'SM010040' .or. & @@ -3452,6 +3659,8 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state trim(field % field) == 'ST028100' .or. & trim(field % field) == 'ST100255' .or. & trim(field % field) == 'ST100289' .or. & + trim(field % field) == 'PTROP' .or. & + trim(field % field) == 'HGTTROP' .or. & trim(field % field) == 'SNOW' .or. & trim(field % field) == 'SEAICE' .or. & trim(field % field) == 'SKINTEMP') then @@ -3580,6 +3789,13 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state lonPoints => lonCell call mpas_pool_get_array(fg, 'sh', destField2d) ndims = 2 + else if (trim(field % field) == 'O3') then + call mpas_log_write('Interpolating O3 at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'o3', destField2d) + ndims = 2 else if (trim(field % field) == 'GHT') then call mpas_log_write('Interpolating GHT at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) nInterpPoints = nCells @@ -3615,6 +3831,20 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state lonPoints => lonCell call mpas_pool_get_array(fg, 'psfc', destField1d) ndims = 1 + else if (trim(field % field) == 'PTROP') then + call mpas_log_write('Interpolating PTROP') + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'ptrop', destField1d) + ndims = 1 + else if (trim(field % field) == 'HGTTROP') then + call mpas_log_write('Interpolating HGTTROP') + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'hgttrop', destField1d) + ndims = 1 else if (trim(field % field) == 'SOILHGT') then call mpas_log_write('Interpolating SOILHGT') nInterpPoints = nCells @@ -4584,6 +4814,22 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state end do + ! O3 + sorted_arr(:,:) = -999.0 + ozone(:,iCell) = 0._RKIND + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = o3_fg(k,iCell) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = nVertLevels, 1, -1 + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) + ozone(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & + sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) + end do + + ! GHT sorted_arr(:,:) = -999.0 do k = 1, nfglevels_actual @@ -6537,32 +6783,39 @@ subroutine physics_idealized_init(mesh, fg) type (mpas_pool_type), intent(inout) :: fg !local variables: - integer :: iCell, iMonth, iSoil - integer, pointer :: nCells, nSoilLevels, nMonths - integer, dimension(:), pointer :: landmask, lu_index, soilcat_top - real (kind=RKIND), dimension(:), pointer :: ter, xice, shdmin, shdmax, vegfra, sfc_albbck, xland, seaice + integer :: iCell, iMonth, iSoil, iLandCat, iSoilCat + integer, pointer :: nCells, nSoilLevels, nMonths, nLandCat, nSoilCat + integer, dimension(:), pointer :: landmask, lu_index, soilcat + real (kind=RKIND), dimension(:), pointer :: ter, xice, shdmin, shdmax, vegfra, sfc_albbck, xland, seaice, lai_modis real (kind=RKIND), dimension(:), pointer :: snow, snowc, snoalb, snowh, skintemp, sst, tmn - real (kind=RKIND), dimension(:,:), pointer :: tslb, smcrel, sh2o, smois, dzs, albedo12m, greenfrac + real (kind=RKIND), dimension(:,:), pointer :: landusef, soiltypf + real (kind=RKIND), dimension(:,:), pointer :: tslb, smcrel, sh2o, smois, dzs, albedo12m, greenfrac, lai12m !--------------------------------------------------------------------------------------------- call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nSoilLevels', nSoilLevels) call mpas_pool_get_dimension(mesh, 'nMonths', nMonths) + call mpas_pool_get_dimension(mesh, 'nLandCat', nLandCat) + call mpas_pool_get_dimension(mesh, 'nSoilCat', nSoilCat) call mpas_pool_get_array(mesh, 'ter', ter) call mpas_pool_get_array(mesh, 'landmask', landmask) call mpas_pool_get_array(mesh, 'lu_index', lu_index) - call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) + call mpas_pool_get_array(mesh, 'landusef', landusef) + call mpas_pool_get_array(mesh, 'soilcat', soilcat) + call mpas_pool_get_array(mesh, 'soiltypf', soiltypf) call mpas_pool_get_array(mesh, 'shdmin', shdmin) call mpas_pool_get_array(mesh, 'shdmax', shdmax) call mpas_pool_get_array(mesh, 'snoalb', snoalb) call mpas_pool_get_array(mesh, 'albedo12m', albedo12m) call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) + call mpas_pool_get_array(mesh, 'lai12m', lai12m) call mpas_pool_get_array(fg, 'xice', xice) call mpas_pool_get_array(fg, 'vegfra', vegfra) call mpas_pool_get_array(fg, 'sfc_albbck', sfc_albbck) + call mpas_pool_get_array(fg, 'lai_modis', lai_modis) call mpas_pool_get_array(fg, 'xland', xland) call mpas_pool_get_array(fg, 'seaice', seaice) call mpas_pool_get_array(fg, 'snow', snow) @@ -6588,11 +6841,12 @@ subroutine physics_idealized_init(mesh, fg) xice(iCell) = 0.0 landmask(iCell) = 0 lu_index(iCell) = 0 - soilcat_top(iCell) = 0 + soilcat(iCell) = 0 shdmin(iCell) = 0.0 shdmax(iCell) = 0.0 vegfra(iCell) = 0.0 sfc_albbck(iCell) = 0.0 + lai_modis(iCell) = 0.0 xland(iCell) = 0.0 seaice(iCell) = 0.0 @@ -6615,11 +6869,22 @@ subroutine physics_idealized_init(mesh, fg) smois(iSoil,iCell) = 0.0 dzs(iSoil,iCell) = 0.0 end do + + !fractional soil type: + do iSoilCat = 1, nSoilCat + soiltypf(iSoilCat,iCell) = 0.0 + end do + + !fractional land use: + do iLandCat = 1, nLandCat + landusef(iLandCat,iCell) = 0.0 + end do - !monthly climatological surface albedo and greeness fraction: + !monthly climatological surface albedo, greeness fraction, and leaf area index: do iMonth = 1, nMonths albedo12m(iMonth,iCell) = 0.08 greenfrac(iMonth,iCell) = 0.0 + lai12m(iMonth,iCell) = 0.0 end do end do diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index c4e35dc382..bc9821a7e6 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -113,6 +113,7 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) integer :: ierr logical, pointer :: initial_conds, sfc_update, lbcs + logical, pointer :: soilndg_update logical, pointer :: gwd_stage_in, gwd_stage_out, vertical_stage_in, vertical_stage_out, met_stage_in, met_stage_out logical, pointer :: config_native_gwd_static, config_static_interp, config_vertical_grid, config_met_interp logical, pointer :: first_guess_field @@ -133,6 +134,9 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) nullify(sfc_update) call mpas_pool_get_package(packages, 'sfc_updateActive', sfc_update) + nullify(soilndg_update) + call mpas_pool_get_package(packages, 'soilndg_updateActive', soilndg_update) + nullify(lbcs) call mpas_pool_get_package(packages, 'lbcsActive', lbcs) @@ -156,6 +160,7 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) if (.not. associated(initial_conds) .or. & .not. associated(sfc_update) .or. & + .not. associated(soilndg_update) .or. & .not. associated(gwd_stage_in) .or. & .not. associated(gwd_stage_out) .or. & .not. associated(vertical_stage_in) .or. & @@ -183,6 +188,14 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) lbcs = .false. end if + if (config_init_case == 10) then + initial_conds = .false. + soilndg_update = .true. + else + initial_conds = .true. + soilndg_update = .false. + end if + if (config_init_case == 7) then ! diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index f38529052b..9758331e28 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -88,9 +88,11 @@ end subroutine interp_accumulation_function ! 12.1.2.2 of the Fortran standard) and currently, only PGI does not support this, so ! use module level variables for now... ! + real (kind=RKIND), dimension(:,:), pointer :: landusef + real (kind=RKIND), dimension(:,:), pointer :: soiltypf integer (kind=I8KIND), dimension(:), pointer :: ter_integer integer, dimension(:), pointer :: lu_index - integer, dimension(:), pointer :: soilcat_top + integer, dimension(:), pointer :: soilcat integer, dimension(:), pointer :: nhs integer, dimension(:,:), allocatable:: ncat ! Landmask is used by the accumulation function for maxsnoalb so it needs to be a global variable @@ -148,6 +150,7 @@ subroutine init_atm_static(mesh, dims, configs) integer, pointer :: isice_lu, iswater_lu integer :: iswater_soil + integer, pointer :: ismax_lu integer, pointer :: nCells, nCellsSolve, nEdges, nVertices, maxEdges logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius @@ -171,12 +174,16 @@ subroutine init_atm_static(mesh, dims, configs) integer (kind=I8KIND), dimension(:), pointer :: snoalb_integer real (kind=RKIND), dimension(:), pointer :: shdmin, shdmax real (kind=RKIND), dimension(:,:), pointer :: greenfrac + real (kind=RKIND), dimension(:,:), pointer :: lai12m + integer (kind=I8KIND), dimension(:,:), pointer :: lai12m_int real (kind=RKIND), dimension(:,:), pointer :: albedo12m integer (kind=I8KIND), dimension(:,:), pointer :: albedo12m_int + real (kind=RKIND), dimension(:,:), pointer :: landusef + real (kind=RKIND), dimension(:,:), pointer :: soiltypf real (kind=RKIND) :: fillval real (kind=RKIND), pointer :: missing_value integer, dimension(:), pointer :: lu_index - integer, dimension(:), pointer :: soilcat_top + integer, dimension(:), pointer :: soilcat integer, dimension(:), pointer :: landmask integer, dimension(:), pointer :: bdyMaskCell character(len=StrKIND), pointer :: mminlu @@ -254,13 +261,17 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) call mpas_pool_get_array(mesh, 'lu_index', lu_index) + call mpas_pool_get_array(mesh, 'landusef', landusef) call mpas_pool_get_array(mesh, 'mminlu', mminlu) call mpas_pool_get_array(mesh, 'isice_lu', isice_lu) call mpas_pool_get_array(mesh, 'iswater_lu', iswater_lu) - call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) + call mpas_pool_get_array(mesh, 'ismax_lu', ismax_lu) + call mpas_pool_get_array(mesh, 'soilcat', soilcat) + call mpas_pool_get_array(mesh, 'soiltypf', soiltypf) call mpas_pool_get_array(mesh, 'landmask', landmask) call mpas_pool_get_array(mesh, 'snoalb', snoalb) call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) + call mpas_pool_get_array(mesh, 'lai12m', lai12m) call mpas_pool_get_array(mesh, 'albedo12m', albedo12m) call mpas_pool_get_array(mesh, 'shdmin', shdmin) call mpas_pool_get_array(mesh, 'shdmax', shdmax) @@ -340,11 +351,14 @@ subroutine init_atm_static(mesh, dims, configs) write(mminlu,'(a)') 'USGS' case('MODIFIED_IGBP_MODIS_NOAH') write(mminlu,'(a)') 'MODIFIED_IGBP_MODIS_NOAH' + case('NLCD40') + write(mminlu,'(a)') 'NLCD40' case default call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Invalid land use dataset '''//trim(config_landuse_data) & //''' selected for config_landuse_data', messageType=MPAS_LOG_ERR) - call mpas_log_write(' Possible options are: ''USGS'', ''MODIFIED_IGBP_MODIS_NOAH''', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Possible options are: ''USGS'', ''MODIFIED_IGBP_MODIS_NOAH'', ', messageType=MPAS_LOG_ERR) + call mpas_log_write(' or ''NLCD40''' , messageType=MPAS_LOG_ERR) call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select surface_input_select0 @@ -383,46 +397,80 @@ subroutine init_atm_static(mesh, dims, configs) case('MODIFIED_IGBP_MODIS_NOAH') call mpas_log_write('Using 20-class MODIS 30-arc-second land cover dataset') geog_sub_path = 'modis_landuse_20class_30s/' + case('NLCD40') + call mpas_log_write('Using 20-class MODIS 30-arc-second land cover dataset for most of globe') + geog_sub_path = 'modis_landuse_20class_30s/' case default call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Invalid land use dataset '''//trim(config_landuse_data) & //''' selected for config_landuse_data', messageType=MPAS_LOG_ERR) - call mpas_log_write(' Possible options are: ''USGS'', ''MODIFIED_IGBP_MODIS_NOAH''', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Possible options are: ''USGS'', ''MODIFIED_IGBP_MODIS_NOAH'', ', messageType=MPAS_LOG_ERR) + call mpas_log_write(' or ''NLCD40''' , messageType=MPAS_LOG_ERR) call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select surface_input_select1 call mpas_log_write('--- start interpolate LU_INDEX') - call interp_landuse(mesh, tree, trim(config_geog_data_path)//trim(geog_sub_path), isice_lu, iswater_lu) + call interp_landuse(mesh, tree, trim(config_geog_data_path)//trim(geog_sub_path), isice_lu, iswater_lu, ismax_lu, configs) call mpas_log_write('--- end interpolate LU_INDEX') + if (config_landuse_data == 'NLCD40') then + ! Incorporate NLCD fractional percentage land use for CONUS, with MODIS for rest of world + call mpas_log_write('Overlaying 40-class NLCD 9-arc-second land cover dataset for CONUS') + geog_sub_path = 'nlcd2011_ll_9s/' + call mpas_log_write('--- start interpolate NLCD LU_INDEX for CONUS') + call interp_landuse2(mesh, dims, configs, trim(config_geog_data_path)//trim(geog_sub_path), isice_lu, iswater_lu, ismax_lu) + call mpas_log_write('--- end interpolate NLCD LU_INDEX for CONUS') + end if + ! -! Interpolate SOILCAT_TOP +! Interpolate SOILCAT ! - geog_sub_path = 'soiltype_top_30s/' + surface_input_select2: select case(trim(config_landuse_data)) + case('USGS') + geog_sub_path = 'soiltype_top_30s/' + case('MODIFIED_IGBP_MODIS_NOAH') + geog_sub_path = 'soiltype_top_30s/' + case('NLCD40') + geog_sub_path = 'soiltype_bot_30s/' + case default + end select surface_input_select2 - call mpas_log_write('--- start interpolate SOILCAT_TOP') - call interp_soilcat(mesh, tree, trim(config_geog_data_path)//trim(geog_sub_path), iswater_soil) - call mpas_log_write('--- end interpolate SOILCAT_TOP') + call mpas_log_write('--- start interpolate SOILCAT') + call interp_soilcat(mesh, tree, trim(config_geog_data_path)//trim(geog_sub_path), iswater_soil, configs) + call mpas_log_write('--- end interpolate SOILCAT') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! KLUDGE TO FIX SOIL TYPE OVER ANTARCTICA !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - where (lu_index == isice_lu) soilcat_top = 16 +! where (lu_index == isice_lu) soilcat = 16 + do iCell = 1,nCells + if (lu_index(iCell) == isice_lu) then + do i = 1,16 + soiltypf(i,iCell) = 0.0 + end do + soilcat(iCell) = 16 + soiltypf(soilcat(iCell),iCell) = 1.0 + end if + end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! CORRECT INCONSISTENT SOIL AND LAND USE DATA !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do iCell = 1,nCells if (lu_index(iCell) == iswater_lu .or. & - soilcat_top(iCell) == iswater_soil) then + soilcat(iCell) == iswater_soil) then if (lu_index(iCell) /= iswater_lu) then call mpas_log_write('Turning lu_index into water at $i', intArgs=(/iCell/)) + landusef(lu_index(iCell),iCell) = 0.0 lu_index(iCell) = iswater_lu + landusef(lu_index(iCell),iCell) = 1.0 ! Currently defines dominant land use fraction only + soiltypf(soilcat(iCell),iCell) = 1.0 ! Currently defines dominant soil type fraction only end if - if (soilcat_top(iCell) /= iswater_soil) then - call mpas_log_write('Turning soilcat_top into water at $i', intArgs=(/iCell/)) - soilcat_top(iCell) = iswater_soil + if (soilcat(iCell) /= iswater_soil) then + call mpas_log_write('Turning soilcat into water at $i', intArgs=(/iCell/)) + soilcat(iCell) = iswater_soil + soiltypf(soilcat(iCell),iCell) = 1.0 ! Currently defines dominant soil type fraction only end if end if end do @@ -919,6 +967,150 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('--- end interpolate GREENFRAC') +! +! Interpolate LAI +! + + call mpas_log_write('Using MODIS LAI 30-arc-second data for climatological monthly leaf area index') + + geog_sub_path = 'lai_modis_30s/' + + ierr = mgr % init(trim(config_geog_data_path)//trim(geog_sub_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred when initalizing the interpolation of monthly leaf area index (lai12m)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z', tile_nz) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor_ptr) + scalefactor = scalefactor_ptr + + allocate(nhs(nCells)) + allocate(lai12m_int(tile_nz, nCells)) + nhs(:) = 0 + lai12m(:,:) = 0.0 + lai12m_int(:,:) = 0_I8KIND + fillval = 0.0 + + do iCell = 1, nCells + if (nhs(iCell) == 0) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_CRIT) + end if + + ierr = mgr % push_tile(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing this tile onto the stack: "//trim(tile % fname), messageType=MPAS_LOG_CRIT) + end if + end if + + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + + all_pixels_mapped_to_halo_cells = .true. + + do j = tile_bdr + 1, tile_ny + tile_bdr, 1 + do i = tile_bdr + 1, tile_nx + tile_bdr, 1 + + call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt) + call mpas_latlon_to_xyz(xPixel, yPixel, zPixel, sphere_radius, lat_pt, lon_pt) + call mpas_kd_search(tree, (/xPixel, yPixel, zPixel/), res, max_distance=max_kdtree_distance2) + + if (.not. associated(res)) cycle + + ! + ! This field only matters for land cells, and for all but the outermost boundary cells, + ! we can safely assume that the nearest model grid cell contains the pixel (else, a different + ! cell would be nearest) + ! + if (landMask(res % id) == 1 .and. bdyMaskCell(res % id) < nBdyLayers) then + do k = 1, tile_nz + if (tile % tile(i, j, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(i,j,k), kind=I8KIND) + end if + lai12m_int(k, res % id) = lai12m_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + + ! For outermost land cells, additional work is needed to verify that the pixel + ! actually lies within the nearest cell + else if (landMask(res % id) == 1) then + if (mpas_in_cell(xPixel, yPixel, zPixel, xCell(res % id), yCell(res % id), zCell(res % id), & + nEdgesOnCell(res % id), verticesOnCell(:,res % id), xVertex, yVertex, zVertex)) then + do k = 1, tile_nz + if (tile % tile(i, j, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(i,j,k), kind=I8KIND) + end if + lai12m_int(k, res % id) = lai12m_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end if + end if + end do + end do + + tile % is_processed = .true. + + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing the tile neighbors of: "//trim(tile%fname), messageType=MPAS_LOG_CRIT) + end if + end if + + end do + end do + + do iCell = 1, nCells + ! For land points that have no overlap with valid data, and for water points, + ! just use the fill value... + if (nhs(iCell) == 0) then + lai12m(:,iCell) = fillval + else + lai12m(:,iCell) = real(real(lai12m_int(:,iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + lai12m(:,iCell) = lai12m(:,iCell) * scalefactor + end if + if (lu_index(iCell) == isice_lu) then + lai12m(:,iCell) = fillval + end if + end do + + deallocate(nhs) + deallocate(lai12m_int) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred when finalizing the interpolation of monthly leaf area index (lai12m)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_log_write('--- end interpolate LAI') + + ! ! Interpolate ALBEDO12M ! @@ -1562,16 +1754,18 @@ end subroutine categorical_interp_accumulation !> that isice and iswater are in the dataset's index file. ! !----------------------------------------------------------------------- - subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) + subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu, ismax_lu, configs) implicit none ! Input variables type (mpas_pool_type), intent(inout) :: mesh type (mpas_kd_type), pointer, intent(in) :: kdtree + type (mpas_pool_type), intent(in) :: configs character (len=*), intent(in) :: geog_data_path integer, intent(out) :: isice_lu integer, intent(out) :: iswater_lu + integer, intent(out) :: ismax_lu ! Local variables type (mpas_geotile_mgr_type) :: mgr @@ -1579,9 +1773,12 @@ subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) integer, pointer :: isice_lu_ptr integer, pointer :: iswater_lu_ptr + logical, pointer :: config_frac_landuse + real (kind=RKIND), pointer :: scalefactor - integer :: iCell + integer :: ncattot + integer :: i, iCell integer :: ierr ierr = mgr % init(trim(geog_data_path)) @@ -1590,28 +1787,52 @@ subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) return ! Program execution should not reach this statement since the preceding message is a critical error end if + call mpas_pool_get_config(configs, 'config_frac_landuse', config_frac_landuse) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_array(mesh, 'lu_index', lu_index) + call mpas_pool_get_array(mesh, 'landusef', landusef) call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) call mpas_pool_get_config(mgr % pool, 'category_min', category_min) call mpas_pool_get_config(mgr % pool, 'category_max', category_max) call mpas_pool_get_config(mgr % pool, 'isice', isice_lu_ptr) call mpas_pool_get_config(mgr % pool, 'iswater', iswater_lu_ptr) + isice_lu = isice_lu_ptr iswater_lu = iswater_lu_ptr + ismax_lu = category_max allocate(ncat(category_min:category_max, nCells)) ncat(:,:) = 0 + landusef(:,:) = 0.0 call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation) - do iCell = 1, nCells - ! Because maxloc returns the location of the maximum value of an array as if the - ! starting index of the array is 1, and dataset categories do not necessarily start - ! at 1, we need to use category_min to ensure the correct category location is chosen. - lu_index(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min - end do + if (.not. config_frac_landuse) then ! compute dominant land use + do iCell = 1, nCells + ! Because maxloc returns the location of the maximum value of an array as if the + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + lu_index(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + landusef(lu_index(iCell),iCell) = 1.0 ! defines dominant land use only + end do + else ! compute fractional land use + do iCell = 1, nCells + ! Note that lu_index currently defines dominant land use only for ivgtyp, where + ! ivgtyp is used by Noah LSM (and PX LSM when landusef=0 everywhere). + lu_index(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + ncattot = 0 + do i = 1,ismax_lu + ncattot = ncattot + ncat(i,iCell) + end do + do i = 1,ismax_lu + if (ncat(i,iCell) > 0) then + landusef(i,iCell) = real(ncat(i,iCell))/ncattot ! defines fractional land use for PX LSM + end if + end do + end do + end if deallocate(ncat) ierr = mgr % finalize() @@ -1625,6 +1846,172 @@ subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) end subroutine interp_landuse + !*********************************************************************** + ! + ! routine interp_landuse2 + ! + !> \brief Interpolate NLCD land use for CONUS + !> \details + !> Interpolate NLCD land use by using the nlcd2011_ll_9s/ dataset. Then + !> overlay the interpolated NLCD data onto CONUS, leaving the previously- + !> interpolated MODIS land use in place over the rest of the globe. + ! + !----------------------------------------------------------------------- + subroutine interp_landuse2(mesh, dims, configs, geog_data_path, isice_lu, iswater_lu, ismax_lu) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs + character (len=*), intent(in) :: geog_data_path + integer, intent(inout) :: isice_lu + integer, intent(inout) :: iswater_lu + integer, intent(inout) :: ismax_lu + + ! Local variables + type (mpas_geotile_mgr_type) :: mgr + character (len=StrKIND) :: fname + character (kind=c_char), dimension(StrKIND+1) :: c_fname + real (kind=c_float), dimension(:,:,:), pointer, contiguous :: rarray + real (kind=RKIND) :: scalefactor + real (kind=RKIND) :: dx, dy + real (kind=RKIND) :: lat_pt, lon_pt + real (kind=RKIND) :: start_lat, start_lon + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + integer, pointer :: nCells, maxEdges + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + integer (c_int) :: endian, isigned, istatus, wordsize + integer (c_int) :: nx, ny, nz + integer:: i,j,k + integer:: iCell,iPoint,iTileStart,iTileEnd,jTileStart,jTileEnd,iEnd,jEnd + type (c_ptr) :: rarray_ptr + + logical, pointer :: config_frac_landuse + + integer :: ncattot + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write("Error occured initalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + call mpas_pool_get_config(configs, 'config_frac_landuse', config_frac_landuse) + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + call mpas_pool_get_array(mesh, 'landusef', landusef) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + + ismax_lu = 40 + iswater_lu = 17 + isice_lu = 15 + nx = 6000 + ny = 3800 + nz = 40 + isigned = 0 + endian = 0 + wordsize = 2 + scalefactor = 0.1 + dx = 0.0025 + dy = 0.0025 + start_lat = 9.00125000 + start_lon = -139.99875000 + jEnd = 19001 + iEnd = 30001 + allocate(rarray(nx,ny,nz)) + allocate(ncat(ismax_lu,nCells)) + ncat(:,:) = 0 + + rarray_ptr = c_loc(rarray) + + do jTileStart = 1,jEnd,ny + jTileEnd = jTileStart + ny - 1 + + do iTileStart = 1,iEnd,nx + iTileEnd = iTileStart + nx - 1 + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path), & + iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus, fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) ! rarray contains fractional % (0-100) land use by category + + iPoint = 1 + do k=1,nz + do j=1,ny + do i=1,nx + ! Check if the NLCD dataset has zeros + if (nint(rarray(i,j,k)) == 0) cycle + + lat_pt = start_lat + (jTileStart + j - 2) * dy + lon_pt = start_lon + (iTileStart + i - 2) * dx + lat_pt = lat_pt * PI / 180.0 + lon_pt = lon_pt * PI / 180.0 + + iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & + nEdgesOnCell,cellsOnCell, & + latCell,lonCell) + ncat(k,iPoint) = ncat(k,iPoint) + 1 + end do + end do + end do + + end do + end do + + if (.not. config_frac_landuse) then ! compute dominant NLCD land use for CONUS + do iCell = 1, nCells + if (maxloc(ncat(:,iCell), dim=1) < 21) cycle ! do not change MODIS land use outside CONUS + ! Because maxloc returns the location of the maximum value of an array as if the + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + lu_index(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + landusef(lu_index(iCell),iCell) = 1.0 ! defines dominant NLCD land use only + end do + else ! compute fractional NLCD land use for CONUS + do iCell = 1, nCells + if (maxloc(ncat(:,iCell), dim=1) < 21) cycle ! do not change MODIS land use outide CONUS + ! Note that lu_index currently defines dominant land use only for ivgtyp, where + ! ivgtyp is used by Noah LSM (and PX LSM when landusef=0 everywhere). + lu_index(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + ncattot = 0 + do i = 1,ismax_lu + ncattot = ncattot + ncat(i,iCell) + end do + do i = 1,ismax_lu + if (ncat(i,iCell) > 0) then + do j = 1,ismax_lu + landusef(j,iCell) = 0.0 ! clear MODIS landusef if NLCD (CONUS) cell + end do + end if + end do + do i = 1,ismax_lu + if (ncat(i,iCell) > 0) then + landusef(i,iCell) = real(ncat(i,iCell))/ncattot ! defines fractional land use for PX LSM + end if + end do + end do + end if + deallocate(rarray) + deallocate(ncat) + + nullify(category_min) + + end subroutine interp_landuse2 + !*********************************************************************** ! ! routine interp_soilcat @@ -1643,13 +2030,14 @@ end subroutine interp_landuse !> iswater is present in the dataset's index file. !> !----------------------------------------------------------------------- - subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) + subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil, configs) implicit none ! Input variables type (mpas_pool_type), intent(inout) :: mesh type (mpas_kd_type), pointer, intent(in) :: kdtree + type (mpas_pool_type), intent(in) :: configs character (len=*), intent(in) :: geog_data_path integer, intent(out) :: iswater_soil @@ -1660,7 +2048,10 @@ subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) real (kind=RKIND), pointer :: scalefactor - integer :: iCell + logical, pointer :: config_frac_landuse + + integer :: ncattot + integer :: i, iCell integer :: ierr ierr = mgr % init(trim(geog_data_path)) @@ -1669,8 +2060,11 @@ subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) return end if + call mpas_pool_get_config(configs, 'config_frac_landuse', config_frac_landuse) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) + call mpas_pool_get_array(mesh, 'soilcat', soilcat) + call mpas_pool_get_array(mesh, 'soiltypf', soiltypf) call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) call mpas_pool_get_config(mgr % pool, 'category_min', category_min) call mpas_pool_get_config(mgr % pool, 'category_max', category_max) @@ -1680,15 +2074,39 @@ subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) allocate(ncat(category_min:category_max, nCells)) ncat(:,:) = 0 + soiltypf(:,:) = 0.0 call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation) - do iCell = 1, nCells - ! Because maxloc returns the location of the maximum value of an array as if the - ! starting index of the array is 1, and dataset categories do not necessarily start - ! at 1, we need to use category_min to ensure the correct category location is chosen. - soilcat_top(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min - end do + if(.not. config_frac_landuse) then ! compute dominant soil type for dominant land use + do iCell = 1, nCells + ! Because maxloc returns the location of the maximum value of an array as if the + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + soilcat(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + soiltypf(soilcat(iCell),iCell) = 1.0 ! defines dominant soil type only + end do + else ! compute fractional soil type for fractional land use + do iCell = 1,nCells + soilcat(iCell) = 1 + do i = 2,16 + if(ncat(i,iCell) > ncat(soilcat(iCell),iCell)) then + soilcat(iCell) = i ! currently defines dominant soil type only for isltyp + end if + end do + end do + do iCell = 1,nCells + ncattot = 0 + do i = 1,16 + ncattot = ncattot + ncat(i,iCell) + end do + do i = 1,16 + if(ncat(i,iCell) > 0) then + soiltypf(i,iCell) = real(ncat(i,iCell))/ncattot ! defines fractional soil type for PX LSM + end if + end do + end do + end if deallocate(ncat) ierr = mgr % finalize() diff --git a/src/core_init_atmosphere/mpas_init_atm_surface.F b/src/core_init_atmosphere/mpas_init_atm_surface.F index 962ccb282c..b9060b1ad1 100644 --- a/src/core_init_atmosphere/mpas_init_atm_surface.F +++ b/src/core_init_atmosphere/mpas_init_atm_surface.F @@ -19,7 +19,7 @@ module mpas_init_atm_surface implicit none private - public :: init_atm_case_sfc, interp_sfc_to_MPAS + public :: init_atm_case_sfc, interp_sfc_to_MPAS, init_atm_case_soilndg, interp_soilndg_to_MPAS contains @@ -276,6 +276,249 @@ subroutine interp_sfc_to_MPAS(timeString, mesh, fg, dims, dminfo, config_sfc_pre end subroutine interp_sfc_to_MPAS +!================================================================================================== + subroutine init_atm_case_soilndg(domain, dminfo, stream_manager, mesh, fg, state, dims, configs) +!================================================================================================== + + use mpas_stream_manager + + implicit none + +!input arguments: + type (domain_type), intent(inout) :: domain + type (dm_info), intent(in) :: dminfo + type (MPAS_streamManager_type), intent(inout) :: stream_manager + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout) :: fg + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs + +!local variables: + type (MPAS_Time_type) :: curr_time, next_time, stop_time + character(len=StrKIND) :: timeStringC, timeStringN, timeStop + + character(len=StrKIND), pointer :: config_sfc_prefix, config_sfc_prefix_hires + character(len=StrKIND), pointer :: xtime + integer :: ierr, count + + +!================================================================================================== + + + call mpas_pool_get_config(configs, 'config_sfc_prefix', config_sfc_prefix) + call mpas_pool_get_config(configs, 'config_sfc_prefix_hires', config_sfc_prefix_hires) + + call mpas_pool_get_array(state, 'xtime', xtime) + +!loop over all times: + curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) + stop_time = mpas_get_clock_time(domain % clock, MPAS_STOP_TIME) + count = 1 + do while (curr_time <= stop_time) + + if(count > 1) then + curr_time = next_time + end if + + call mpas_get_time(curr_time, dateTimeString=timeStringC) + call mpas_get_time(stop_time, dateTimeString=timeStop) + xtime = timeStringC + + call mpas_advance_clock(domain % clock) + next_time = mpas_get_clock_time(domain % clock, MPAS_NOW) + call mpas_get_time(next_time, dateTimeString=timeStringN) + + ! Read the T2, RH2 and SNOW analyses from the surface file, and interpolate the data to the MPAS grid. + ! If hires analysis is specified do blending with coarse analysis. If default of NONE, only interp + ! the main analysis. Note that hires analysis needs to be placed on a global lat-lon grid using wgrib2 + ! + if(trim(config_sfc_prefix_hires) == "NONE") then + call interp_soilndg_to_MPAS(timeStringN(1:13), mesh, fg, dims, dminfo, config_sfc_prefix, 1) + else + call mpas_log_write('Blending hires '//trim(config_sfc_prefix_hires)//' with '//trim(config_sfc_prefix)) + call interp_soilndg_to_MPAS(timeStringN(1:13), mesh, fg, dims, dminfo, config_sfc_prefix_hires, 1) + call interp_soilndg_to_MPAS(timeStringN(1:13), mesh, fg, dims, dminfo, config_sfc_prefix, 0) + endif + + + !write the interpolated T2, RH2 and SNOW analyses in MPAS output file: + call mpas_stream_mgr_write(stream_manager, streamID='soilndg', ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='soilndg', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + + count = count +1 + + end do + + end subroutine init_atm_case_soilndg + +!================================================================================================== + subroutine interp_soilndg_to_MPAS(timeString, mesh, fg, dims, dminfo, config_sfc_prefix, firstpass) +!================================================================================================== + + use mpas_dmpar + + implicit none + +!input arguments: + character(len=*), intent(in) :: timeString + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (dm_info), intent(in) :: dminfo + character(len=*), intent(in) :: config_sfc_prefix + integer, intent(in) :: firstpass + +!inout arguments: + type (mpas_pool_type), intent(inout) :: fg + + +!local variables: + type(met_data) :: field !real*4 meteorological data. + + integer :: istatus + integer :: masked + integer, dimension(5) :: interp_list + integer, dimension(:), pointer :: mask_array + logical :: have_landmask + + real(kind=RKIND) :: fillval, maskval, msgval + real(kind=RKIND), dimension(:,:), allocatable :: maskslab + + integer, dimension(:), pointer :: landmask + real(kind=RKIND), dimension(:), pointer :: destField1d + real(kind=RKIND), dimension(:), pointer :: t2anl, rh2anl, snoanl + + integer, pointer :: nCells + +!================================================================================================== + + call mpas_pool_get_array(mesh, 'landmask', mask_array) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(fg, 't2anl', t2anl) + call mpas_pool_get_array(fg, 'rh2anl', rh2anl) + call mpas_pool_get_array(fg, 'snoanl', snoanl) + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + +!open intermediate file: + call read_met_init(trim(config_sfc_prefix),.false.,timeString,istatus) + if(istatus /= 0) then + call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Error opening surface file '//trim(config_sfc_prefix)//':'//timeString(1:13), messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_CRIT) + else + call mpas_log_write('Processing file '//trim(config_sfc_prefix)//':'//timeString(1:13)) + end if + +!scan through all fields in the file, looking for the LANDSEA field: + have_landmask = .false. + call read_next_met_field(field,istatus) + do while (istatus == 0) + if(index(field % field, 'LANDSEA') /= 0) then + have_landmask = .true. + if(.not.allocated(maskslab)) allocate(maskslab(-2:field % nx+3, field % ny)) + maskslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny) + maskslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny) + maskslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny) + maskslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny) + maskslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny) + maskslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny) + maskslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny) +! write(0,*) 'minval, maxval of LANDSEA = ', minval(maskslab), maxval(maskslab) + end if + deallocate(field % slab) + call read_next_met_field(field,istatus) + end do + call read_met_close() + +!read sea-surface temperatures and seaice data. open intermediate file: + call read_met_init(trim(config_sfc_prefix),.false.,timeString(1:13),istatus) + if(istatus /= 0) then + call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Error opening surface file '//trim(config_sfc_prefix)//':'//timeString(1:13), messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_CRIT) + end if + +!scan through all fields in the file, looking for the T2, RH2 and SNOWH + call read_next_met_field(field,istatus) + do while (istatus == 0) + + if(index(field % field, 'T2') /= 0) then + call mpas_log_write('... Processing T2:') + if(firstpass == 1) then + t2anl(1:nCells) = 0.0_RKIND + end if + destField1d => t2anl + + !interpolation to the MPAS grid: + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = SEARCH + interp_list(4) = N_NEIGHBOR + msgval = -1.0e30_R4KIND !missing value + masked = 1 + maskval = 1.0_RKIND + fillval = 0.0_RKIND + call interp_to_MPAS2(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + mask_array) + deallocate(field%slab) + + ! 2-m Rel. Hum. (RH2 in Ungrib file) + else if(index(field % field, 'RH2') /= 0) then + call mpas_log_write('... Processing RH2:') + if(firstpass == 1) then + rh2anl(1:nCells) = 0.0_RKIND + end if + destField1d => rh2anl + + !interpolation to the MPAS grid: + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = SEARCH + interp_list(4) = N_NEIGHBOR + msgval = -1.0e30_R4KIND !missing value + masked = 1 + maskval = 1.0_RKIND + fillval = 0.0_RKIND + call interp_to_MPAS2(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + mask_array) + deallocate(field%slab) + + ! Snow water (SNOW in Ungrib file) + else if(index(field % field, 'SNOW') /= 0) then + call mpas_log_write('... Processing SNOW:') + if(firstpass == 1) then + snoanl(1:nCells) = 0.0_RKIND + end if + destField1d => snoanl + + !interpolation to the MPAS grid: + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = SEARCH + interp_list(4) = N_NEIGHBOR + msgval = -1.0e30_R4KIND !missing value + masked = 1 + maskval = 1.0_RKIND + fillval = 0.0_RKIND + call interp_to_MPAS2(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + mask_array) + deallocate(field%slab) + + else + deallocate(field%slab) + + end if + + call read_next_met_field(field,istatus) + end do + +!close intermediate file: + call read_met_close() + if(allocated(maskslab)) deallocate(maskslab) + + end subroutine interp_soilndg_to_MPAS + !================================================================================================== subroutine interp_to_MPAS(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & mask_array,maskslab) @@ -384,6 +627,122 @@ subroutine interp_to_MPAS(mesh,nCells,field,destField1d,interp_list,msgval,maske end subroutine interp_to_MPAS +!================================================================================================== + subroutine interp_to_MPAS2(mesh,nCells,field,destField1d,interp_list,msgval,masked,maskval,fillval, & + mask_array,maskslab) +!================================================================================================== + +!input arguments: + type (mpas_pool_type), intent(in) :: mesh + integer, intent(in) :: nCells + type (met_data), intent(in) :: field !real*4 meteorological data. + + integer, intent(in) :: masked + integer, dimension(5), intent(in) :: interp_list + integer, dimension(:), intent(in), pointer :: mask_array + + real(kind=RKIND), intent(in) :: fillval, maskval, msgval + real(kind=RKIND), intent(in), dimension(*), optional :: maskslab + +!inout arguments: + real(kind=RKIND), intent(inout), dimension(:), pointer :: destField1d + +!local variables: + type(proj_info) :: proj + integer :: i, nInterpPoints + real(kind=RKIND) :: lat,lon,x,y, tmpfield + real(kind=RKIND), dimension(:,:), allocatable :: rslab + + real(kind=RKIND), dimension(:), pointer :: latPoints, lonPoints + real(kind=RKIND), dimension(:), pointer :: latCell, lonCell + +!-------------------------------------------------------------------------------------------------- + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + + call map_init(proj) + if(field % iproj == PROJ_LATLON) then + call map_set(PROJ_LATLON, proj, & + latinc = real(field % deltalat,RKIND), & + loninc = real(field % deltalon,RKIND), & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) +! write(0,*) '--- The projection is PROJ_LATLON.' + else if(field % iproj == PROJ_GAUSS) then + call map_set(PROJ_GAUSS, proj, & + nlat = nint(field % deltalat), & + loninc = 360.0_RKIND / real(field % nx,RKIND), & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) +! write(0,*) '--- The projection is PROJ_GAUSS.' + else if(field % iproj == PROJ_PS) then + call map_set(PROJ_PS, proj, & + dx = real(field % dx,RKIND), & + truelat1 = real(field % truelat1,RKIND), & + stdlon = real(field % xlonc,RKIND), & + knowni = real(field % nx / 2.0,RKIND), & + knownj = real(field % ny / 2.0,RKIND), & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) +! write(0,*) '--- The projection is PROJ_PS.' + end if + + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + + allocate(rslab(-2:field % nx+3, field % ny)) + rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny) + rslab( 0, 1:field % ny) = field % slab(field % nx , 1:field % ny) + rslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny) + rslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny) + rslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny) + rslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny) + rslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny) + + do i = 1,nInterpPoints + if(mask_array(i) /= masked) then + lat = latPoints(i) * DEG_PER_RAD + lon = lonPoints(i) * DEG_PER_RAD + call latlon_to_ij(proj, lat, lon, x, y) + if(y <= 0.5) then + y = 1.0 + else if(y >= real(field%ny)+0.5) then + y = real(field % ny) + end if + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if (x >= real(field%nx)+0.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + + if(present(maskslab)) then + if(destField1d(i) == 0.0 .or. destField1d(i) > 999999999999 ) then + destField1d(i) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1, & + msgval,interp_list,4,maskval=maskval,mask_array=maskslab) + else + endif + else + if(destField1d(i) == 0.0 .or. destField1d(i) > 999999999999 ) then + destField1d(i) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1, & + msgval,interp_list,4,maskval=maskval) + else + endif + end if + else + destField1d(i) = fillval + end if + + end do + deallocate(rslab) + + end subroutine interp_to_MPAS2 + !================================================================================================== end module mpas_init_atm_surface !==================================================================================================