From 1c8c372ce6140980e176c54a0b5c5b59b274842d Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Mon, 7 Feb 2022 14:15:08 -0700 Subject: [PATCH 01/25] Correct mismatch in minimum slope limit. Setting both back to 1e-5. (#592) --- trunk/NDHMS/Routing/module_HYDRO_io.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/trunk/NDHMS/Routing/module_HYDRO_io.F b/trunk/NDHMS/Routing/module_HYDRO_io.F index 8db9ee721..8a0b3f937 100644 --- a/trunk/NDHMS/Routing/module_HYDRO_io.F +++ b/trunk/NDHMS/Routing/module_HYDRO_io.F @@ -9007,8 +9007,8 @@ subroutine read_route_link_netcdf( route_link_file, & call get_1d_netcdf_real(ncid, 'Length', CHANLEN, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'n', MannN, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'So', So, 'read_route_link_netcdf', .TRUE.) -!! impose a minimum as this sometimes fails in the file. LKR changed to 10^-4 on 2/2018. -where(So .lt. 0.0001) So=0.00001 +!! impose a minimum as this sometimes fails in the file. +where(So .lt. 0.00001) So=0.00001 call get_1d_netcdf_real(ncid, 'ChSlp', ChSSlp, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'BtmWdth', Bw, 'read_route_link_netcdf', .TRUE.) !! Loads channel infiltration, by default is zero, my need to add namelist option in future From 00eed487afa63566bd582c6364159307e4066ec8 Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Mon, 7 Feb 2022 15:02:34 -0700 Subject: [PATCH 02/25] Channel NaN fixes for Muskingum-Cunge (#599) Add checks to prevent divide-by-zero --- trunk/NDHMS/Routing/module_channel_routing.F | 22 ++++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/trunk/NDHMS/Routing/module_channel_routing.F b/trunk/NDHMS/Routing/module_channel_routing.F index 6f7725ac7..8ebf788de 100644 --- a/trunk/NDHMS/Routing/module_channel_routing.F +++ b/trunk/NDHMS/Routing/module_channel_routing.F @@ -266,7 +266,7 @@ subroutine SUBMUSKINGCUNGE( & Twl = Bw + 2.0*z*h_0 !--top surface water width of the channel inflow - if(h_0 .gt. bfd) then !water outside of defined channel + if ( (h_0 .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) ) then !water outside of defined channel AREA = (Bw + bfd * z) * bfd AREAC = (TwCC * (h_0 -bfd)) !assume compound component is rect. chan, that's 3 times the Tw WP = (Bw + 2.0 * bfd * sqrt(1.0 + z*z)) @@ -285,7 +285,7 @@ subroutine SUBMUSKINGCUNGE( & endif - if(h_0 .gt. bfd) then !water outside of defined channel + if ( (h_0 .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) ) then !water outside of defined channel !weight the celerity by the contributing area, and assume that the mannings !of the spills is 2x the manning of the channel Ck = max(0.0,((sqrt(So)/n)*((5./3.)*R**(2./3.) - & @@ -306,7 +306,8 @@ subroutine SUBMUSKINGCUNGE( & Km = dt endif - if(h_0 .gt. bfd) then !water outside of defined channel + if ( (h_0 .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) .and. (Ck .gt. 0.0) ) then + !water outside of defined channel X = min(0.5,max(0.0,0.5*(1-(Qj_0/(2.0*TwCC*So*Ck*dx))))) else if(Ck .gt. 0.0) then @@ -322,7 +323,6 @@ subroutine SUBMUSKINGCUNGE( & call hydro_stop("In MUSKINGCUNGE() - D is 0.") endif - C1 = (Km*X + dt/2.000000)/D C2 = (dt/2.0000 - Km*X)/D C3 = (Km*(1.00000000-X)-dt/2.000000)/D @@ -344,14 +344,13 @@ subroutine SUBMUSKINGCUNGE( & endif ! WPk = WP*MIN((h/(modK*SQRT(Bw))),1.0) ! KINEROS2 Mod. This shouldn't be HERE. - !--upper interval ----------- WPC = 0.0 AREAC = 0.0 Twl = Bw + 2.0*z*h !--top width of the channel inflow - if(h .gt. bfd) then !water outside of defined channel + if ( (h .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) ) then !water outside of defined channel AREA = (Bw + bfd * z) * bfd AREAC = (TwCC * (h-bfd)) !assume compound component is rect. chan, that's 3 times the Tw WP = (Bw + 2.0 * bfd * sqrt(1.0 + z*z)) @@ -370,7 +369,8 @@ subroutine SUBMUSKINGCUNGE( & endif endif - if(h .gt. bfd) then !water outside of defined channel, assumed rectangular, 3x TW and n = 3x + if ( (h .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) ) then + !water outside of defined channel, assumed rectangular, 3x TW and n = 3x Ck = max(0.0,((sqrt(So)/n)*((5./3.)*R**(2./3.) - & ((2./3.)*R**(5./3.)*(2.0*sqrt(1.0 + z*z)/(Bw + 2.0*bfd*z))))*AREA & + ((sqrt(So)/(nCC))*(5./3.)*(h-bfd)**(2./3.))*AREAC)/(AREA+AREAC)) @@ -382,22 +382,22 @@ subroutine SUBMUSKINGCUNGE( & Ck = 0.0 endif endif + if(Ck .gt. 0.0) then Km = max(dt,dx/Ck) else Km = dt endif - if(h .gt. bfd) then !water outside of defined channel - X = min(0.5,max(0.25,0.5*(1-(((C1*qup)+(C2*quc)+(C3*qdp) + C4)/(2.0*TwCC*So*Ck*dx))))) + if ( (h .gt. bfd) .and. (TwCC .gt. 0.0) .and. (nCC .gt. 0.0) .and. (Ck .gt. 0.0) ) then + !water outside of defined channel + X = min(0.5,max(0.25,0.5*(1-(((C1*qup)+(C2*quc)+(C3*qdp) + C4)/(2.0*TwCC*So*Ck*dx))))) else - if(Ck .gt. 0.0) then X = min(0.5,max(0.25,0.5*(1-(((C1*qup)+(C2*quc)+(C3*qdp) + C4)/(2.0*Twl*So*Ck*dx))))) else X = 0.5 endif - endif D = (Km*(1 - X) + dt/2) !--seconds From 459c86e4f97756744fe4bf36f4557d28fd8301fb Mon Sep 17 00:00:00 2001 From: Ryan Cabell Date: Wed, 9 Feb 2022 12:17:43 -0700 Subject: [PATCH 03/25] Update WRF coupler to recent MPP_LAND_INIT changes (#602) * duplicate WRF's MPI communicator to HYDRO_COMM_WORLD * call MPP_LAND_INIT with global grid size from WRF `domain` object --- trunk/NDHMS/CPL/WRF_cpl/module_wrf_HYDRO.F | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/trunk/NDHMS/CPL/WRF_cpl/module_wrf_HYDRO.F b/trunk/NDHMS/CPL/WRF_cpl/module_wrf_HYDRO.F index ec83338f5..9c88bfc4b 100644 --- a/trunk/NDHMS/CPL/WRF_cpl/module_wrf_HYDRO.F +++ b/trunk/NDHMS/CPL/WRF_cpl/module_wrf_HYDRO.F @@ -22,10 +22,11 @@ module module_WRF_HYDRO #ifdef MPP_LAND + use mpi use module_mpp_land, only: global_nx, global_ny, decompose_data_real, & write_io_real, my_id, mpp_land_bcast_real1, IO_id, & mpp_land_bcast_real, mpp_land_bcast_int1, mpp_land_init - use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate + use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate, HYDRO_COMM_WORLD use module_hydro_stop, only: HYDRO_stop #endif use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe @@ -77,6 +78,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) integer :: i,j + integer :: ierr !output flux and state variable @@ -98,15 +100,15 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) if(.not. RT_DOMAIN(did)%initialized) then - - call MPP_LAND_INIT() - !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels nlst(did)%nsoil = grid%num_soil_layers #ifdef MPP_LAND + call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + call MPP_LAND_INIT(grid%e_we - grid%s_we - 1, grid%e_sn - grid%s_sn - 1) + call mpp_land_bcast_int1 (nlst(did)%nsoil) #endif allocate(nlst(did)%zsoil8(nlst(did)%nsoil)) From 2dbe34f82214cc24bd6a9e8284f5faf35268fe08 Mon Sep 17 00:00:00 2001 From: Dan Date: Fri, 11 Feb 2022 16:56:31 -0700 Subject: [PATCH 04/25] Update NUOPC cap exchange fields (#600) * Move fields utilities to WRFHydro_NUOPC_Fields.F90 * Add 3 dimensional soil fields smc, slc, stc * Remove fields that aren't connected * Update LSM forcings check * Update NUOPC cap fill values * Add options for memory copy or pointer * Add options to initialize with prescribed values * Add options to check for missing values * Add options to fill missing values with prescribed values * Cleanup field creation and fill * Cleanup ESMF extension utilities * Update error flags * Set field timestamp to invalid for coldstarts * Add WRFHYDRO model state debugging * Fix WRFHYDRO NUOPC cap installation dependencies --- trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt | 2 + trunk/NDHMS/CPL/NUOPC_cpl/Makefile | 15 +- .../NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 | 1803 ----------------- .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 | 775 +++---- .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 | 1479 ++++++++++++++ .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 | 305 +++ .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 | 443 +--- .../CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h | 2 +- 8 files changed, 2269 insertions(+), 2555 deletions(-) create mode 100644 trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 create mode 100644 trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt b/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt index 381b5e928..95816d970 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt +++ b/trunk/NDHMS/CPL/NUOPC_cpl/CMakeLists.txt @@ -9,6 +9,8 @@ endif (NOT TARGET esmf) list(APPEND wrfhydro_nuopc_files WRFHydro_NUOPC_Cap.F90 WRFHydro_NUOPC_Gluecode.F90 + WRFHydro_NUOPC_Fields.F90 + WRFHydro_NUOPC_Flags.F90 WRFHydro_ESMF_Extensions.F90 ) diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/Makefile b/trunk/NDHMS/CPL/NUOPC_cpl/Makefile index 656499206..78aa70f80 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/Makefile +++ b/trunk/NDHMS/CPL/NUOPC_cpl/Makefile @@ -108,10 +108,14 @@ CAP_MK := wrfhydro.mk CAP_OBJS := WRFHydro_NUOPC_Cap.o CAP_OBJS += WRFHydro_NUOPC_Gluecode.o +CAP_OBJS += WRFHydro_NUOPC_Fields.o +CAP_OBJS += WRFHydro_NUOPC_Flags.o CAP_OBJS += WRFHydro_ESMF_Extensions.o CAP_MODS := wrfhydro_nuopc.mod CAP_MODS += wrfhydro_nuopc_gluecode.mod +CAP_MODS += wrfhydro_nuopc_fields.mod +CAP_MODS += wrfhydro_nuopc_flags.mod CAP_MODS += wrfhydro_esmf_extensions.mod CAP_FILES := $(CAP_OBJS) $(CAP_MODS) $(CAP_LIB) $(CAP_VERS) $(CAP_MK) @@ -143,12 +147,19 @@ nuopcinstall: $(CAP_LIB) $(CAP_MODS) $(CAP_VERS) \ # ############ WRFHydro_NUOPC_Cap.o: WRFHydro_NUOPC_Macros.h \ - WRFHydro_NUOPC_Gluecode.o WRFHydro_ESMF_Extensions.o + WRFHydro_NUOPC_Gluecode.o WRFHydro_NUOPC_Fields.o \ + WRFHydro_NUOPC_Flags.o WRFHydro_ESMF_Extensions.o WRFHydro_NUOPC_Gluecode.o: WRFHydro_NUOPC_Macros.h \ + WRFHydro_NUOPC_Fields.o WRFHydro_NUOPC_Flags.o \ WRFHydro_ESMF_Extensions.o $(MODEL_MODS) +WRFHydro_NUOPC_Fields.o: WRFHydro_NUOPC_Macros.h \ + WRFHydro_NUOPC_Flags.o WRFHydro_ESMF_Extensions.o \ + $(MODEL_MODS) wrfhydro_nuopc.mod: WRFHydro_NUOPC_Cap.o wrfhydro_nuopc_gluecode.mod: WRFHydro_NUOPC_Gluecode.o +wrfhydro_nuopc_fields.mod: WRFHydro_NUOPC_Fields.o +wrfhydro_nuopc_flags.mod: WRFHydro_NUOPC_Flags.o wrfhydro_esmf_extensions.mod: WRFHydro_ESMF_Extensions.o # ############### @@ -253,7 +264,7 @@ $(CAP_MK): # Install Library, Modules, and Makefile Fragment # ----------------------------------------------------------------------------- -$(INSTPATH)/%: +$(INSTPATH)/%: % @echo $(HR) @echo "Installing $(notdir $@)" @echo diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 index c9a830cd9..831bd24b3 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_ESMF_Extensions.F90 @@ -41,11 +41,6 @@ module WRFHydro_ESMF_Extensions public :: WRFHYDRO_ESMF_MAPPRESET_CONUS public :: WRFHYDRO_ESMF_MAPPRESET_IRENE public :: WRFHYDRO_ESMF_MAPPRESET_FRONTRANGE - public :: WRFHYDRO_ESMF_FieldFill - public :: WRFHYDRO_ESMF_FillField - public :: WRFHYDRO_ESMF_FillArray - public :: WRFHYDRO_ESMF_FillFieldBundle - public :: WRFHYDRO_ESMF_FillState public :: WRFHYDRO_ESMF_NetcdfReadIXJX public :: WRFHYDRO_ESMF_NetcdfIsPresent public :: WRFHYDRO_ESMF_LogStateList @@ -85,36 +80,6 @@ module WRFHydro_ESMF_Extensions module procedure WRFHYDRO_ESMF_FerretScriptWrite_default end interface - interface WRFHYDRO_ESMF_FillState - module procedure WRFHYDRO_ESMF_FillState_I4 - module procedure WRFHYDRO_ESMF_FillState_I8 - module procedure WRFHYDRO_ESMF_FillState_R4 - module procedure WRFHYDRO_ESMF_FillState_R8 - module procedure WRFHYDRO_ESMF_FillState_SCHEME - end interface - - interface WRFHYDRO_ESMF_FillFieldBundle - module procedure WRFHYDRO_ESMF_FillFieldBundle_I4 - module procedure WRFHYDRO_ESMF_FillFieldBundle_I8 - module procedure WRFHYDRO_ESMF_FillFieldBundle_R4 - module procedure WRFHYDRO_ESMF_FillFieldBundle_R8 - module procedure WRFHYDRO_ESMF_FillFieldBundle_SCHEME - end interface - - interface WRFHYDRO_ESMF_FillField - module procedure WRFHYDRO_ESMF_FillField_I4 - module procedure WRFHYDRO_ESMF_FillField_I8 - module procedure WRFHYDRO_ESMF_FillField_R4 - module procedure WRFHYDRO_ESMF_FillField_R8 - end interface - - interface WRFHYDRO_ESMF_FillArray - module procedure WRFHYDRO_ESMF_FillArray_I4 - module procedure WRFHYDRO_ESMF_FillArray_I8 - module procedure WRFHYDRO_ESMF_FillArray_R4 - module procedure WRFHYDRO_ESMF_FillArray_R8 - end interface - interface WRFHYDRO_ESMF_NetcdfReadIXJX module procedure WRFHYDRO_ESMF_NetcdfReadIXJX_Field module procedure WRFHYDRO_ESMF_NetcdfReadIXJX_Array @@ -1241,1774 +1206,6 @@ subroutine WRFHYDRO_ESMF_FerretScriptWrite_default(varName, dataFile, gridFile, !----------------------------------------------------------------------------- -#define METHOD "WRFHYDRO_ESMF_FieldFill" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FieldFill - Fill data into a Field -! !INTERFACE: - subroutine WRFHYDRO_ESMF_FieldFill(field, keywordEnforcer, & - dataFillScheme, member, step, amplitude, meanValue, rc) -! !ARGUMENTS: - type(ESMF_Field), intent(inout) :: field -type(ESMF_KeywordEnforcer), optional:: keywordEnforcer ! must use keywords below - character(len=*), intent(in), optional :: dataFillScheme - integer, intent(in), optional :: member - integer, intent(in), optional :: step - real, intent(in), optional :: amplitude - real, intent(in), optional :: meanValue - integer, intent(out), optional :: rc -! !DESCRIPTION: -! Fill {\tt field} with data according to {\tt dataFillScheme}. Depending -! on the chosen fill scheme, the {\tt member} and {\tt step} arguments are -! used to provide differing fill data patterns. -! -! The arguments are: -! \begin{description} -! \item[field] -! The {\tt ESMF\_Field} object to fill with data. -! \item[{[dataFillScheme]}] -! The fill scheme. The available options are "sincos", and "one". -! Defaults to "sincos". -! \item[{[member]}] -! Member incrementor. Defaults to 1. -! \item[{[step]}] -! Step incrementor. Defaults to 1. -! \item[{[amplitude]}] -! Magnitude of change. Defaults to 1. -! \item[{[meanValue]}] -! Mean value. Defaults to 0. -! \item[{[rc]}] -! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Grid) :: grid - type(ESMF_TypeKind_Flag) :: typekind - type(ESMF_TypeKind_Flag) :: coordTypeKind - integer :: rank - integer, allocatable :: coordDimCount(:) - real(ESMF_KIND_R8), pointer :: dataPtrR8D1(:) - real(ESMF_KIND_R8), pointer :: dataPtrR8D2(:,:) - real(ESMF_KIND_R8), pointer :: dataPtrR8D3(:,:,:) - real(ESMF_KIND_R4), pointer :: dataPtrR4D1(:) - real(ESMF_KIND_R4), pointer :: dataPtrR4D2(:,:) - real(ESMF_KIND_R4), pointer :: dataPtrR4D3(:,:,:) - real(ESMF_KIND_R8), pointer :: coord1PtrR8D1(:) - real(ESMF_KIND_R8), pointer :: coord2PtrR8D1(:) - real(ESMF_KIND_R8), pointer :: coord1PtrR8D2(:,:) - real(ESMF_KIND_R8), pointer :: coord2PtrR8D2(:,:) - real(ESMF_KIND_R8), pointer :: coord1PtrR8D3(:,:,:) - real(ESMF_KIND_R8), pointer :: coord2PtrR8D3(:,:,:) - real(ESMF_KIND_R8), pointer :: coord3PtrR8D3(:,:,:) - real(ESMF_KIND_R4), pointer :: coord1PtrR4D1(:) - real(ESMF_KIND_R4), pointer :: coord2PtrR4D1(:) - real(ESMF_KIND_R4), pointer :: coord1PtrR4D2(:,:) - real(ESMF_KIND_R4), pointer :: coord2PtrR4D2(:,:) - real(ESMF_KIND_R4), pointer :: coord1PtrR4D3(:,:,:) - real(ESMF_KIND_R4), pointer :: coord2PtrR4D3(:,:,:) - real(ESMF_KIND_R4), pointer :: coord3PtrR4D3(:,:,:) - integer :: i, j, k - - integer :: l_member, l_step - real :: l_amplitude, l_meanValue - character(len=16) :: l_dataFillScheme - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field, typekind=typekind, rank=rank, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - l_member = 1 - if(present(member)) l_member = member - l_step = 1 - if(present(step)) l_step = step - l_dataFillScheme = "sincos" - if(present(dataFillScheme)) l_dataFillScheme = dataFillScheme - l_amplitude = 1.0 - if(present(amplitude)) l_amplitude = amplitude - l_meanValue = 0.0 - if(present(meanValue)) l_meanValue = meanValue - - allocate(coordDimCount(rank)) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of coordinate dimensions memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - if (trim(l_dataFillScheme)=="sincos") then - call ESMF_FieldGet(field, grid=grid, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call ESMF_GridGet(grid,coordTypeKind=coordTypeKind, & - coordDimCount=coordDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (rank==1) then - ! 1D sin pattern - ! TODO: support Meshes - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do i=lbound(dataPtrR4D1,1),ubound(dataPtrR4D1,1) - dataPtrR4D1(i) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - elseif (typekind==ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do i=lbound(dataPtrR8D1,1),ubound(dataPtrR8D1,1) - dataPtrR8D1(i) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - elseif (rank==2) then - ! 2D sin*cos pattern - ! TODO: support Meshes - if (coordTypeKind==ESMF_TYPEKIND_R4) then - if (coordDimCount(1)==1) then - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - if (coordDimCount(2)==1) then - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - if (coordDimCount(1)==1) then - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - if (coordDimCount(2)==1) then - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - else - ! assume the only other choice here is 2D, if not will trigger error - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported coordinate typekind.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - - if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (coordDimCount(1)==1 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==2 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==1 .and. coordDimCount(2)==2) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else - ! only choice left is both 2d coordinate arrays - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR4D2,2),ubound(dataPtrR4D2,2) - do i=lbound(dataPtrR4D2,1),ubound(dataPtrR4D2,1) - dataPtrR4D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - endif - elseif (typekind==ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (coordDimCount(1)==1 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==2 .and. coordDimCount(2)==1) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D1(j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else if (coordDimCount(1)==1 .and. coordDimCount(2)==2) then - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D1(i)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - else - ! only choice left is both 2d coordinate arrays - if (coordTypeKind==ESMF_TYPEKIND_R4) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR4D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR4D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - elseif (coordTypeKind==ESMF_TYPEKIND_R8) then - do j=lbound(dataPtrR8D2,2),ubound(dataPtrR8D2,2) - do i=lbound(dataPtrR8D2,1),ubound(dataPtrR8D2,1) - dataPtrR8D2(i,j) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D2(i,j)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D2(i,j)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - endif - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - elseif (rank==3) then - ! 3D sin*cos*sin pattern - ! TODO: support Meshes - call ESMF_GridGetCoord(grid, coordDim=1, farrayPtr=coord1PtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call ESMF_GridGetCoord(grid, coordDim=2, farrayPtr=coord2PtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) & - return ! bail out - call ESMF_GridGetCoord(grid, coordDim=3, farrayPtr=coord3PtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - if (typekind==ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do k=lbound(dataPtrR4D3,3),ubound(dataPtrR4D3,3) - do j=lbound(dataPtrR4D3,2),ubound(dataPtrR4D3,2) - do i=lbound(dataPtrR4D3,1),ubound(dataPtrR4D3,1) - dataPtrR4D3(i,j,k) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D3(i,j,k)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D3(i,j,k)+real(l_step))/180.) * & - sin(real(l_member)*3.1416*(coord3PtrR8D3(i,j,k)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - enddo - elseif (typekind==ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - do k=lbound(dataPtrR8D3,3),ubound(dataPtrR8D3,3) - do j=lbound(dataPtrR8D3,2),ubound(dataPtrR8D3,2) - do i=lbound(dataPtrR8D3,1),ubound(dataPtrR8D3,1) - dataPtrR8D3(i,j,k) = & - (sin(real(l_member)*3.1416*(coord1PtrR8D3(i,j,k)+real(l_step))/180.) * & - cos(real(l_member)*3.1416*(coord2PtrR8D3(i,j,k)+real(l_step))/180.) * & - sin(real(l_member)*3.1416*(coord3PtrR8D3(i,j,k)+real(l_step))/180.)) * & - l_amplitude+l_meanValue - enddo - enddo - enddo - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unsupported typekind-rank and scheme combination requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - else if (trim(dataFillScheme)=="one") then - if (typekind==ESMF_TYPEKIND_R8 .and. rank==1) then - ! 1D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR8D1 = 1._ESMF_KIND_R8 - elseif (typekind==ESMF_TYPEKIND_R4 .and. rank==1) then - ! 1D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D1, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR4D1 = 1._ESMF_KIND_R4 - elseif (typekind==ESMF_TYPEKIND_R8 .and. rank==2) then - ! 2D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR8D2 = 1._ESMF_KIND_R8 - elseif (typekind==ESMF_TYPEKIND_R4 .and. rank==2) then - ! 2D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D2, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR4D2 = 1._ESMF_KIND_R4 - elseif (typekind==ESMF_TYPEKIND_R8 .and. rank==3) then - ! 3D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR8D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR8D3 = 1._ESMF_KIND_R8 - elseif (typekind==ESMF_TYPEKIND_R4 .and. rank==3) then - ! 3D all 1. - call ESMF_FieldGet(field, farrayPtr=dataPtrR4D3, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - ! initialize the entire array - dataPtrR4D3 = 1._ESMF_KIND_R4 - endif - else - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg="Unknown dataFillScheme requested.", & - CONTEXT, rcToReturn=rc) - return ! bail out - endif - - deallocate(coordDimCount,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of coordinate dimensions memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - -!------------------------------------------------------------------------------ - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_I4 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_I4(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_I8 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_I8(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_R4 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_R4(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_R8 - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_R8(state,value,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call WRFHYDRO_ESMF_FillField(field,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillState" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillState_SCHEME - Fill data into State -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillState - subroutine WRFHYDRO_ESMF_FillState_SCHEME(state,dataFillScheme,step,rc) -! ! ARGUMENTS - type(ESMF_State), intent(in) :: state - character(len=*), intent(in) :: dataFillScheme - integer, intent(in), optional :: step - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_State. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: k - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_StateGet(state,itemCount=itemCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(itemNameList(itemCount), itemTypeList(itemCount), stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_StateGet(state,itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - k=1 ! initialize - do iIndex = 1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - call ESMF_FieldFill(field, dataFillScheme=dataFillScheme, & - member=k, step=step, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - k=k+1 ! increment the member counter - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_I4 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_I4(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_I8 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_I8(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_R4 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_R4(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_R8 - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_R8(fieldbundle,value,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call WRFHYDRO_ESMF_FillField(fieldList(fIndex),value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillFieldBundle" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillFieldBundle_SCHEME - Fill data into FieldBundle -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillFieldBundle - subroutine WRFHYDRO_ESMF_FillFieldBundle_SCHEME(fieldbundle,dataFillScheme,step,rc) -! ! ARGUMENTS - type(ESMF_FieldBundle), intent(in) :: fieldbundle - character(len=*), intent(in) :: dataFillScheme - integer, intent(in), optional :: step - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_FieldBundle. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer :: fIndex - integer :: fieldCount - type(ESMF_Field),pointer :: fieldList(:) - integer :: stat - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldBundleGet(fieldbundle, & - fieldCount=fieldCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - allocate(fieldList(fieldCount),stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - call ESMF_FieldBundleGet(fieldbundle, & - fieldList=fieldList, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - do fIndex=1,fieldCount - call ESMF_FieldFill(fieldList(fIndex), dataFillScheme=dataFillScheme, & - member=fIndex, step=step, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - enddo - - deallocate(fieldList,stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of field lists failed.", & - CONTEXT, rcToReturn=rc)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_I4 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_I4(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_I8 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_I8(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_R4 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_R4(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillField" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillField_R8 - Fill data into Field -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillField - subroutine WRFHYDRO_ESMF_FillField_R8(field,value,rc) -! ! ARGUMENTS - type(ESMF_Field), intent(in) :: field - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Field. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - type(ESMF_Array) :: array - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_FieldGet(field,array=array,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - call WRFHYDRO_ESMF_FillArray(array,value=value,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_I4 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_I4(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - integer(ESMF_KIND_I4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_I8 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_I8(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - integer(ESMF_KIND_I8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_R4 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_R4(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - real(ESMF_KIND_R4),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - -#define METHOD "WRFHYDRO_ESMF_FillArray" -!BOP -! !IROUTINE: WRFHYDRO_ESMF_FillArray_R8 - Fill data into Array -! !INTERFACE: - ! call using generic interface: WRFHYDRO_ESMF_FillArray - subroutine WRFHYDRO_ESMF_FillArray_R8(array,value,rc) -! ! ARGUMENTS - type(ESMF_Array), intent(in) :: array - real(ESMF_KIND_R8),intent(in) :: value - integer, intent(out),optional :: rc -! !DESCRIPTION: -! Fill data into ESMF_Array. -! -! The arguments are: -! \begin{description} -! \end{description} -! -!EOP - !----------------------------------------------------------------------------- - ! local variables - integer(ESMF_KIND_I4),pointer :: farray_I41D(:) - integer(ESMF_KIND_I4),pointer :: farray_I42D(:,:) - integer(ESMF_KIND_I4),pointer :: farray_I43D(:,:,:) - integer(ESMF_KIND_I8),pointer :: farray_I81D(:) - integer(ESMF_KIND_I8),pointer :: farray_I82D(:,:) - integer(ESMF_KIND_I8),pointer :: farray_I83D(:,:,:) - real(ESMF_KIND_R4),pointer :: farray_R41D(:) - real(ESMF_KIND_R4),pointer :: farray_R42D(:,:) - real(ESMF_KIND_R4),pointer :: farray_R43D(:,:,:) - real(ESMF_KIND_R8),pointer :: farray_R81D(:) - real(ESMF_KIND_R8),pointer :: farray_R82D(:,:) - real(ESMF_KIND_R8),pointer :: farray_R83D(:,:,:) - type(ESMF_TypeKind_Flag) :: typekind - integer :: rank - integer :: localDeCount - integer :: deIndex - - if (present(rc)) rc = ESMF_SUCCESS - - call ESMF_ArrayGet(array,typekind=typekind,rank=rank,localDeCount=localDeCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - - if (rank == 1) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I81D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R41D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R41D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R81D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R81D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 2) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I82D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R42D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R42D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R82D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R82D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - elseif (rank == 3) then - if (typekind == ESMF_TYPEKIND_I4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_I8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_I83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_I83D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R4) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R43D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R43D = value - enddo - elseif (typekind == ESMF_TYPEKIND_R8) then - do deIndex=0,localDeCount-1 - call ESMF_ArrayGet(array,farrayPtr=farray_R83D,localDe=deIndex,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, PASSTHRU)) return ! bail out - farray_R83D = value - enddo - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because typekind is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - else - call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_RANK, & - msg="Cannot fill ESMF Array because rank is not supported", & - CONTEXT, rcToReturn=rc) - return - endif - - end subroutine -#undef METHOD - - !----------------------------------------------------------------------------- - #define METHOD "WRFHYDRO_ESMF_NetcdfIsPresent" !BOP ! !IROUTINE: WRFHYDRO_ESMF_NetcdfIsPresent - Check NetCDF file for varname diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 index 6727b6596..e18ddff01 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Cap.F90 @@ -239,6 +239,8 @@ module WRFHydro_NUOPC model_label_Advance => label_Advance, & model_label_Finalize => label_Finalize use WRFHYDRO_NUOPC_Gluecode + use WRFHYDRO_NUOPC_Fields + use WRFHYDRO_NUOPC_Flags use WRFHydro_ESMF_Extensions implicit none @@ -250,6 +252,7 @@ module WRFHydro_NUOPC CHARACTER(LEN=*), PARAMETER :: label_InternalState = 'InternalState' type type_InternalStateStruct + logical :: realizeAllImport = .FALSE. logical :: realizeAllExport = .FALSE. character(len=64) :: configFile = 'hydro.namelist' character(len=64) :: dasConfigFile = 'namelist.hrldas' @@ -257,20 +260,24 @@ module WRFHydro_NUOPC character(len=128) :: forcingDir = 'WRFHYDRO_FORCING' integer :: did = 1 logical :: nestToNest = .FALSE. - logical :: importDependency = .FALSE. - character(len=128) :: dirOutput = "." - character(len=128) :: dirInput = "." + type(memory_flag) :: memr_import = MEMORY_POINTER + type(memory_flag) :: memr_export = MEMORY_POINTER + type(fillv_flag) :: init_import = FILLV_MODEL + type(fillv_flag) :: init_export = FILLV_MODEL + type(checkclock_flag) :: chck_import = CHECKCLOCK_CURRT + type(missingval_flag) :: misg_import = MISSINGVAL_FAIL + logical :: reset_import = .FALSE. + character(len=128) :: dirOutput = "./HYD_OUTPUT" + character(len=128) :: dirInput = "./HYD_INPUT" logical :: writeRestart = .FALSE. - logical :: readRestart = .FALSE. logical :: multiInstance = .FALSE. character :: hgrid = '0' integer :: nnests = 1 - integer :: nfields = size(WRFHYDRO_FieldList) type (ESMF_Clock) :: clock(1) type (ESMF_TimeInterval) :: stepTimer(1) type(ESMF_State) :: NStateImp(1) type(ESMF_State) :: NStateExp(1) - integer :: mode(1) = WRFHYDRO_Unknown + logical :: lsm_forcings(1) = .FALSE. endtype type type_InternalState @@ -415,8 +422,10 @@ subroutine WRFHydro_AttributeGet(rc) logical :: configIsPresent type(ESMF_Config) :: config type(NUOPC_FreeFormat) :: attrFF + character(32) :: atName + logical :: atPres + character(32) :: atVal character(ESMF_MAXSTR) :: logMsg - character(len=64) :: modeStr ! check gcomp for config call ESMF_GridCompGet(gcomp, configIsPresent=configIsPresent, rc=rc) @@ -435,101 +444,238 @@ subroutine WRFHydro_AttributeGet(rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif + ! Realize all import fields + atName="realize_all_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%realizeAllImport = (trim(atVal)=="TRUE") + endif + ! Realize all export fields - call ESMF_AttributeGet(gcomp, name="realize_all_export", value=value, & - defaultValue="false", convention="NUOPC", purpose="Instance", rc=rc) + atName="realize_all_export" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%realizeAllExport = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%realizeAllExport = (trim(atVal)=="TRUE") + endif ! Determine hydro configuration filename - call ESMF_AttributeGet(gcomp, name="config_file", value=value, & - defaultValue="hydro.namelist", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="config_file" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%configFile = value + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%configFile = atVal + endif ! Determine DAS configuration filename - call ESMF_AttributeGet(gcomp, name="das_config_file", value=value, & - defaultValue="namelist.hrldas", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="das_config_file" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%dasConfigFile = value + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%dasConfigFile = atVal + endif ! Time Step - call ESMF_AttributeGet(gcomp, name="time_step", value=value, defaultValue="0", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="time_step" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - read (value,*,iostat=stat) is%wrap%timeStepInt - if (stat /= 0) then - call ESMF_LogSetError(ESMF_FAILURE, & - msg="Cannot convert "//trim(value)//" to integer.", & - line=__LINE__,file=__FILE__,rcToReturn=rc) - return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + read (atVal,*,iostat=stat) is%wrap%timeStepInt + if (stat /= 0) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Cannot convert "//trim(atVal)//" to integer.", & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + endif endif ! Forcing Directory - call ESMF_AttributeGet(gcomp, name="forcings_directory", value=value, & - defaultValue=is%wrap%forcingDir, & - convention="NUOPC", purpose="Instance", rc=rc) + atName="forcings_directory" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%forcingDir = trim(value) + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%forcingDir = trim(atVal) + endif ! Determine Domain ID - call ESMF_AttributeGet(gcomp, name="did", value=value, & - defaultValue="1", & - convention="NUOPC", purpose="Instance", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%did = ESMF_UtilString2Int(value, rc=rc) + atName="did" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%did = ESMF_UtilString2Int(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif ! Connect Nest to Nest - call ESMF_AttributeGet(gcomp, name="nest_to_nest", value=value, & - defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="nest_to_nest" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%nestToNest = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%nestToNest = (trim(atVal)=="TRUE") + endif - ! Determine Import Dependency - call ESMF_AttributeGet(gcomp, name="import_dependency", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + ! import data memory type + atName="field_memory_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%memr_import = atVal + endif + + ! export data memory type + atName="field_memory_export" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%memr_export = atVal + endif + + ! import data initialization type + atName="initialize_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%init_import = atVal + endif + + ! backwards compatible setting (overrides initialize_import) + atName="import_dependency" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%importDependency = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (trim(atVal)=="TRUE") is%wrap%init_import = FILLV_DEPENDENCY + endif + + ! export data initialization type + atName="initialize_export" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%init_export = atVal + endif + + ! backwards compatible setting (overrides initialize_export) + atName="read_restart" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (trim(atVal)=="TRUE") is%wrap%init_export = FILLV_FILE + endif + + ! Get check import + atName="check_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%chck_import = atVal + endif + + ! Get missing import handler + atName="missing_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%misg_import = atVal + endif + + ! Get reset import handler + atName="reset_import" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%reset_import = (trim(atVal)=="TRUE") + endif ! Get component output directory - call ESMF_AttributeGet(gcomp, name="output_directory", & - value=value, defaultValue=trim(cname)//"_OUTPUT", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="output_directory" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%dirOutput = trim(value) + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%dirOutput = trim(atVal) + endif ! Get component input directory - call ESMF_AttributeGet(gcomp, name="input_directory", & - value=value, defaultValue=trim(cname)//"_INPUT", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="input_directory" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%dirInput = trim(value) + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%dirInput = trim(atVal) + endif ! Write cap restart state - call ESMF_AttributeGet(gcomp, name="write_restart", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="write_restart" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%writeRestart = (trim(value)=="true") - - ! Read cap restart state - call ESMF_AttributeGet(gcomp, name="read_restart", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%readRestart = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%writeRestart = (trim(atVal)=="TRUE") + endif ! Determine Import Dependency - call ESMF_AttributeGet(gcomp, name="multi_instance_hyd", & - value=value, defaultValue="false", & - convention="NUOPC", purpose="Instance", rc=rc) + atName="multi_instance_hyd" + call NUOPC_CompAttributeGet(gcomp, name=atName, isPresent=atPres, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%multiInstance = (trim(value)=="true") + if (atPres) then + call NUOPC_CompAttributeGet(gcomp, name=atName, value=atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + atVal = ESMF_UtilStringUpperCase(atVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + is%wrap%multiInstance = (trim(atVal)=="TRUE") + endif if (btest(verbosity,16)) then call ESMF_LogWrite(trim(cname)//": Settings",ESMF_LOGMSG_INFO) @@ -539,6 +685,9 @@ subroutine WRFHydro_AttributeGet(rc) write (logMsg, "(A,(A,I0))") trim(cname)//": ", & "Diagnostic = ",diagnostic call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + write (logMsg, "(A,(A,L1))") trim(cname)//": ", & + "Realze All Imports = ",is%wrap%realizeAllImport + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,L1))") trim(cname)//": ", & "Realze All Exports = ",is%wrap%realizeAllExport call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) @@ -560,8 +709,32 @@ subroutine WRFHydro_AttributeGet(rc) write (logMsg, "(A,(A,L1))") trim(cname)//": ", & "Nest To Nest = ",is%wrap%nestToNest call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%memr_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Field Memory Import = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%memr_export + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Field Memory Export = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%init_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Initialize Import = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%init_export + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Initialize Export = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%chck_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Check Imports = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) + atVal = is%wrap%misg_import + write (logMsg, "(A,(A,A))") trim(cname)//": ", & + "Missing Imports = ",trim(atVal) + call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,L1))") trim(cname)//': ', & - "Import Dependency = ",is%wrap%importDependency + "Reset Import = ",is%wrap%reset_import call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,A))") trim(cname)//": ", & "Output Directory = ",trim(is%wrap%dirOutput) @@ -572,9 +745,6 @@ subroutine WRFHydro_AttributeGet(rc) write (logMsg, "(A,(A,L1))") trim(cname)//': ', & "Write Restart = ",is%wrap%writeRestart call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) - write (logMsg, "(A,(A,L1))") trim(cname)//': ', & - "Read Restart = ",is%wrap%readRestart - call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) write (logMsg, "(A,(A,L1))") trim(cname)//': ', & "Multiple Instances = ",is%wrap%multiInstance call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) @@ -658,83 +828,19 @@ subroutine InitializeP1(gcomp, importState, exportState, clock, rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif - call WRFHYDRO_FieldDictionaryAdd(rc=rc) + call field_dictionary_add(fieldList=cap_fld_list, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out !! !! advertise import and export fields !! - do fIndex = 1, size(WRFHYDRO_FieldList) - if (WRFHYDRO_FieldList(fIndex)%adImport) then - call NUOPC_Advertise(is%wrap%NStateImp(1), & - standardName=trim(WRFHYDRO_FieldList(fIndex)%stdname), & - name=trim(WRFHYDRO_FieldList(fIndex)%stateName), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - if (WRFHYDRO_FieldList(fIndex)%adExport) then - call NUOPC_Advertise(is%wrap%NStateExp(1), & - standardName=trim(WRFHYDRO_FieldList(fIndex)%stdname), & - name=trim(WRFHYDRO_FieldList(fIndex)%stateName), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - enddo - - if (btest(verbosity,16)) call LogAdvertised() - - contains ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine LogAdvertised() - ! local variables - integer :: cntImp - integer :: cntExp - integer :: fIndex - character(ESMF_MAXSTR) :: logMsg - - ! Count advertised import and export fields - cntImp = 0 - cntExp = 0 - do fIndex = 1, size(WRFHydro_FieldList) - if (WRFHydro_FieldList(fIndex)%adImport) cntImp = cntImp + 1 - if (WRFHydro_FieldList(fIndex)%adExport) cntExp = cntExp + 1 - enddo - - ! Report advertised import fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of advertised import fields(',cntImp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntImp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%adImport) cycle - cntImp = cntImp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntImp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) - enddo - - ! Report advertised export fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of advertised export fields(',cntExp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntExp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%adExport) cycle - cntExp = cntExp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntExp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) - enddo + call field_advertise(fieldList=cap_fld_list, & + importState=is%wrap%NStateImp(1), & + exportState=is%wrap%NStateExp(1), & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out - end subroutine + if (btest(verbosity,16)) call field_advertise_log(cap_fld_list,cname,rc=rc) end subroutine @@ -805,128 +911,25 @@ subroutine InitializeP3(gcomp, importState, exportState, clock, rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif - do fIndex = 1, size(WRFHYDRO_FieldList) - if (WRFHYDRO_FieldList(fIndex)%adImport) then - importConnected = NUOPC_IsConnected(is%wrap%NStateImp(1), & - fieldName=WRFHYDRO_FieldList(fIndex)%stateName, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - else - importConnected = .FALSE. - endif - - if (importConnected) then - WRFHYDRO_FieldList(fIndex)%realizedImport = .TRUE. - field = WRFHYDRO_FieldCreate(stateName=WRFHYDRO_FieldList(fIndex)%stateName, & - grid=WRFHYDRO_grid, & - did=is%wrap%did, & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - call NUOPC_Realize(is%wrap%NStateImp(1), field=field, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - elseif(WRFHYDRO_FieldList(fIndex)%adImport) then - call ESMF_StateRemove(is%wrap%NStateImp(1), (/trim(WRFHYDRO_FieldList(fIndex)%stateName)/), & - relaxedflag=.true.,rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - endif - - if (WRFHYDRO_FieldList(fIndex)%adExport) then - if (is%wrap%realizeAllExport) then - exportConnected = .TRUE. - else - exportConnected = NUOPC_IsConnected(is%wrap%NStateExp(1), & - fieldName=WRFHYDRO_FieldList(fIndex)%stateName, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - else - exportConnected = .FALSE. - endif - - if (exportConnected) then - WRFHYDRO_FieldList(fIndex)%realizedExport = .TRUE. - field = WRFHYDRO_FieldCreate(stateName=WRFHYDRO_FieldList(fIndex)%stateName, & - grid=WRFHYDRO_grid, & - did=is%wrap%did, & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - call NUOPC_Realize(is%wrap%NStateExp(1), field=field,rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - elseif(WRFHYDRO_FieldList(fIndex)%adExport) then - call ESMF_StateRemove(is%wrap%NStateExp(1),(/trim(WRFHYDRO_FieldList(fIndex)%stateName)/), & - relaxedflag=.true.,rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - endif - - ! TODO: Initialize the value in the pointer to 0 after proper restart is setup - !if(associated(WRFHYDRO_FieldList(fIndex)%farrayPtr) ) WRFHYDRO_FieldList(fIndex)%farrayPtr = 0.0 - ! remove a not connected Field from State - - enddo - -! Model has initialized its own field memory so don't fill state. -! call NUOPC_FillState(is%wrap%NStateImp(1),0,rc=rc) -! if (ESMF_STDERRORCHECK(rc)) return -! call NUOPC_FillState(is%wrap%NStateExp(1),0,rc=rc) -! if (ESMF_STDERRORCHECK(rc)) return + call field_realize(fieldList=cap_fld_list, & + importState=is%wrap%NStateImp(1), & + exportState=is%wrap%NStateExp(1), & + grid=WRFHYDRO_grid, did=is%wrap%did, & + realizeAllImport=is%wrap%realizeAllImport, & + realizeAllExport=is%wrap%realizeAllExport, & + memr_import=is%wrap%memr_import, & + memr_export=is%wrap%memr_export, & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out - is%wrap%mode(1) = WRFHYDRO_RunModeGet(is%wrap%NStateImp(1),rc) + is%wrap%lsm_forcings(1) = check_lsm_forcings(is%wrap%NStateImp(1),rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - if (btest(verbosity,16)) call LogRealized() + if (btest(verbosity,16)) call field_realize_log(cap_fld_list,cname,rc=rc) if (btest(verbosity,16)) call LogMode() contains ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine LogRealized() - ! local variables - integer :: cntImp - integer :: cntExp - integer :: fIndex - character(ESMF_MAXSTR) :: logMsg - - ! Count advertised import and export fields - cntImp = 0 - cntExp = 0 - do fIndex = 1, size(WRFHydro_FieldList) - if (WRFHydro_FieldList(fIndex)%realizedImport) cntImp = cntImp + 1 - if (WRFHydro_FieldList(fIndex)%realizedExport) cntExp = cntExp + 1 - enddo - - ! Report realized import fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of realized import fields(',cntImp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntImp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%realizedImport) cycle - cntImp = cntImp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntImp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) - enddo - - ! Report realized export fields - write(logMsg,'(a,a,i0,a)') TRIM(cname)//': ', & - 'List of realized export fields(',cntExp,'):' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - write(logMsg,'(a,a5,a,a16,a,a)') TRIM(cname)//': ', & - 'index',' ','name',' ','standardName' - call ESMF_LogWrite(TRIM(logMsg), ESMF_LOGMSG_INFO) - cntExp = 0 - do fIndex=1, size(WRFHydro_FieldList) - if (.NOT.WRFHydro_FieldList(fIndex)%realizedExport) cycle - cntExp = cntExp + 1 - write(logMsg,'(a,i5,a,a16,a,a)') TRIM(cname)//': ', & - cntExp,' ',TRIM(WRFHydro_FieldList(fIndex)%stateName), & - ' ',TRIM(WRFHydro_FieldList(fIndex)%stdName) - call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) - enddo - - end subroutine - !--------------------------------------------------------------------------- subroutine LogMode() @@ -934,16 +937,11 @@ subroutine LogMode() character(ESMF_MAXSTR) :: logMsg character(len=64) :: modeStr - select case(is%wrap%mode(1)) - case (WRFHYDRO_Offline) - modeStr ="WRFHYDRO_Offline" - case (WRFHYDRO_Coupled) - modeStr = "WRFHYDRO_Coupled" - case (WRFHYDRO_Hybrid) - modeStr = "WRFHYDRO_Hybrid" - case default - modeStr = "WRFHYDRO_Unknown" - end select + if(is%wrap%lsm_forcings(1)) then + modeStr = "WRFHYDRO_Coupled" + else + modeStr = "WRFHYDRO_Offline" + endif write (logMsg, "(A,(A,A))") trim(cname)//": ", & "Mode = ",trim(modeStr) call ESMF_LogWrite(trim(logMsg),ESMF_LOGMSG_INFO) @@ -966,16 +964,15 @@ subroutine DataInitialize(gcomp, rc) type(type_InternalState) :: is type(ESMF_Clock) :: modelClock type(ESMF_Time) :: currTime + type(ESMF_Time) :: invalidTime character(len=32) :: currTimeStr character(len=9) :: nStr - integer :: iIndex - integer :: itemCount - character(len=64),allocatable :: itemNameList(:) - type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - type(ESMF_Field) :: field - integer :: stat logical :: importCurrent logical :: importUpdated + logical :: exportUpdated + character(len=32) :: initTypeStr + logical :: mdlRestart + integer :: stat rc = ESMF_SUCCESS @@ -1008,89 +1005,141 @@ subroutine DataInitialize(gcomp, rc) call NUOPC_ModelGet(gcomp, modelClock=modelClock, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out + ! set up invalid time (by convention) + call ESMF_TimeSet(invalidTime, yy=99999999, mm=01, dd=01, & + h=00, m=00, s=00, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + ! get the current time out of the clock call ESMF_ClockGet(modelClock, currTime=currTime, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out call ESMF_TimeGet(currTime, timeString=currTimeStr, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - ! Initialize import and export fields - ! No initialization. Fields remain set to initial value - - importUpdated = .TRUE. write (nStr,"(I0)") is%wrap%did - if (is%wrap%importDependency) then + ! initialize import state + if (is%wrap%init_import.eq.FILLV_MISSING) then + call state_fill_uniform(is%wrap%NStateImp(1), & + fillValue=ESMF_MISSING_VALUE, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_ZERO) then + call state_fill_uniform(is%wrap%NStateImp(1), & + fillValue=0.0_ESMF_KIND_R8, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_DEPENDENCY) then importCurrent = NUOPC_IsAtTime(is%wrap%NStateImp(1), & time=currTime, rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out - if (importCurrent) then call ESMF_LogWrite( & trim(cname)//': '//rname//' Initialize-Data-Dependency SATISFIED!!! Nest='//trim(nStr), & ESMF_LOGMSG_INFO) + importUpdated = .TRUE. else call ESMF_LogWrite( & trim(cname)//': '//rname//' Initialize-Data-Dependency NOT YET SATISFIED!!! Nest='//trim(nStr), & ESMF_LOGMSG_INFO) importUpdated = .FALSE. endif + elseif (is%wrap%init_import.eq.FILLV_PRESCRIBE) then + call state_fill_prescribe(is%wrap%NStateImp(1), & + fieldList=cap_fld_list, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_FILE) then + call state_fill_file(is%wrap%NStateImp(1), & + filePrefix=trim(is%wrap%dirInput)//"/restart_"//trim(cname)// & + "_imp_D"//trim(nStr)//"_"//trim(currTimeStr), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + importUpdated = .TRUE. + elseif (is%wrap%init_import.eq.FILLV_MODEL) then + if (is%wrap%memr_import.eq.MEMORY_COPY) then + call state_copy_frhyd(is%wrap%NStateImp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + call WRFHYDRO_get_restart(is%wrap%did, restart=mdlRestart, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (mdlRestart) then + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + else + call NUOPC_SetTimestamp(is%wrap%NStateImp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + importUpdated = .TRUE. + else + initTypeStr = is%wrap%init_import + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Import data initialize routine unknown "//trim(initTypeStr), & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + importUpdated = .FALSE. endif - if (is%wrap%readRestart) then - call ESMF_StateGet(is%wrap%NStateExp(1),itemCount=itemCount, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - - allocate( & - itemNameList(itemCount), & - itemTypeList(itemCount), & - stat=stat) - if (ESMF_LogFoundAllocError(statusToCheck=stat, & - msg="Allocation of state item list memory failed.", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_StateGet(is%wrap%NStateExp(1),itemNameList=itemNameList, & - itemTypeList=itemTypeList,rc=rc) + ! initialize export state + if (is%wrap%init_export.eq.FILLV_MISSING) then + call state_fill_uniform(is%wrap%NStateExp(1), & + fillValue=ESMF_MISSING_VALUE, rc=rc) if (ESMF_STDERRORCHECK(rc)) return - - do iIndex=1, itemCount - if ( itemTypeList(iIndex) == ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(is%wrap%NStateExp(1),field=field, & - itemName=itemNameList(iIndex),rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - call ESMF_AttributeGet(field, name="StandardName", & - value=value, convention="NUOPC", purpose="Instance", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - call ESMF_FieldRead(field, & - fileName=trim(is%wrap%dirInput)//"/restart_"//trim(cname)// & - "_exp_D"//trim(nStr)//"_"//trim(currTimeStr)//"_"// & - trim(itemNameList(iIndex))//".nc", & - variableName=value, iofmt=ESMF_IOFMT_NETCDF, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) - if (ESMF_STDERRORCHECK(rc)) return ! bail out - endif - enddo - - deallocate(itemNameList, itemTypeList, stat=stat) - if (ESMF_LogFoundDeallocError(statusToCheck=stat, & - msg="Deallocation of state item list memory failed.", & - line=__LINE__, & - file=__FILE__)) & - return ! bail out - - call ESMF_LogWrite( & - trim(cname)//': '//rname//' Read cap restart complete! Nest='//trim(nStr), & - ESMF_LOGMSG_INFO) - is%wrap%readRestart = .FALSE. - - endif ! readRestart + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_ZERO) then + call state_fill_uniform(is%wrap%NStateExp(1), & + fillValue=0.0_ESMF_KIND_R8, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_PRESCRIBE) then + call state_fill_prescribe(is%wrap%NStateExp(1), & + fieldList=cap_fld_list, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_FILE) then + call state_fill_file(is%wrap%NStateExp(1), & + filePrefix=trim(is%wrap%dirInput)//"/restart_"//trim(cname)// & + "_exp_D"//trim(nStr)//"_"//trim(currTimeStr), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + exportUpdated = .TRUE. + elseif (is%wrap%init_export.eq.FILLV_MODEL) then + if (is%wrap%memr_export.eq.MEMORY_COPY) then + call state_copy_frhyd(is%wrap%NStateExp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + call WRFHYDRO_get_restart(is%wrap%did, restart=mdlRestart, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (mdlRestart) then + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=currTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + else + call NUOPC_SetTimestamp(is%wrap%NStateExp(1), time=invalidTime, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + exportUpdated = .TRUE. + else + initTypeStr = is%wrap%init_export + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Export data initialize routine unknown "//trim(initTypeStr), & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + exportUpdated = .FALSE. + endif ! set InitializeDataComplete Attribute to "true", indicating to the ! generic code that all inter-model data dependencies are satisfied - if (importUpdated) then + if (importUpdated.AND.exportUpdated) then call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out ! Write initialization files @@ -1108,8 +1157,6 @@ subroutine DataInitialize(gcomp, rc) endif endif -! if (btest(verbosity,16)) call WRFHydro_FieldListLog(label=cname) - end subroutine !----------------------------------------------------------------------------- @@ -1313,6 +1360,7 @@ subroutine ModelAdvance(gcomp, rc) character(len=32) :: currTimeStr, advEndTimeStr type(ESMF_TimeInterval) :: timeStep character(len=9) :: nStr + character(len=16) :: misgValTypeStr rc = ESMF_SUCCESS @@ -1370,6 +1418,36 @@ subroutine ModelAdvance(gcomp, rc) if (ESMF_STDERRORCHECK(rc)) return ! bail out endif + if (is%wrap%memr_import.eq.MEMORY_COPY) then + call state_copy_tohyd(is%wrap%NStateImp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + + if (is%wrap%misg_import.eq.MISSINGVAL_FAIL) then + call state_check_missing(is%wrap%NStateImp(1), did=is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + elseif (is%wrap%misg_import.eq.MISSINGVAL_PRESCRIBE) then + call state_prescribe_missing(is%wrap%NStateImp(1), did=is%wrap%did, & + fieldList=cap_fld_list, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + elseif (is%wrap%misg_import.eq.MISSINGVAL_IGNORE) then +! DO NOTHING + else + misgValTypeStr = is%wrap%misg_import + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Unknown missing value handler "//trim(misgValTypeStr), & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + endif + + if (btest(diagnostic,16)) then + call model_debug(is%wrap%NStateImp(1), did=is%wrap%did, & + memflg=is%wrap%memr_import, & + filePrefix=trim(is%wrap%dirOutput)//"/wrfhydro_"// & + rname//"_imp_D"//trim(nStr)//"_"//trim(currTimeStr)//"_", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + is%wrap%stepTimer(1) = is%wrap%stepTimer(1) + timeStep call ESMF_ClockGet(is%wrap%clock(1),timeStep=timestep,rc=rc) @@ -1380,7 +1458,7 @@ subroutine ModelAdvance(gcomp, rc) if (btest(verbosity,16)) then call LogAdvance(nIndex=1,nStr=nStr) endif - call wrfhydro_nuopc_run(is%wrap%did,is%wrap%mode(1), & + call wrfhydro_nuopc_run(is%wrap%did,is%wrap%lsm_forcings(1), & is%wrap%clock(1),is%wrap%NStateImp(1),is%wrap%NStateExp(1),rc) if(ESMF_STDERRORCHECK(rc)) return ! bail out call ESMF_ClockAdvance(is%wrap%clock(1),rc=rc) @@ -1389,6 +1467,25 @@ subroutine ModelAdvance(gcomp, rc) is%wrap%stepTimer(1) - timestep enddo + if (is%wrap%memr_export.eq.MEMORY_COPY) then + call state_copy_frhyd(is%wrap%NStateExp(1), is%wrap%did, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + + if (is%wrap%reset_import) then + if ((is%wrap%memr_import.eq.MEMORY_POINTER) .AND. & + (is%wrap%memr_export.eq.MEMORY_POINTER)) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Cannot reset import field if pointer is shared with export.", & + line=__LINE__,file=__FILE__,rcToReturn=rc) + return ! bail out + else + call state_fill_uniform(is%wrap%NStateImp(1), & + fillValue=ESMF_MISSING_VALUE, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + endif + endif + ! Write export files if (btest(diagnostic,16)) then call NUOPC_Write(is%wrap%NStateExp(1), & @@ -1414,16 +1511,12 @@ subroutine LogAdvance(nIndex,nStr) call ESMF_LogWrite(trim(cname)//': '//rname//& ' Advancing Nest='//trim(nStr),ESMF_LOGMSG_INFO) - select case(is%wrap%mode(nIndex)) - case (WRFHYDRO_Offline) - nModeStr ="WRFHYDRO_Offline" - case (WRFHYDRO_Coupled) + if (is%wrap%lsm_forcings(nIndex)) then nModeStr = "WRFHYDRO_Coupled" - case (WRFHYDRO_Hybrid) - nModeStr = "WRFHYDRO_Hybrid" - case default - nModeStr = "WRFHYDRO_Unknown" - end select + else + nModeStr = "WRFHYDRO_Offline" + endif + write (logMsg, "(A,(A,A,A),(A,A))") trim(cname)//': ', & 'Nest(',trim(nStr),') ', & 'Mode = ',trim(nModeStr) diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 new file mode 100644 index 000000000..af433d45d --- /dev/null +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Fields.F90 @@ -0,0 +1,1479 @@ +#define FILENAME "WRFHydro_NUOPC_Fields.F90" +#define MODNAME "wrfhydro_nuopc_fields" +#include "WRFHydro_NUOPC_Macros.h" + +module wrfhydro_nuopc_fields +! !MODULE: wrfhydro_nuopc_fields +! +! !DESCRIPTION: +! This module connects NUOPC field information for WRFHYDRO +! +! !REVISION HISTORY: +! 21Jul23 Dan Rosen Initial Specification +! +! !USES: + use ESMF + use NUOPC + use WRFHydro_ESMF_Extensions + use WRFHydro_NUOPC_Flags + use config_base, only: nlst + use module_rt_data, only: rt_domain + use overland_data, only: overland_struct + use overland_control, only: overland_control_struct + + implicit none + + private + + type cap_fld_type + sequence + character(len=64) :: sd_name = "dummy" ! standard name + character(len=64) :: st_name = "dummy" ! state name + character(len=64) :: units = "-" ! units + logical :: ad_import = .FALSE. ! advertise import + logical :: ad_export = .FALSE. ! advertise export + real(ESMF_KIND_R8) :: vl_fillv = ESMF_MISSING_VALUE ! default + logical :: rl_import = .FALSE. ! realize import + logical :: rl_export = .FALSE. ! realize export + end type cap_fld_type + + type(cap_fld_type),target,dimension(20) :: cap_fld_list = (/ & + cap_fld_type("inst_total_soil_moisture_content ","smc ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("inst_soil_moisture_content ","slc ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("inst_soil_temperature ","stc ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_1","sh2ox1 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_2","sh2ox2 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_3","sh2ox3 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("liquid_fraction_of_soil_moisture_layer_4","sh2ox4 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_1 ","smc1 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_2 ","smc2 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_3 ","smc3 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_moisture_fraction_layer_4 ","smc4 ", & + "m3 m-3",.TRUE. ,.TRUE. ,0.20d0), & + cap_fld_type("soil_temperature_layer_1 ","stc1 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_temperature_layer_2 ","stc2 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_temperature_layer_3 ","stc3 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_temperature_layer_4 ","stc4 ", & + "K ",.TRUE. ,.FALSE.,288.d0), & + cap_fld_type("soil_porosity ","smcmax1 ", & + "1 ",.FALSE.,.FALSE.,0.45d0), & + cap_fld_type("vegetation_type ","vegtyp ", & + "1 ",.FALSE.,.FALSE.,16.0d0), & + cap_fld_type("surface_water_depth ","sfchead ", & + "mm ",.FALSE.,.TRUE. ,0.00d0), & + cap_fld_type("time_step_infiltration_excess ","infxsrt ", & + "mm ",.TRUE. ,.FALSE.,0.00d0), & + cap_fld_type("soil_column_drainage ","soldrain", & + "mm ",.TRUE. ,.FALSE.,0.00d0) & + /) + + public cap_fld_list + public field_dictionary_add + public field_create + public field_realize + public field_advertise + public check_lsm_forcings + public field_advertise_log + public field_realize_log + public read_impexp_config_flnm + public field_find_standardname + public field_find_statename + public state_fill_uniform + public state_fill_prescribe + public state_fill_file + public state_copy_tohyd + public state_copy_frhyd + public state_check_missing + public state_prescribe_missing + public model_debug + + !----------------------------------------------------------------------------- + contains + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_dictionary_add" + subroutine field_dictionary_add(fieldList, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + integer, intent(out) :: rc + ! local variables + integer :: n + logical :: isPresent + + rc = ESMF_SUCCESS + + do n=lbound(fieldList,1),ubound(fieldList,1) + isPresent = NUOPC_FieldDictionaryHasEntry( & + fieldList(n)%sd_name, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (.not.isPresent) then + call NUOPC_FieldDictionaryAddEntry( & + StandardName=trim(fieldList(n)%sd_name), & + canonicalUnits=trim(fieldList(n)%units), & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + end do + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_realize" + subroutine field_realize(fieldList, importState, exportState, grid, & + did, realizeAllImport, realizeAllExport, memr_import, memr_export, rc) + type(cap_fld_type), intent(inout) :: fieldList(:) + type(ESMF_State), intent(inout) :: importState + type(ESMF_State), intent(inout) :: exportState + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: did + logical, intent(in) :: realizeAllImport + logical, intent(in) :: realizeAllExport + type(memory_flag) :: memr_import + type(memory_flag) :: memr_export + integer, intent(out) :: rc + ! local variables + integer :: n + logical :: realizeImport + logical :: realizeExport + type(ESMF_Field) :: field_import + type(ESMF_Field) :: field_export + + rc = ESMF_SUCCESS + + do n=lbound(fieldList,1),ubound(fieldList,1) + ! check realize import + if (fieldList(n)%ad_import) then + if (realizeAllImport) then + realizeImport = .true. + else + realizeImport = NUOPC_IsConnected(importState, & + fieldName=trim(fieldList(n)%st_name),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + else + realizeImport = .false. + end if + ! create import field + if ( realizeImport ) then + field_import=field_create(fld_name=fieldList(n)%st_name, & + grid=grid, did=did, memflg=memr_import, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call NUOPC_Realize(importState, field=field_import, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_import = .true. + else + call ESMF_StateRemove(importState, (/fieldList(n)%st_name/), & + relaxedflag=.true., rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_import = .false. + end if + + ! check realize export + if (fieldList(n)%ad_export) then + if (realizeAllExport) then + realizeExport = .true. + else + realizeExport = NUOPC_IsConnected(exportState, & + fieldName=trim(fieldList(n)%st_name),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + else + realizeExport = .false. + end if + ! create export field + if( realizeExport ) then + field_export=field_create(fld_name=fieldList(n)%st_name, & + grid=grid, did=did, memflg=memr_export, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call NUOPC_Realize(exportState, field=field_export, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_export = .true. + else + call ESMF_StateRemove(exportState, (/fieldList(n)%st_name/), & + relaxedflag=.true., rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(n)%rl_export = .false. + end if + end do + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "lsm_forcings" + + function check_lsm_forcings(importState,rc) + ! RETURN + logical :: check_lsm_forcings + ! ARGUMENTS + type(ESMF_State), intent(in) :: importState + integer, intent(out) :: rc + ! LOCAL VARIABLES + integer :: fieldIndex + type(ESMF_StateItem_Flag) :: itemType + integer :: s_smc, s_smc1, s_smc2, s_smc3, s_smc4 + integer :: s_slc, s_slc1, s_slc2, s_slc3, s_slc4 + integer :: s_stc, s_stc1, s_stc2, s_stc3, s_stc4 + integer :: s_infxsrt + integer :: s_soldrain + logical :: c_smc + logical :: c_slc + logical :: c_stc + logical :: c_infxsrt + logical :: c_soldrain + + ! total soil moisture content + call ESMF_StateGet(importState,itemSearch="smc", itemCount=s_smc, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc1",itemCount=s_smc1,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc2",itemCount=s_smc2,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc3",itemCount=s_smc3,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="smc4",itemCount=s_smc4,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_smc.gt.0) then + c_smc = NUOPC_IsConnected(importState, fieldName="smc") + elseif ((s_smc1.gt.0) .and. (s_smc2.gt.0) .and. & + (s_smc3.gt.0) .and. (s_smc4.gt.0)) then + c_smc = (NUOPC_IsConnected(importState, fieldName="smc1") .and. & + NUOPC_IsConnected(importState, fieldName="smc2") .and. & + NUOPC_IsConnected(importState, fieldName="smc3") .and. & + NUOPC_IsConnected(importState, fieldName="smc4")) + else + c_smc = .false. + endif + + ! liquid soil moisture content + call ESMF_StateGet(importState,itemSearch="slc", itemCount=s_slc, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox1",itemCount=s_slc1,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox2",itemCount=s_slc2,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox3",itemCount=s_slc3,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="sh2ox4",itemCount=s_slc4,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_slc.gt.0) then + c_slc = NUOPC_IsConnected(importState, fieldName="slc") + elseif ((s_slc1.gt.0) .and. (s_slc2.gt.0) .and. & + (s_slc3.gt.0) .and. (s_slc4.gt.0)) then + c_slc = (NUOPC_IsConnected(importState, fieldName="sh2ox1") .and. & + NUOPC_IsConnected(importState, fieldName="sh2ox2") .and. & + NUOPC_IsConnected(importState, fieldName="sh2ox3") .and. & + NUOPC_IsConnected(importState, fieldName="sh2ox4")) + else + c_slc = .false. + endif + + ! soil temperature + call ESMF_StateGet(importState,itemSearch="stc", itemCount=s_stc, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc1",itemCount=s_stc1,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc2",itemCount=s_stc2,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc3",itemCount=s_stc3,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_StateGet(importState,itemSearch="stc4",itemCount=s_stc4,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_stc.gt.0) then + c_stc = NUOPC_IsConnected(importState, fieldName="stc") + elseif ((s_stc1.gt.0) .and. (s_stc2.gt.0) .and. & + (s_stc3.gt.0) .and. (s_stc4.gt.0)) then + c_stc = (NUOPC_IsConnected(importState, fieldName="stc1") .and. & + NUOPC_IsConnected(importState, fieldName="stc2") .and. & + NUOPC_IsConnected(importState, fieldName="stc3") .and. & + NUOPC_IsConnected(importState, fieldName="stc4")) + else + c_stc = .false. + endif + + ! infiltration excess + call ESMF_StateGet(importState,itemSearch="infxsrt",itemCount=s_infxsrt,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_infxsrt.gt.0) then + c_infxsrt = NUOPC_IsConnected(importState, fieldName="infxsrt") + else + c_infxsrt = .false. + endif + + ! soil drainage + call ESMF_StateGet(importState,itemSearch="soldrain",itemCount=s_soldrain,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (s_soldrain.gt.0) then + c_soldrain = NUOPC_IsConnected(importState, fieldName="soldrain") + else + c_soldrain = .false. + endif + + check_lsm_forcings = c_smc .and. c_slc .and. c_stc .and. & + c_infxsrt .and. c_soldrain + + end function + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_advertise" + subroutine field_advertise(fieldList, importState, exportState, & + transferOffer, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + type(ESMF_State), intent(inout) :: importState + type(ESMF_State), intent(inout) :: exportState + character(*), intent(in),optional :: transferOffer + integer, intent(out) :: rc + ! local variables + integer :: n + + rc = ESMF_SUCCESS + + do n=lbound(fieldList,1),ubound(fieldList,1) + if (fieldList(n)%ad_import) then + call NUOPC_Advertise(importState, & + StandardName=fieldList(n)%sd_name, & + Units=fieldList(n)%units, & + TransferOfferGeomObject=transferOffer, & + name=fieldList(n)%st_name, & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + if (fieldList(n)%ad_export) then + call NUOPC_Advertise(exportState, & + StandardName=fieldList(n)%sd_name, & + Units=fieldList(n)%units, & + TransferOfferGeomObject=transferOffer, & + name=fieldList(n)%st_name, & + rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + end if + end do + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_advertise_log" + subroutine field_advertise_log(fieldList, cname, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(*), intent(in) :: cname + integer, intent(out) :: rc + ! local variables + integer :: cntImp + integer :: cntExp + integer :: n + character(32) :: label + character(ESMF_MAXSTR) :: logMsg + + rc = ESMF_SUCCESS + + label = trim(cname) + + ! count advertised import and export fields + cntImp = 0 + cntExp = 0 + do n = lbound(fieldList,1), ubound(fieldList,1) + if (fieldList(n)%ad_import) cntImp = cntImp + 1 + if (fieldList(n)%ad_export) cntExp = cntExp + 1 + enddo + + ! log advertised import fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of advertised import fields(',cntImp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntImp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%ad_import) cycle + cntImp = cntImp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntImp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + enddo + + ! log advertised export fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of advertised export fields(',cntExp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntExp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%ad_export) cycle + cntExp = cntExp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntExp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + enddo + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_realize_log" + subroutine field_realize_log(fieldList, cname, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(*), intent(in) :: cname + integer, intent(out) :: rc + ! local variables + integer :: cntImp + integer :: cntExp + integer :: n + character(32) :: label + character(ESMF_MAXSTR) :: logMsg + + rc = ESMF_SUCCESS + + label = trim(cname) + + ! count realized import and export fields + cntImp = 0 + cntExp = 0 + do n = lbound(fieldList,1), ubound(fieldList,1) + if (fieldList(n)%rl_import) cntImp = cntImp + 1 + if (fieldList(n)%rl_export) cntExp = cntExp + 1 + enddo + + ! log realized import fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of realized import fields(',cntImp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntImp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%rl_import) cycle + cntImp = cntImp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntImp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) + enddo + + ! log realized export fields + write(logMsg,'(a,a,i0,a)') trim(label)//': ', & + 'List of realized export fields(',cntExp,'):' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + write(logMsg,'(a,a5,a,a16,a,a)') trim(label)//': ', & + 'index',' ','name',' ','standardName' + call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO) + cntExp = 0 + do n=lbound(fieldList,1), ubound(fieldList,1) + if (.NOT.fieldList(n)%rl_export) cycle + cntExp = cntExp + 1 + write(logMsg,'(a,i5,a,a16,a,a)') trim(label)//': ', & + cntExp,' ',trim(fieldList(n)%st_name), & + ' ',trim(fieldList(n)%sd_name) + call ESMF_LogWrite(trim(LogMsg), ESMF_LOGMSG_INFO) + enddo + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "read_impexp_config_flnm" + subroutine read_impexp_config_flnm(fname, fieldList, rc) + character(len=30),intent(in) :: fname + type(cap_fld_type),intent(inout) :: fieldList(:) + integer,intent(out) :: rc + + ! local variables + type(ESMF_Config) :: fieldsConfig + type(NUOPC_FreeFormat) :: attrFF + integer :: lineCount + integer :: tokenCount + character(len=NUOPC_FreeFormatLen),allocatable :: tokenList(:) + integer :: i,j + integer :: stat + + rc = ESMF_SUCCESS + +! load fname into fieldsConfig + fieldsConfig = ESMF_ConfigCreate(rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_ConfigLoadFile(fieldsConfig, fname, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + +! read export fields from config + attrFF = NUOPC_FreeFormatCreate(fieldsConfig, & + label="hyd_fields", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call NUOPC_FreeFormatGet(attrFF, lineCount=lineCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + do i=1, lineCount + call NUOPC_FreeFormatGetLine(attrFF, line=i, & + tokenCount=tokenCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + if (.not.((tokenCount.eq.5).or.(tokenCount.eq.6))) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg="Malformed ocn_export_fields item FORMAT="// & + "'STATE_NAME' 'STANDARD_NAME' 'UNITS' 'IMPORT' 'EXPORT' "// & +! "['FILLVAL'] "// & + "in file: "//trim(fname), & + CONTEXT, rcToReturn=rc) + return ! bail out + endif + allocate(tokenList(tokenCount)) + call NUOPC_FreeFormatGetLine(attrFF, line=i, tokenList=tokenList, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call field_find_statename(fieldList, tokenList(1), location=j, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(j)%st_name=tokenList(1) + fieldList(j)%sd_name=tokenList(2) + fieldList(j)%units=tokenList(3) + tokenList(4) = ESMF_UtilStringUpperCase(tokenList(4), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(j)%ad_import=((tokenList(4).eq.".TRUE.") .or. & + (tokenList(4).eq."TRUE")) + tokenList(5) = ESMF_UtilStringUpperCase(tokenList(5), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + fieldList(j)%ad_export=((tokenList(5).eq.".TRUE.") .or. & + (tokenList(5).eq."TRUE")) + if (tokenCount.eq.6) then + fieldList(j)%vl_fillv = ESMF_UtilString2Real(tokenList(6), rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + deallocate(tokenList) + enddo + +! cleanup + call NUOPC_FreeFormatDestroy(attrFF, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + call ESMF_ConfigDestroy(fieldsConfig, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + end subroutine read_impexp_config_flnm + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_find_standardname" + subroutine field_find_standardname(fieldList, standardName, location, & + fillValue, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(len=64), intent(in) :: standardName + integer, intent(out), optional :: location + real(ESMF_KIND_R8),intent(out),optional :: fillValue + integer, intent(out) :: rc + ! local variables + integer :: n + + rc = ESMF_RC_NOT_FOUND + + if (present(location)) location = lbound(fieldList,1) - 1 + if (present(fillValue)) fillValue = ESMF_MISSING_VALUE + + do n=lbound(fieldList,1),ubound(fieldList,1) + if (fieldList(n)%sd_name .eq. standardName) then + if (present(location)) location = n + if (present(fillValue)) fillValue = fieldList(n)%vl_fillv + rc = ESMF_SUCCESS + return + end if + end do + + if (ESMF_LogFoundError(rcToCheck=rc, & + msg="Field not found in fieldList "//trim(standardName), & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_find_statename" + subroutine field_find_statename(fieldList, stateName, location, & + fillValue, rc) + type(cap_fld_type), intent(in) :: fieldList(:) + character(len=64), intent(in) :: stateName + integer, intent(out), optional :: location + real(ESMF_KIND_R8),intent(out),optional :: fillValue + integer, intent(out) :: rc + ! local variables + integer :: n + + rc = ESMF_RC_NOT_FOUND + + if (present(location)) location = lbound(fieldList,1) - 1 + if (present(fillValue)) fillValue = ESMF_MISSING_VALUE + + do n=lbound(fieldList,1),ubound(fieldList,1) + if (fieldList(n)%st_name .eq. stateName) then + if (present(location)) location = n + if (present(fillValue)) fillValue = fieldList(n)%vl_fillv + rc = ESMF_SUCCESS + return + end if + end do + + if (ESMF_LogFoundError(rcToCheck=rc, & + msg="Field not found in fieldList "//trim(stateName), & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + end subroutine + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "field_create" + function field_create(fld_name,grid,did,memflg,rc) + ! return value + type(ESMF_Field) :: field_create + ! arguments + character(*), intent(in) :: fld_name + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: did + type(memory_flag), intent(in) :: memflg + integer, intent(out) :: rc + ! local variables + character(len=16) :: cmemflg + + + rc = ESMF_SUCCESS + + if (memflg .eq. MEMORY_POINTER) then + select case (trim(fld_name)) + case ('smc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,:), gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('slc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,:), gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,:), gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,1), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox2') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,2), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox3') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,3), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sh2ox4') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%sh2ox(:,:,4), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,1), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc2') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,2), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc3') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,3), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smc4') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smc(:,:,4), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('smcmax1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%smcmax1, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc1') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,1), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc2') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,2), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc3') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,3), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('stc4') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%stc(:,:,4), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('vegtyp') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%vegtyp, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('sfchead') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%overland%control%surface_water_head_lsm, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case ('infxsrt') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%infxsrt, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + case ('soldrain') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + farray=rt_domain(did)%soldrain, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(fld_name), & + file=FILENAME,rcToReturn=rc) + return ! bail out + end select + elseif (memflg .eq. MEMORY_COPY) then + select case (trim(fld_name)) + case ('smc','slc','stc') + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + typekind=ESMF_TYPEKIND_FIELD, gridToFieldMap=(/1,2/), & + ungriddedLBound=(/1/), ungriddedUBound=(/nlst(did)%nsoil/), & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if(ESMF_STDERRORCHECK(rc)) return ! bail out + case default + field_create = ESMF_FieldCreate(name=fld_name, grid=grid, & + typekind=ESMF_TYPEKIND_FIELD, & + indexflag=ESMF_INDEX_DELOCAL, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + end select + call ESMF_FieldFill(field_create, dataFillScheme="const", & + const1=ESMF_MISSING_VALUE, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + else + cmemflg = memflg + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field memory flag unknown: "//trim(cmemflg), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + + end function + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_fill_uniform" + subroutine state_fill_uniform(state, fillValue, rc) + type(ESMF_State), intent(inout) :: state + real(ESMF_KIND_R8), intent(in) :: fillValue + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldFill(field, dataFillScheme="const", & + const1=fillValue, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_fill_uniform + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_fill_prescribe" + subroutine state_fill_prescribe(state, fieldList, rc) + type(ESMF_State), intent(inout) :: state + type(cap_fld_type), intent(in) :: fieldList(:) + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + real(ESMF_KIND_R8) :: filVal + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call field_find_statename(fieldList, & + stateName=itemNameList(n), fillValue=filVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldFill(field, dataFillScheme="const", & + const1=filVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_fill_prescribe + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_fill_file" + subroutine state_fill_file(state, filePrefix, rc) + type(ESMF_State), intent(inout) :: state + character(len=*), intent(in) :: filePrefix + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + character(len=64) :: fldName + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if ( itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state,field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_GetAttribute(field, name="StandardName", & + value=fldName, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldRead(field, variableName=trim(fldName), & + fileName=trim(filePrefix)//"_"//trim(itemNameList(n))//".nc", & + iofmt=ESMF_IOFMT_NETCDF, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_fill_file + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_copy_tohyd" + subroutine state_copy_tohyd(state, did, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + integer :: dimCount + real(ESMF_KIND_FIELD), pointer :: farrayPtr2d(:,:) + real(ESMF_KIND_FIELD), pointer :: farrayPtr3d(:,:,:) + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldGet(field, dimCount=dimCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + if (dimCount .eq. 2) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr2d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + elseif (dimCount .eq. 3) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr3d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + else + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": dimCount is not supported.", & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + select case (ItemNameList(n)) + case ('smc') + rt_domain(did)%smc = farrayPtr3d + case ('slc') + rt_domain(did)%sh2ox = farrayPtr3d + case ('stc') + rt_domain(did)%stc = farrayPtr3d + case ('sh2ox1') + rt_domain(did)%sh2ox(:,:,1) = farrayPtr2d + case ('sh2ox2') + rt_domain(did)%sh2ox(:,:,2) = farrayPtr2d + case ('sh2ox3') + rt_domain(did)%sh2ox(:,:,3) = farrayPtr2d + case ('sh2ox4') + rt_domain(did)%sh2ox(:,:,4) = farrayPtr2d + case ('smc1') + rt_domain(did)%smc(:,:,1) = farrayPtr2d + case ('smc2') + rt_domain(did)%smc(:,:,2) = farrayPtr2d + case ('smc3') + rt_domain(did)%smc(:,:,3) = farrayPtr2d + case ('smc4') + rt_domain(did)%smc(:,:,4) = farrayPtr2d + case ('smcmax1') + rt_domain(did)%smcmax1 = farrayPtr2d + case ('stc1') + rt_domain(did)%stc(:,:,1) = farrayPtr2d + case ('stc2') + rt_domain(did)%stc(:,:,2) = farrayPtr2d + case ('stc3') + rt_domain(did)%stc(:,:,3) = farrayPtr2d + case ('stc4') + rt_domain(did)%stc(:,:,4) = farrayPtr2d + case ('vegtyp') + rt_domain(did)%vegtyp = farrayPtr2d + case ('sfchead') + rt_domain(did)%overland%control%surface_water_head_lsm = & + farrayPtr2d + case ('infxsrt') + rt_domain(did)%infxsrt = farrayPtr2d + case ('soldrain') + rt_domain(did)%soldrain = farrayPtr2d + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endselect + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_copy_tohyd + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_copy_frhyd" + subroutine state_copy_frhyd(state, did, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: field + integer :: dimCount + real(ESMF_KIND_FIELD), pointer :: farrayPtr2d(:,:) + real(ESMF_KIND_FIELD), pointer :: farrayPtr3d(:,:,:) + integer :: stat + character(len=16) :: cmissingv_flag + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=field, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldGet(field, dimCount=dimCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + if (dimCount .eq. 2) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr2d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + elseif (dimCount .eq. 3) then + call ESMF_FieldGet(field, farrayPtr=farrayPtr3d, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + else + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": dimCount is not supported.", & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + select case (ItemNameList(n)) + case ('smc') + farrayPtr3d = rt_domain(did)%smc + case ('slc') + farrayPtr3d = rt_domain(did)%sh2ox + case ('stc') + farrayPtr3d = rt_domain(did)%stc + case ('sh2ox1') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,1) + case ('sh2ox2') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,2) + case ('sh2ox3') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,3) + case ('sh2ox4') + farrayPtr2d = rt_domain(did)%sh2ox(:,:,4) + case ('smc1') + farrayPtr2d = rt_domain(did)%smc(:,:,1) + case ('smc2') + farrayPtr2d = rt_domain(did)%smc(:,:,2) + case ('smc3') + farrayPtr2d = rt_domain(did)%smc(:,:,3) + case ('smc4') + farrayPtr2d = rt_domain(did)%smc(:,:,4) + case ('smcmax1') + farrayPtr2d = rt_domain(did)%smcmax1 + case ('stc1') + farrayPtr2d = rt_domain(did)%stc(:,:,1) + case ('stc2') + farrayPtr2d = rt_domain(did)%stc(:,:,2) + case ('stc3') + farrayPtr2d = rt_domain(did)%stc(:,:,3) + case ('stc4') + farrayPtr2d = rt_domain(did)%stc(:,:,4) + case ('vegtyp') + farrayPtr2d = rt_domain(did)%vegtyp + case ('sfchead') + farrayPtr2d = rt_domain(did)%overland%control%surface_water_head_lsm + case ('infxsrt') + farrayPtr2d = rt_domain(did)%infxsrt + case ('soldrain') + farrayPtr2d = rt_domain(did)%soldrain + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + end select + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_copy_frhyd + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_check_missing" + subroutine state_check_missing(state, did, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + real(ESMF_KIND_R8), parameter :: chkVal = real(ESMF_MISSING_VALUE) + logical :: missng + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + missng = .FALSE. + select case (ItemNameList(n)) + case ('smc') + missng = any(rt_domain(did)%smc.eq.chkVal) + case ('slc') + missng = any(rt_domain(did)%sh2ox.eq.chkVal) + case ('stc') + missng = any(rt_domain(did)%stc.eq.chkVal) + case ('sh2ox1') + missng = any(rt_domain(did)%sh2ox(:,:,1).eq.chkVal) + case ('sh2ox2') + missng = any(rt_domain(did)%sh2ox(:,:,2).eq.chkVal) + case ('sh2ox3') + missng = any(rt_domain(did)%sh2ox(:,:,3).eq.chkVal) + case ('sh2ox4') + missng = any(rt_domain(did)%sh2ox(:,:,4).eq.chkVal) + case ('smc1') + missng = any(rt_domain(did)%smc(:,:,1).eq.chkVal) + case ('smc2') + missng = any(rt_domain(did)%smc(:,:,2).eq.chkVal) + case ('smc3') + missng = any(rt_domain(did)%smc(:,:,3).eq.chkVal) + case ('smc4') + missng = any(rt_domain(did)%smc(:,:,4).eq.chkVal) + case ('smcmax1') + missng = any(rt_domain(did)%smcmax1.eq.chkVal) + case ('stc1') + missng = any(rt_domain(did)%stc(:,:,1).eq.chkVal) + case ('stc2') + missng = any(rt_domain(did)%stc(:,:,2).eq.chkVal) + case ('stc3') + missng = any(rt_domain(did)%stc(:,:,3).eq.chkVal) + case ('stc4') + missng = any(rt_domain(did)%stc(:,:,4).eq.chkVal) + case ('vegtyp') + missng = any(rt_domain(did)%vegtyp.eq.chkVal) + case ('sfchead') + missng = any(rt_domain(did)%overland%control%surface_water_head_lsm & + .eq.chkVal) + case ('infxsrt') + missng = any(rt_domain(did)%infxsrt.eq.chkVal) + case ('soldrain') + missng = any(rt_domain(did)%soldrain.eq.chkVal) + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endselect + if (missng) then + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Missing value: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + endif + enddo + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_check_missing + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "state_prescribe_missing" + subroutine state_prescribe_missing(state, did, fieldList, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + type(cap_fld_type), intent(in) :: fieldList(:) + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + real(ESMF_KIND_R8), parameter :: chkVal = real(ESMF_MISSING_VALUE) + real(ESMF_KIND_R8) :: filVal + integer :: stat + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call field_find_statename(fieldList, & + stateName=itemNameList(n), fillValue=filVal, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + select case (itemNameList(n)) + case ('smc') + where (rt_domain(did)%smc.eq.chkVal) & + rt_domain(did)%smc = filVal + case ('slc') + where (rt_domain(did)%sh2ox.eq.chkVal) & + rt_domain(did)%sh2ox = filVal + case ('stc') + where (rt_domain(did)%stc.eq.chkVal) & + rt_domain(did)%stc = filVal + case ('sh2ox1') + where (rt_domain(did)%sh2ox(:,:,1).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,1) = filVal + case ('sh2ox2') + where (rt_domain(did)%sh2ox(:,:,2).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,2) = filVal + case ('sh2ox3') + where (rt_domain(did)%sh2ox(:,:,3).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,3) = filVal + case ('sh2ox4') + where (rt_domain(did)%sh2ox(:,:,4).eq.chkVal) & + rt_domain(did)%sh2ox(:,:,4) = filVal + case ('smc1') + where (rt_domain(did)%smc(:,:,1).eq.chkVal) & + rt_domain(did)%smc(:,:,1) = filVal + case ('smc2') + where (rt_domain(did)%smc(:,:,2).eq.chkVal) & + rt_domain(did)%smc(:,:,2) = filVal + case ('smc3') + where (rt_domain(did)%smc(:,:,3).eq.chkVal) & + rt_domain(did)%smc(:,:,3) = filVal + case ('smc4') + where (rt_domain(did)%smc(:,:,4).eq.chkVal) & + rt_domain(did)%smc(:,:,4) = filVal + case ('smcmax1') + where (rt_domain(did)%smcmax1.eq.chkVal) & + rt_domain(did)%smcmax1 = filVal + case ('stc1') + where (rt_domain(did)%stc(:,:,1).eq.chkVal) & + rt_domain(did)%stc(:,:,1) = filVal + case ('stc2') + where (rt_domain(did)%stc(:,:,2).eq.chkVal) & + rt_domain(did)%stc(:,:,2) = filVal + case ('stc3') + where (rt_domain(did)%stc(:,:,3).eq.chkVal) & + rt_domain(did)%stc(:,:,3) = filVal + case ('stc4') + where (rt_domain(did)%stc(:,:,4).eq.chkVal) & + rt_domain(did)%stc(:,:,4) = filVal + case ('vegtyp') + where (rt_domain(did)%vegtyp.eq.chkVal) & + rt_domain(did)%vegtyp = filVal + case ('sfchead') + where (rt_domain(did)%overland%control%surface_water_head_lsm & + .eq.chkVal) & + rt_domain(did)%overland%control%surface_water_head_lsm = filVal + case ('infxsrt') + where (rt_domain(did)%infxsrt.eq.chkVal) & + rt_domain(did)%infxsrt = filVal + case ('soldrain') + where (rt_domain(did)%soldrain.eq.chkVal) & + rt_domain(did)%soldrain = filVal + case default + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field hookup missing: "//trim(itemNameList(n)), & + file=FILENAME,rcToReturn=rc) + return ! bail out + end select + endif + enddo + + deallocate(itemNameList) + deallocate(itemTypeList) + + end subroutine state_prescribe_missing + + !----------------------------------------------------------------------------- + +#undef METHOD +#define METHOD "model_debug" + subroutine model_debug(state, did, memflg, filePrefix, rc) + type(ESMF_State), intent(inout) :: state + integer, intent(in) :: did + type(memory_flag) :: memflg + character(len=*) :: filePrefix + integer, intent(out) :: rc + ! local variables + integer :: n + integer :: itemCount + character(len=64),allocatable :: itemNameList(:) + type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + type(ESMF_Field) :: cpyfield, outfield + type(ESMF_Grid) :: grid + integer :: stat + character(len=16) :: cmemflg + + rc = ESMF_SUCCESS + + if (memflg .eq. MEMORY_POINTER) then + call NUOPC_Write(state, & + fileNamePrefix=filePrefix, overwrite=.true., & + status=ESMF_FILESTATUS_REPLACE, timeslice=1, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + elseif(memflg .eq. MEMORY_COPY) then + call ESMF_StateGet(state,itemCount=itemCount, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return ! bail out + + allocate(itemNameList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item name memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + allocate(itemTypeList(itemCount), stat=stat) + if (ESMF_LogFoundAllocError(statusToCheck=stat, & + msg="Allocation of state item type memory failed.", & + line=__LINE__, file=__FILE__)) return ! bail out + call ESMF_StateGet(state,itemNameList=itemNameList, & + itemTypeList=itemTypeList,rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + + do n=1, itemCount + if (itemTypeList(n) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(state, field=cpyfield, & + itemName=itemNameList(n),rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + call ESMF_FieldGet(cpyfield, grid=grid, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + outfield = field_create(itemNameList(n), grid=grid, did=did, & + memflg=MEMORY_POINTER, rc=rc) + call ESMF_FieldWrite(outfield, variableName=itemNameList(n), & + fileName=trim(filePrefix)//"_"//trim(itemNameList(n))//".nc", & + iofmt=ESMF_IOFMT_NETCDF, rc=rc) + call ESMF_FieldDestroy(outfield, rc=rc) + if (ESMF_STDERRORCHECK(rc)) return + endif + enddo + deallocate(itemNameList) + deallocate(itemTypeList) + else + cmemflg = memflg + call ESMF_LogSetError(ESMF_FAILURE, & + msg=METHOD//": Field memory flag unknown: "//trim(cmemflg), & + file=FILENAME,rcToReturn=rc) + return ! bail out + endif + + end subroutine model_debug + + !----------------------------------------------------------------------------- + + +end module wrfhydro_nuopc_fields diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 new file mode 100644 index 000000000..3a4ffe934 --- /dev/null +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Flags.F90 @@ -0,0 +1,305 @@ +#define FILENAME "WRFHydro_NUOPC_Flags.F90" +#define MODNAME "wrfhydro_nuopc_flags" +#include "WRFHydro_NUOPC_Macros.h" + +module wrfhydro_nuopc_flags +! !MODULE: wrfhydro_nuopc_flags +! +! !DESCRIPTION: +! This module controls WRFHYDRO configuration flags for NUOPC cap +! +! !REVISION HISTORY: +! 21Sep23 Dan Rosen Initial Specification +! +! !USES: + use ESMF, only: ESMF_UtilStringUpperCase, ESMF_SUCCESS + + implicit none + + private + + type memory_flag + sequence + private + integer :: mem + end type memory_flag + + type(memory_flag), parameter :: & + MEMORY_ERROR = memory_flag(-1), & + MEMORY_POINTER = memory_flag(0), & + MEMORY_COPY = memory_flag(1) + + type fillv_flag + sequence + private + integer :: fillv + end type fillv_flag + + type(fillv_flag), parameter :: & + FILLV_ERROR = fillv_flag(-1), & + FILLV_MISSING = fillv_flag(0), & + FILLV_ZERO = fillv_flag(1), & + FILLV_PRESCRIBE = fillv_flag(2), & + FILLV_MODEL = fillv_flag(3), & + FILLV_DEPENDENCY = fillv_flag(4), & + FILLV_FILE = fillv_flag(5) + + type checkclock_flag + sequence + private + integer :: checkclock + end type checkclock_flag + + type(checkclock_flag), parameter :: & + CHECKCLOCK_ERROR = checkclock_flag(-1), & + CHECKCLOCK_CURRT = checkclock_flag(0), & + CHECKCLOCK_NEXTT = checkclock_flag(1), & + CHECKCLOCK_NONE = checkclock_flag(2) + + type missingval_flag + sequence + private + integer :: missingval + end type missingval_flag + + type(missingval_flag), parameter :: & + MISSINGVAL_ERROR = missingval_flag(-1), & + MISSINGVAL_IGNORE = missingval_flag(0), & + MISSINGVAL_FAIL = missingval_flag(1), & + MISSINGVAL_PRESCRIBE = missingval_flag(2) + + public memory_flag + public fillv_flag + public checkclock_flag + public missingval_flag + public MEMORY_ERROR + public MEMORY_COPY + public MEMORY_POINTER + public FILLV_ERROR + public FILLV_ZERO + public FILLV_MISSING + public FILLV_PRESCRIBE + public FILLV_MODEL + public FILLV_DEPENDENCY + public FILLV_FILE + public CHECKCLOCK_ERROR + public CHECKCLOCK_CURRT + public CHECKCLOCK_NEXTT + public CHECKCLOCK_NONE + public MISSINGVAL_ERROR + public MISSINGVAL_IGNORE + public MISSINGVAL_FAIL + public MISSINGVAL_PRESCRIBE + + public operator(==), assignment(=) + + interface operator (==) + module procedure memory_eq + module procedure fillv_eq + module procedure checkclock_eq + module procedure missingval_eq + end interface + + interface assignment (=) + module procedure memory_toString + module procedure memory_frString + module procedure fillv_toString + module procedure fillv_frString + module procedure checkclock_toString + module procedure checkclock_frString + module procedure missingval_toString + module procedure missingval_frString + end interface + + !----------------------------------------------------------------------------- + contains + !----------------------------------------------------------------------------- + + function memory_eq(val1, val2) + logical memory_eq + type(memory_flag), intent(in) :: val1, val2 + memory_eq = (val1%mem == val2%mem) + end function memory_eq + + !----------------------------------------------------------------------------- + subroutine memory_toString(string, val) + character(len=*), intent(out) :: string + type(memory_flag), intent(in) :: val + if (val == MEMORY_COPY) then + write(string,'(a)') 'MEMORY_COPY' + elseif (val == MEMORY_POINTER) then + write(string,'(a)') 'MEMORY_POINTER' + else + write(string,'(a)') 'MEMORY_ERROR' + endif + end subroutine memory_toString + + !----------------------------------------------------------------------------- + + subroutine memory_frString(val, string) + type(memory_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=16) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = MEMORY_ERROR + elseif (ustring .eq. 'MEMORY_COPY') then + val = MEMORY_COPY + elseif (ustring .eq. 'MEMORY_POINTER') then + val = MEMORY_POINTER + else + val = MEMORY_ERROR + endif + end subroutine memory_frString + + !----------------------------------------------------------------------------- + + function fillv_eq(val1, val2) + logical fillv_eq + type(fillv_flag), intent(in) :: val1, val2 + fillv_eq = (val1%fillv == val2%fillv) + end function fillv_eq + + !----------------------------------------------------------------------------- + + subroutine fillv_toString(string, val) + character(len=*), intent(out) :: string + type(fillv_flag), intent(in) :: val + if (val == FILLV_ZERO) then + write(string,'(a)') 'FILLV_ZERO' + elseif (val == FILLV_MISSING) then + write(string,'(a)') 'FILLV_MISSING' + elseif (val == FILLV_PRESCRIBE) then + write(string,'(a)') 'FILLV_PRESCRIBE' + elseif (val == FILLV_MODEL) then + write(string,'(a)') 'FILLV_MODEL' + elseif (val == FILLV_DEPENDENCY) then + write(string,'(a)') 'FILLV_DEPENDENCY' + elseif (val == FILLV_FILE) then + write(string,'(a)') 'FILLV_FILE' + else + write(string,'(a)') 'FILLV_ERROR' + endif + end subroutine fillv_toString + + !----------------------------------------------------------------------------- + + subroutine fillv_frString(val, string) + type(fillv_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=16) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = FILLV_ERROR + elseif (ustring .eq. 'FILLV_ZERO') then + val = FILLV_ZERO + elseif (ustring .eq. 'FILLV_MISSING') then + val = FILLV_MISSING + elseif (ustring .eq. 'FILLV_PRESCRIBE') then + val = FILLV_PRESCRIBE + elseif (ustring .eq. 'FILLV_MODEL') then + val = FILLV_MODEL + elseif (ustring .eq. 'FILLV_DEPENDENCY') then + val = FILLV_DEPENDENCY + elseif (ustring .eq. 'FILLV_FILE') then + val = FILLV_FILE + else + val = FILLV_ERROR + endif + end subroutine fillv_frString + + !----------------------------------------------------------------------------- + + function checkclock_eq(val1, val2) + logical checkclock_eq + type(checkclock_flag), intent(in) :: val1, val2 + checkclock_eq = (val1%checkclock == val2%checkclock) + end function checkclock_eq + + !----------------------------------------------------------------------------- + + subroutine checkclock_toString(string, val) + character(len=*), intent(out) :: string + type(checkclock_flag), intent(in) :: val + if (val == CHECKCLOCK_CURRT) then + write(string,'(a)') 'CHECKCLOCK_CURRT' + elseif (val == CHECKCLOCK_NEXTT) then + write(string,'(a)') 'CHECKCLOCK_NEXTT' + elseif (val == CHECKCLOCK_NONE) then + write(string,'(a)') 'CHECKCLOCK_NONE' + else + write(string,'(a)') 'CHECKCLOCK_ERROR' + endif + end subroutine checkclock_toString + + !----------------------------------------------------------------------------- + + subroutine checkclock_frString(val, string) + type(checkclock_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=16) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = CHECKCLOCK_ERROR + elseif (ustring .eq. 'CHECKCLOCK_CURRT') then + val = CHECKCLOCK_CURRT + elseif (ustring .eq. 'CHECKCLOCK_NEXTT') then + val = CHECKCLOCK_NEXTT + elseif (ustring .eq. 'CHECKCLOCK_NONE') then + val = CHECKCLOCK_NONE + else + val = CHECKCLOCK_ERROR + endif + end subroutine checkclock_frString + + !----------------------------------------------------------------------------- + + function missingval_eq(val1, val2) + logical missingval_eq + type(missingval_flag), intent(in) :: val1, val2 + missingval_eq = (val1%missingval == val2%missingval) + end function missingval_eq + + !----------------------------------------------------------------------------- + + subroutine missingval_toString(string, val) + character(len=*), intent(out) :: string + type(missingval_flag), intent(in) :: val + if (val == MISSINGVAL_IGNORE) then + write(string,'(a)') 'MISSINGVAL_IGNORE' + elseif (val == MISSINGVAL_FAIL) then + write(string,'(a)') 'MISSINGVAL_FAIL' + elseif (val == MISSINGVAL_PRESCRIBE) then + write(string,'(a)') 'MISSINGVAL_PRESCRIBE' + else + write(string,'(a)') 'MISSINGVAL_ERROR' + endif + end subroutine missingval_toString + + !----------------------------------------------------------------------------- + + subroutine missingval_frString(val, string) + type(missingval_flag), intent(out) :: val + character(len=*), intent(in) :: string + character(len=20) :: ustring + integer :: rc + ustring = ESMF_UtilStringUpperCase(string, rc=rc) + if (rc .ne. ESMF_SUCCESS) then + val = MISSINGVAL_ERROR + elseif (ustring .eq. 'MISSINGVAL_IGNORE') then + val = MISSINGVAL_IGNORE + elseif (ustring .eq. 'MISSINGVAL_FAIL') then + val = MISSINGVAL_FAIL + elseif (ustring .eq. 'MISSINGVAL_PRESCRIBE') then + val = MISSINGVAL_PRESCRIBE + else + val = MISSINGVAL_ERROR + endif + end subroutine missingval_frString + + !----------------------------------------------------------------------------- + +end module diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 index d9b1a5515..019646bd0 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Gluecode.F90 @@ -44,16 +44,14 @@ module wrfhydro_nuopc_gluecode cpl_outdate use module_rt_data, only: & rt_domain - use overland_data, only: & - overland_struct - use overland_control, only: & - overland_control_struct use module_lsm_forcing, only: & read_ldasout use config_base, only: & nlst, & init_namelist_rt_field use orchestrator_base + use wrfhydro_nuopc_fields + use wrfhydro_nuopc_flags implicit none @@ -66,173 +64,7 @@ module wrfhydro_nuopc_gluecode public :: WRFHYDRO_get_timestep public :: WRFHYDRO_set_timestep public :: WRFHYDRO_get_hgrid - public :: WRFHYDRO_RunModeGet - public :: WRFHYDRO_Unknown - public :: WRFHYDRO_Offline - public :: WRFHYDRO_Coupled - public :: WRFHYDRO_Hybrid - public :: WRFHYDRO_Field - public :: WRFHYDRO_FieldList - public :: WRFHYDRO_FieldDictionaryAdd - public :: WRFHYDRO_FieldCreate - - INTEGER, PARAMETER :: WRFHYDRO_Unknown = -1 - INTEGER, PARAMETER :: WRFHYDRO_Offline = 0 - INTEGER, PARAMETER :: WRFHYDRO_Coupled = 1 - INTEGER, PARAMETER :: WRFHYDRO_Hybrid = 2 - - type WRFHYDRO_Field - character(len=64) :: stdname = ' ' - character(len=10) :: units = ' ' - character(len=16) :: stateName = ' ' - character(len=64) :: transferOffer = 'will provide' - logical :: adImport = .FALSE. - logical :: realizedImport = .FALSE. - logical :: adExport = .FALSE. - logical :: realizedExport = .FALSE. - logical :: assoc = .FALSE. - real(ESMF_KIND_R8), dimension(:,:,:), pointer :: farrayPtr => null() - endtype WRFHYDRO_Field - - type(WRFHYDRO_Field),dimension(46) :: WRFHYDRO_FieldList = (/ & - WRFHYDRO_Field( & !(01) - stdname='aerodynamic_roughness_length', units='m', & - stateName='z0',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(02) - stdname='canopy_moisture_storage', units='kg m-2', & - stateName='cmc',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(03) - stdname='carbon_dioxide', units='mol?', & - stateName='co2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(04) - stdname='cosine_zenith_angle', units='?', & - stateName='cosz',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(05) - stdname='exchange_coefficient_heat', units='?', & - stateName='ch',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(06) - stdname='exchange_coefficient_heat_height2m', units='?', & - stateName='ch2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(07) - stdname='exchange_coefficient_moisture_height2m', units='?', & - stateName='ch2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(08) - stdname='ice_mask', units='1', & - stateName='xice',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(09) - stdname='inst_down_lw_flx', units='W m-2', & - stateName='lwdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(10) - stdname='inst_down_sw_flx', units='W m-2', & - stateName='swdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(11) - stdname='inst_height_lowest', units='m', & - stateName='hgt',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(12) - stdname='inst_merid_wind_height_lowest', units='m s-1', & - stateName='vwind',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(13) - stdname='inst_pres_height_lowest', units='Pa', & - stateName='psurf',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(14) - stdname='inst_pres_height_surface', units='Pa', & - stateName='psurf',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(15) - stdname='inst_spec_humid_height_lowest', units='kg kg-1', & - stateName='q2',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(16) - stdname='inst_temp_height_lowest', units='K', & - stateName='sfctmp',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(17) - stdname='inst_temp_height_surface', units='K', & - stateName='sfctmp',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(18) - stdname='inst_wind_speed_height_lowest', units='m s-1', & - stateName='sfcspd',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(19) - stdname='inst_zonal_wind_height_lowest', units='m s-1', & - stateName='uwind',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(20) - stdname='liquid_fraction_of_soil_moisture_layer_1', units='m3 m-3', & - stateName='sh2ox1',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(21) - stdname='liquid_fraction_of_soil_moisture_layer_2', units='m3 m-3', & - stateName='sh2ox2',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(22) - stdname='liquid_fraction_of_soil_moisture_layer_3', units='m3 m-3', & - stateName='sh2ox3',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(23) - stdname='liquid_fraction_of_soil_moisture_layer_4', units='m3 m-3', & - stateName='sh2ox4',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(24) - stdname='mean_cprec_rate', units='kg s-1 m-2', & - stateName='prcpconv',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(25) - stdname='mean_down_lw_flx', units='W m-2', & - stateName='lwdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(26) - stdname='mean_down_sw_flx', units='W m-2', & - stateName='swdown',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(27) - stdname='mean_fprec_rate', units='kg s-1 m-2', & - stateName='prcp_frozen',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(28) - stdname='mean_prec_rate', units='kg s-1 m-2', & - stateName='prcprain',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(29) - stdname='mean_surface_albedo', units='lm lm-1', & - stateName='albedo',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(30) - stdname='soil_moisture_fraction_layer_1', units='m3 m-3', & - stateName='smc1',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(31) - stdname='soil_moisture_fraction_layer_2', units='m3 m-3', & - stateName='smc2',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(32) - stdname='soil_moisture_fraction_layer_3', units='m3 m-3', & - stateName='smc3',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(33) - stdname='soil_moisture_fraction_layer_4', units='m3 m-3', & - stateName='smc4',adImport=.TRUE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(34) - stdname='soil_porosity', units='1', & - stateName='smcmax1',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(35) - stdname='subsurface_runoff_amount', units='kg m-2', & - stateName='soldrain',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(36) - stdname='surface_runoff_amount', units='kg m-2', & - stateName='infxsrt',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(37) - stdname='surface_snow_thickness', units='m', & - stateName='snowdepth',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(38) - stdname='soil_temperature_layer_1', units='K', & - stateName='stc1',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(39) - stdname='soil_temperature_layer_2', units='K', & - stateName='stc2',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(40) - stdname='soil_temperature_layer_3', units='K', & - stateName='stc3',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(41) - stdname='soil_temperature_layer_4', units='K', & - stateName='stc4',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(42) - stdname='vegetation_type', units='1', & - stateName='vegtyp',adImport=.FALSE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(43) - stdname='volume_fraction_of_total_water_in_soil', units='m3 m-3', & - stateName='snliqv',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(44) - stdname='surface_water_depth', units='mm', & - stateName='sfchead',adImport=.FALSE.,adExport=.TRUE.), & - WRFHYDRO_Field( & !(45) - stdname='time_step_infiltration_excess', units='mm', & - stateName='infxsrt',adImport=.TRUE.,adExport=.FALSE.), & - WRFHYDRO_Field( & !(46) - stdname='soil_column_drainage', units='mm', & - stateName='soldrain',adImport=.TRUE.,adExport=.FALSE.)/) + public :: WRFHYDRO_get_restart ! PARAMETERS character(len=ESMF_MAXSTR) :: indir = 'WRFHYDRO_FORCING' @@ -337,7 +169,7 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) write(nlst(did)%hgrid,'(I1)') did if(nlst(did)%dt .le. 0) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Timestep less than 1 is not supported!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -352,7 +184,7 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) #endif if(nlst(did)%nsoil .gt. 4) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Maximum soil levels supported is 4.", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -473,7 +305,7 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) cpl_outdate = startTimeStr(1:19) if(nlst(did)%dt .le. 0) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Timestep less than 1 is not supported!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -521,9 +353,10 @@ subroutine wrfhydro_nuopc_ini(did,vm,clock,forcingDir,rc) #undef METHOD #define METHOD "wrfhydro_nuopc_run" - subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) + subroutine wrfhydro_nuopc_run(did,lsm_forcings,clock,importState,& + exportState,rc) integer, intent(in) :: did - integer, intent(in) :: mode + logical, intent(in) :: lsm_forcings type(ESMF_Clock),intent(in) :: clock type(ESMF_State),intent(inout) :: importState type(ESMF_State),intent(inout) :: exportState @@ -539,7 +372,7 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) rc = ESMF_SUCCESS if(.not. RT_DOMAIN(did)%initialized) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg="WRHYDRO: Model has not been initialized!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -556,7 +389,7 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) if(ESMF_STDERRORCHECK(rc)) return ! bail out if(nlst(did)%dt .le. 0) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Timestep less than 1 is not supported!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -593,7 +426,7 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) nlst(did)%GWBASESWCRT .eq. 0) then call ESMF_LogWrite(METHOD//": SUBRTSWCRT,OVRTSWCRT,GWBASESWCRT are zero!", & ESMF_LOGMSG_WARNING) - !call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + !call ESMF_LogSetError(ESMF_FAILURE, & ! msg=METHOD//": SUBRTSWCRT,OVRTSWCRT,GWBASESWCRT are zero!", & ! file=FILENAME,rcToReturn=rc) !return ! bail out @@ -603,31 +436,13 @@ subroutine wrfhydro_nuopc_run(did,mode,clock,importState,exportState,rc) call ESMF_LogWrite(METHOD//": Restart initial data from offline file.", & ESMF_LOGMSG_INFO) else - - select case (mode) - case (WRFHYDRO_Offline) - call read_ldasout(olddate=nlst(did)%olddate(1:19), & - hgrid=nlst(did)%hgrid, & - indir=trim(indir), dt=nlst(did)%dt, & - ix=rt_domain(did)%ix,jx=rt_domain(did)%jx, & - infxsrt=rt_domain(did)%infxsrt,soldrain=rt_domain(did)%soldrain) - case (WRFHYDRO_Coupled) - - - case (WRFHYDRO_Hybrid) - call read_ldasout(olddate=nlst(did)%olddate(1:19), & - hgrid=nlst(did)%hgrid, & - indir=trim(indir), dt=nlst(did)%dt, & - ix=rt_domain(did)%ix,jx=rt_domain(did)%jx, & - infxsrt=rt_domain(did)%infxsrt,soldrain=rt_domain(did)%soldrain) - - - case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=METHOD//": Running mode is unknown.", & - file=FILENAME, rcToReturn=rc) - return ! bail out - end select + if (.not. lsm_forcings) then + call read_ldasout(olddate=nlst(did)%olddate(1:19), & + hgrid=nlst(did)%hgrid, & + indir=trim(indir), dt=nlst(did)%dt, & + ix=rt_domain(did)%ix,jx=rt_domain(did)%jx, & + infxsrt=rt_domain(did)%infxsrt,soldrain=rt_domain(did)%soldrain) + endif endif ! Call the WRF-HYDRO run routine @@ -681,128 +496,6 @@ subroutine wrfhydro_nuopc_fin(did,rc) end subroutine - !----------------------------------------------------------------------------- - ! Create field using internal memory - !----------------------------------------------------------------------------- - -#undef METHOD -#define METHOD "WRFHYDRO_FieldCreate" - - function WRFHYDRO_FieldCreate(stateName,grid,did,rc) - ! RETURN VALUE - type(ESMF_Field) :: WRFHYDRO_FieldCreate - ! ARGUMENTS - character(*), intent(in) :: stateName - type(ESMF_Grid), intent(in) :: grid - integer, intent(in) :: did - integer, intent(out) :: rc - ! LOCAL VARIABLES - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": entered "//METHOD, ESMF_LOGMSG_INFO) -#endif - - rc = ESMF_SUCCESS - - SELECT CASE (trim(stateName)) - CASE ('sh2ox1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,1), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sh2ox2') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,2), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sh2ox3') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,3), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sh2ox4') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%sh2ox(:,:,4), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,1), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc2') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,2), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc3') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,3), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smc4') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smc(:,:,4), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('smcmax1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%smcmax1, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc1') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,1), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc2') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,2), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc3') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,3), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('stc4') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%stc(:,:,4), & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('vegtyp') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%vegtyp, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('sfchead') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%overland%control%surface_water_head_lsm, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if(ESMF_STDERRORCHECK(rc)) return ! bail out - CASE ('infxsrt') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%infxsrt, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - CASE ('soldrain') - WRFHYDRO_FieldCreate = ESMF_FieldCreate(name=stateName, grid=grid, & - farray=rt_domain(did)%soldrain, & - indexflag=ESMF_INDEX_DELOCAL, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - CASE DEFAULT - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & - msg=METHOD//": Field hookup missing: "//trim(stateName), & - file=FILENAME,rcToReturn=rc) - return ! bail out - END SELECT - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": leaving "//METHOD, ESMF_LOGMSG_INFO) -#endif - - end function - #undef METHOD #define METHOD "WRFHYDRO_GridCreate" @@ -1237,57 +930,31 @@ subroutine WRFHYDRO_get_hgrid(did,hgrid,rc) !----------------------------------------------------------------------------- #undef METHOD -#define METHOD "WRFHYDRO_RunModeGet" +#define METHOD "WRFHYDRO_get_restart" - function WRFHYDRO_RunModeGet(importState,rc) - ! RETURN - integer :: WRFHYDRO_RunModeGet + subroutine WRFHYDRO_get_restart(did,restart,rc) ! ARGUMENTS - type(ESMF_State), intent(in) :: importState - integer, intent(out), optional :: rc - ! LOCAL VARIABLES - integer :: fieldIndex - integer :: forcingCount - integer :: connectedCount - type(ESMF_StateItem_Flag) :: itemType + integer, intent(in) :: did + logical, intent(out) :: restart + integer, intent(out) :: rc #ifdef DEBUG call ESMF_LogWrite(MODNAME//": entered "//METHOD, ESMF_LOGMSG_INFO) #endif - if(present(rc)) rc = ESMF_SUCCESS - - WRFHYDRO_RunModeGet = WRFHYDRO_Unknown - forcingCount = 0 - connectedCount = 0 - - do fieldIndex=1, size(WRFHYDRO_FieldList) - if(WRFHYDRO_FieldList(fieldIndex)%adImport) then - forcingCount = forcingCount + 1 - ! Check itemType to see if field exists in state - call ESMF_StateGet(importState, & - itemName=trim(WRFHYDRO_FieldList(fieldIndex)%stateName), & - itemType=itemType, rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - - if (itemType == ESMF_STATEITEM_FIELD) then - if (NUOPC_IsConnected(importState, & - fieldName=trim(WRFHYDRO_FieldList(fieldIndex)%stateName))) then - connectedCount = connectedCount + 1 - endif - endif - endif - enddo + rc = ESMF_SUCCESS - if( connectedCount == 0 ) then - WRFHYDRO_RunModeGet = WRFHYDRO_Offline - elseif ( connectedCount == forcingCount ) then - WRFHYDRO_RunModeGet = WRFHYDRO_Coupled - elseif ( connectedCount < forcingCount ) then - WRFHYDRO_RunModeGet = WRFHYDRO_Hybrid + if (nlst(did)%rst_typ .eq. 0) then + restart = .FALSE. + else + restart = .TRUE. endif - end function +#ifdef DEBUG + call ESMF_LogWrite(MODNAME//": leaving "//METHOD, ESMF_LOGMSG_INFO) +#endif + + end subroutine !----------------------------------------------------------------------------- ! Conversion Utilities @@ -1348,7 +1015,7 @@ subroutine WRFHYDRO_TimeToString(time, timestr, rc) timestr = '' ! clear string if (len(timestr) < 19) then - call ESMF_LogSetError(ESMF_RC_ARG_OUTOFRANGE, & + call ESMF_LogSetError(ESMF_FAILURE, & msg=METHOD//": Time string is too short!", & file=FILENAME,rcToReturn=rc) return ! bail out @@ -1400,46 +1067,6 @@ function WRFHYDRO_TimeIntervalGetReal(timeInterval,rc) end function - !----------------------------------------------------------------------------- - ! Dictionary Utility - !----------------------------------------------------------------------------- - -#undef METHOD -#define METHOD "WRFHYDRO_FieldDictionaryAdd" - - subroutine WRFHYDRO_FieldDictionaryAdd(rc) - ! ARGUMENTS - integer,intent(out) :: rc - ! LOCAL VARIABLES - integer :: fIndex - logical :: isPresent - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": entered "//METHOD, ESMF_LOGMSG_INFO) -#endif - - rc = ESMF_SUCCESS - - do fIndex=1,size(WRFHYDRO_FieldList) - isPresent = NUOPC_FieldDictionaryHasEntry( & - trim(WRFHYDRO_FieldList(fIndex)%stdname), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - if (.not.isPresent) then - call NUOPC_FieldDictionaryAddEntry( & - trim(WRFHYDRO_FieldList(fIndex)%stdname), & - trim(WRFHYDRO_FieldList(fIndex)%units), & - rc=rc) - if (ESMF_STDERRORCHECK(rc)) return - endif - enddo - -#ifdef DEBUG - call ESMF_LogWrite(MODNAME//": leaving "//METHOD, ESMF_LOGMSG_INFO) -#endif - - end subroutine - !----------------------------------------------------------------------------- ! Log Utilities !----------------------------------------------------------------------------- diff --git a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h index bd847f8b6..5ca6f46c8 100644 --- a/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h +++ b/trunk/NDHMS/CPL/NUOPC_cpl/WRFHydro_NUOPC_Macros.h @@ -32,7 +32,7 @@ ! Define Missing Value !------------------------------------------------------------------------------- -#define MISSINGVALUE 999999 +#define ESMF_MISSING_VALUE 9.99e20_ESMF_KIND_R8 #define UNINITIALIZED -9999 !------------------------------------------------------------------------------- From 0a5a94c224ccaf6493cf57b356d4f3a7315286e1 Mon Sep 17 00:00:00 2001 From: Soren Rasmussen Date: Wed, 9 Mar 2022 12:06:23 -0800 Subject: [PATCH 05/25] Solution to fix the request to download google drive file --- tests/local/utils/gdrive_download.py | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/local/utils/gdrive_download.py b/tests/local/utils/gdrive_download.py index 7dae5475d..f8741fa25 100644 --- a/tests/local/utils/gdrive_download.py +++ b/tests/local/utils/gdrive_download.py @@ -9,7 +9,8 @@ def download_file_from_google_drive(id, destination): session = requests.Session() - response = session.get(URL, params={'id': id}, stream=True) + response = session.get(URL, params={'id': id, 'alt': 'media', 'confirm':'t'} + , stream=True) token = get_confirm_token(response) if token: @@ -54,4 +55,4 @@ def main(): download_file_from_google_drive(file_id, dest_file) if __name__ == "__main__": - main() \ No newline at end of file + main() From 616d1b5069970dd0b442ed775de60701b802a2b0 Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Tue, 10 Nov 2020 14:41:46 -0700 Subject: [PATCH 06/25] Move max SWE limit to a parameter in MPTABLE. --- .../NoahMP/phys/module_sf_noahmp_glacier.F | 16 ++++++++++------ .../NoahMP/phys/module_sf_noahmpdrv.F | 2 ++ .../NoahMP/phys/module_sf_noahmplsm.F | 12 ++++++++---- trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL | 1 + trunk/NDHMS/Routing/module_NWM_io_dict.F | 2 +- 5 files changed, 22 insertions(+), 11 deletions(-) diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F index c4250fd14..a9bfba175 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F @@ -126,6 +126,7 @@ SUBROUTINE NOAHMP_GLACIER (& ILOC ,JLOC ,COSZ ,NSNOW ,NSOIL ,DT , & ! IN : Time/Space/Model-related SFCTMP ,SFCPRS ,UU ,VV ,Q2 ,SOLDN , & ! IN : Forcing PRCP ,LWDN ,TBOT ,ZLVL ,FICEOLD ,ZSOIL , & ! IN : Forcing + SWE_LIMIT , & ! IN : Forcing QSNOW, QRAIN, SNEQVO, ALBOLD, CM, CH ,ISNOW , & ! IN/OUT : SNEQV ,SMC ,ZSNSO ,SNOWH ,SNICE ,SNLIQ , & ! IN/OUT : TG ,STC ,SH2O ,TAUSS ,QSFC , & ! IN/OUT : @@ -163,6 +164,7 @@ SUBROUTINE NOAHMP_GLACIER (& REAL , INTENT(IN) :: ZLVL !reference height (m) REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + REAL , INTENT(IN) :: SWE_LIMIT !maximum SWE limit (mm) #ifdef WRF_HYDRO REAL , INTENT(INOUT) :: sfcheadrt @@ -278,7 +280,7 @@ SUBROUTINE NOAHMP_GLACIER (& ! compute water budgets (water storages, ET components, and runoff) CALL WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in - QVAP ,QDEW ,FICEOLD,ZSOIL , & !in + QVAP ,QDEW ,FICEOLD,ZSOIL , SWE_LIMIT , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO ,FSH , & !inout RUNSRF ,RUNSUB ,QSNOW, QRAIN, PONDING1, PONDING2,QSNBOT,FPICE & !out @@ -2011,7 +2013,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & END SUBROUTINE PHASECHANGE_GLACIER ! ================================================================================================== SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in - QVAP ,QDEW ,FICEOLD,ZSOIL , & !in + QVAP ,QDEW ,FICEOLD,ZSOIL , SWE_LIMIT , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO ,FSH , & !inout RUNSRF ,RUNSUB ,QSNOW, QRAIN, PONDING1 ,PONDING2,QSNBOT,FPICE & !out @@ -2036,6 +2038,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in REAL, INTENT(INOUT) :: QDEW !soil surface dew rate[mm/s] REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD !ice fraction at last timestep REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + REAL, INTENT(IN) :: SWE_LIMIT !maximum SWE limit (mm) ! input/output INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers @@ -2140,7 +2143,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in CALL SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in SNOWHIN,QSNOW ,QSNFRO ,QSNSUB ,QRAIN , & !in - FICEOLD,ZSOIL , & !in + FICEOLD,ZSOIL ,SWE_LIMIT , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout SH2O ,SICE ,STC ,DZSNSO ,ZSNSO , & !inout FSH , & !inout @@ -2189,7 +2192,7 @@ END SUBROUTINE WATER_GLACIER ! ---------------------------------------------------------------------- SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in SNOWHIN,QSNOW ,QSNFRO ,QSNSUB ,QRAIN , & !in - FICEOLD,ZSOIL , & !in + FICEOLD,ZSOIL ,SWE_LIMIT , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout SH2O ,SICE ,STC ,DZSNSO ,ZSNSO , & !inout FSH , & !inout @@ -2210,6 +2213,7 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] REAL, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: FICEOLD!ice fraction at last timestep REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + REAL, INTENT(IN) :: SWE_LIMIT !maximum SWE limit (mm) ! input & output INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers @@ -2276,9 +2280,9 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in !to obtain equilibrium state of snow in glacier region - IF(SNEQV > 2000.) THEN ! 2000 mm -> maximum water depth + IF(SNEQV > SWE_LIMIT) THEN ! 2000 mm -> maximum water depth BDSNOW = SNICE(0) / DZSNSO(0) - SNOFLOW = (SNEQV - 2000.) + SNOFLOW = (SNEQV - SWE_LIMIT) SNICE(0) = SNICE(0) - SNOFLOW DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW SNOFLOW = SNOFLOW / DT diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F index b16126c51..1e1634784 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F @@ -715,6 +715,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related T_ML, P_ML, U_ML, V_ML, Q_ML, SWDN, & ! IN : Forcing PRCP, LWDN, TBOT, Z_ML, FICEOLD, ZSOIL, & ! IN : Forcing + parameters%swe_limit, & ! IN : Forcing QSNOW, QRAIN, SNEQVO, ALBOLD, CM, CH, ISNOW, & ! IN/OUT : SWE, SMC, ZSNSO, SNDPTH, SNICE, SNLIQ, & ! IN/OUT : TG, STC, SMH2O, TAUSS, QSFC1D, & ! IN/OUT : @@ -1176,6 +1177,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%BATS_VIS_DIR = BATS_VIS_DIR_TABLE parameters%BATS_NIR_DIR = BATS_NIR_DIR_TABLE parameters%RSURF_SNOW = RSURF_SNOW_TABLE + parameters%SWE_LIMIT = SWE_LIMIT_TABLE ! ---------------------------------------------------------------------- ! Transfer soil parameters diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F index de6d7819b..674707e24 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F @@ -303,6 +303,7 @@ MODULE MODULE_SF_NOAHMPLSM REAL :: BATS_NIR_DIR !cosz factor for direct NIR snow albedo Yang97 eqn. 16 REAL :: RSURF_SNOW !surface resistance for snow(s/m) REAL :: RSURF_EXP !exponent in the shape parameter for soil resistance option 1 + REAL :: SWE_LIMIT !maximum SWE limit (mm) !------------------------------------------------------------------------------------------! ! From the crop section of MPTABLE.TBL @@ -6094,9 +6095,9 @@ SUBROUTINE SNOWWATER (parameters,NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in !to obtain equilibrium state of snow in glacier region - IF(SNEQV > 5000.) THEN ! 5000 mm -> maximum water depth + IF(SNEQV > parameters%SWE_LIMIT) THEN ! 5000 mm -> maximum water depth BDSNOW = SNICE(0) / DZSNSO(0) - SNOFLOW = (SNEQV - 5000.) + SNOFLOW = (SNEQV - parameters%SWE_LIMIT) SNICE(0) = SNICE(0) - SNOFLOW DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW SNOFLOW = SNOFLOW / DT @@ -9261,6 +9262,7 @@ MODULE NOAHMP_TABLES REAL :: BATS_NIR_DIR_TABLE !cosz factor for direct NIR snow albedo Yang97 eqn. 16 REAL :: RSURF_SNOW_TABLE !surface resistance for snow(s/m) REAL :: RSURF_EXP_TABLE !exponent in the shape parameter for soil resistance option 1 + REAL :: SWE_LIMIT_TABLE !maximum SWE limit (mm) ! MPTABLE.TBL crop parameters @@ -9766,12 +9768,12 @@ subroutine read_mp_global_parameters() REAL :: CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC, & SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& - RSURF_SNOW,RSURF_EXP + RSURF_SNOW,RSURF_EXP,SWE_LIMIT NAMELIST / noahmp_global_parameters / CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC, & SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& - RSURF_SNOW,RSURF_EXP + RSURF_SNOW,RSURF_EXP,SWE_LIMIT ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. @@ -9796,6 +9798,7 @@ subroutine read_mp_global_parameters() BATS_NIR_DIR_TABLE = -1.E36 RSURF_SNOW_TABLE = -1.E36 RSURF_EXP_TABLE = -1.E36 + SWE_LIMIT_TABLE = -1.E36 inquire( file='MPTABLE.TBL', exist=file_named ) if ( file_named ) then @@ -9833,6 +9836,7 @@ subroutine read_mp_global_parameters() BATS_NIR_DIR_TABLE = BATS_NIR_DIR RSURF_SNOW_TABLE = RSURF_SNOW RSURF_EXP_TABLE = RSURF_EXP + SWE_LIMIT_TABLE = SWE_LIMIT end subroutine read_mp_global_parameters diff --git a/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL b/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL index 7d8c9e34c..df6556113 100644 --- a/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL +++ b/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL @@ -342,6 +342,7 @@ BATS_NIR_DIR = 0.4 !cosz factor for direct NIR snow albedo Yang97 eqn. 16 RSURF_SNOW = 50.0 !surface resistence for snow [s/m] RSURF_EXP = 5.0 !exponent in the shape parameter for soil resistance option 1 + SWE_LIMIT = 5000.0 !maximum SWE limit [mm] / diff --git a/trunk/NDHMS/Routing/module_NWM_io_dict.F b/trunk/NDHMS/Routing/module_NWM_io_dict.F index bb4cf009e..d7c55279d 100644 --- a/trunk/NDHMS/Routing/module_NWM_io_dict.F +++ b/trunk/NDHMS/Routing/module_NWM_io_dict.F @@ -1322,7 +1322,7 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 400.0d0, 400.0d0, 400.0d0, 400.0d0, 400.0d0, & !46-50 400.0d0, 400.0d0, 1.0d0, 1.0d0, 100000.0d0, & !51-55 1.0d0, 100.0d0, 100000.0d0, 100000.0d0, 400.0d0, & !56-60 - 1.0d0, 400.0d0, 1.0d0, 100.0d0, 100000.0d0, & !61-65 + 1.0d0, 400.0d0, 1.0d0, 100.0d0, 1000000.0d0, & !61-65 100.0d0, 10.0d0, 1.0d0, 100000.0d0, 100000.0d0, & !66-70 5.0d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0, & !71-76 5.0d0, 5.0d0, 5.0d0, 1000.0d0, 1000.0d0, & !76-80 From 758ea3888e6f35f53ff2670ecd031322e1ffcbeb Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Tue, 10 Nov 2020 14:47:10 -0700 Subject: [PATCH 07/25] Fix for energy NAs over large snowpacks due to very small numbers being rounded to 0, so number/number=NA instead of 1. Switched to an if statement. --- trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F index 674707e24..8e7a4bd9f 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F @@ -1106,7 +1106,11 @@ SUBROUTINE PHENOLOGY (parameters,VEGTYP ,croptype, SNOWH , TV , LAT , YEA IF(parameters%HVT> 0. .AND. parameters%HVT <= 1.0) THEN !MB: change to 1.0 and 0.2 to reflect SNOWHC = parameters%HVT*EXP(-SNOWH/0.2) ! changes to HVT in MPTABLE - FB = MIN(SNOWH,SNOWHC)/SNOWHC + if (SNOWHC .le. SNOWH) then ! AD: change this min to an if then since precision was leading to divide by 0s + FB = 1. + else + FB = SNOWH/SNOWHC + endif ENDIF ELAI = LAI*(1.-FB) From b757c38f4c2cf33a992dd74584595bf40da7ec06 Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Thu, 17 Mar 2022 09:22:53 -0600 Subject: [PATCH 08/25] Add priority snow parameters to 2d parameter file and add new scamax param (#594) --- .../IO_code/module_NoahMP_hrldas_driver.F | 14 ++++- .../NoahMP/IO_code/module_hrldas_netcdf_io.F | 58 ++++++++++++++++++- .../NoahMP/phys/module_sf_noahmpdrv.F | 19 +++++- .../NoahMP/phys/module_sf_noahmplsm.F | 10 +++- .../NDHMS/Land_models/NoahMP/run/MPTABLE.TBL | 1 + 5 files changed, 94 insertions(+), 8 deletions(-) diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F index c3cbcd247..78bed4bce 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F @@ -159,6 +159,11 @@ module module_NoahMP_hrldas_driver REAL, ALLOCATABLE, DIMENSION(:,:) :: axaj_2D ! Tension water distribution inflection parameter [-] REAL, ALLOCATABLE, DIMENSION(:,:) :: bxaj_2D ! Tension water distribution shape parameter [-] REAL, ALLOCATABLE, DIMENSION(:,:) :: xxaj_2D ! Free water distribution shape parameter [-] + REAL, ALLOCATABLE, DIMENSION(:,:) :: ssi_2D ! liquid water holding capacity for snowpack (m3/m3) + REAL, ALLOCATABLE, DIMENSION(:,:) :: snowretfac_2D ! snowpack water release timescale factor (1/s) + REAL, ALLOCATABLE, DIMENSION(:,:) :: tau0_2D ! tau0 from Yang97 eqn. 10a + REAL, ALLOCATABLE, DIMENSION(:,:) :: rsurfsnow_2D ! surface resistence for snow [s/m] + REAL, ALLOCATABLE, DIMENSION(:,:) :: scamax_2D ! maximum fractional snow covered area (0.0-1.0) #endif ! INOUT (with generic LSM equivalent) (as defined in WRF) @@ -747,6 +752,11 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) ALLOCATE ( axaj_2D (XSTART:XEND,YSTART:YEND) ) ! Tension water distribution inflection parameter [-] ALLOCATE ( bxaj_2D (XSTART:XEND,YSTART:YEND) ) ! Tension water distribution shape parameter [-] ALLOCATE ( xxaj_2D (XSTART:XEND,YSTART:YEND) ) ! Free water distribution shape parameter [-] + ALLOCATE ( ssi_2D (XSTART:XEND,YSTART:YEND) ) ! liquid water holding capacity for snowpack (m3/m3) + ALLOCATE ( snowretfac_2D (XSTART:XEND,YSTART:YEND) ) ! snowpack water release timescale factor (1/s) + ALLOCATE ( tau0_2D (XSTART:XEND,YSTART:YEND) ) ! tau0 from Yang97 eqn. 10a + ALLOCATE ( rsurfsnow_2D (XSTART:XEND,YSTART:YEND) ) ! surface resistence for snow [s/m] + ALLOCATE ( scamax_2D (XSTART:XEND,YSTART:YEND) ) ! maximum fractional snow covered area (0.0-1.0) #endif ! INOUT (with generic LSM equivalent) (as defined in WRF) @@ -1092,7 +1102,8 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) CALL READ_3D_SOIL(noah_lsm%SPATIAL_FILENAME, XSTART, XEND, YSTART, YEND, & NSOIL,BEXP_3D,SMCDRY_3D,SMCWLT_3D,SMCREF_3D,SMCMAX_3D, & DKSAT_3D,DWSAT_3D,PSISAT_3D,QUARTZ_3D,REFDK_2D,REFKDT_2D,& - SLOPE_2D,CWPVT_2D,VCMX25_2D,MP_2D,HVT_2D,MFSNO_2D,RSURFEXP_2D) + SLOPE_2D,CWPVT_2D,VCMX25_2D,MP_2D,HVT_2D,MFSNO_2D,RSURFEXP_2D, & + SSI_2D,SNOWRETFAC_2D,TAU0_2D,RSURFSNOW_2D,SCAMAX_2D) if (noah_lsm%runoff_option == 7) then CALL READ_XAJ_RUNOFF(noah_lsm%SPATIAL_FILENAME,XSTART, XEND, YSTART, YEND, & @@ -1670,6 +1681,7 @@ subroutine land_driver_exe(itime, state) REFDK_2D,REFKDT_2D,SLOPE_2D, & CWPVT_2D,VCMX25_2D,MP_2D,HVT_2D,MFSNO_2D,RSURFEXP_2D, & AXAJ_2D,BXAJ_2D,XXAJ_2D, & + SSI_2D,SNOWRETFAC_2D,TAU0_2D,RSURFSNOW_2D,SCAMAX_2D, & #endif #ifdef WRF_HYDRO sfcheadrt,INFXSRT,soldrain, & !O diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F index c2fb15900..10de07c19 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F @@ -837,7 +837,8 @@ end subroutine read_xaj_runoff subroutine read_3d_soil(spatial_filename,xstart, xend,ystart, yend, & nsoil,bexp_3d,smcdry_3d,smcwlt_3d,smcref_3d,smcmax_3d, & dksat_3d,dwsat_3d,psisat_3d,quartz_3d,refdk_2d,refkdt_2d,slope_2d,& - cwpvt_2d,vcmx25_2d,mp_2d,hvt_2d,mfsno_2d,rsurfexp_2d) + cwpvt_2d,vcmx25_2d,mp_2d,hvt_2d,mfsno_2d,rsurfexp_2d, & + ssi_2d,snowretfac_2d,tau0_2d,rsurfsnow_2d,scamax_2d) implicit none character(len=*), intent(in) :: spatial_filename integer, intent(in) :: xstart, xend, ystart, yend @@ -860,6 +861,11 @@ subroutine read_3d_soil(spatial_filename,xstart, xend,ystart, yend, & real, dimension(xstart:xend,ystart:yend), intent(out) :: hvt_2d real, dimension(xstart:xend,ystart:yend), intent(out) :: mfsno_2d real, dimension(xstart:xend,ystart:yend), intent(out) :: rsurfexp_2d + real, dimension(xstart:xend,ystart:yend), intent(out) :: ssi_2d + real, dimension(xstart:xend,ystart:yend), intent(out) :: snowretfac_2d + real, dimension(xstart:xend,ystart:yend), intent(out) :: tau0_2d + real, dimension(xstart:xend,ystart:yend), intent(out) :: rsurfsnow_2d + real, dimension(xstart:xend,ystart:yend), intent(out) :: scamax_2d character(len=24) :: name character(len=256) :: units @@ -1089,6 +1095,56 @@ subroutine read_3d_soil(spatial_filename,xstart, xend,ystart, yend, & iret = nf90_get_var(ncid, varid, rsurfexp_2d, start=(/xstart,ystart/), count=(/xend-xstart+1,yend-ystart+1/)) ! + name = "ssi" + iret = nf90_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'ncid = ', ncid + write(*,*) "FATAL ERROR: In read_3d_soil(): Problem finding variable '"//trim(name)//"' in NetCDF file: " // trim(spatial_filename) + stop + endif + + iret = nf90_get_var(ncid, varid, ssi_2d, start=(/xstart,ystart/), count=(/xend-xstart+1,yend-ystart+1/)) +! + name = "snowretfac" + iret = nf90_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'ncid = ', ncid + write(*,*) "FATAL ERROR: In read_3d_soil(): Problem finding variable '"//trim(name)//"' in NetCDF file: " // trim(spatial_filename) + stop + endif + + iret = nf90_get_var(ncid, varid, snowretfac_2d, start=(/xstart,ystart/), count=(/xend-xstart+1,yend-ystart+1/)) +! + name = "tau0" + iret = nf90_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'ncid = ', ncid + write(*,*) "FATAL ERROR: In read_3d_soil(): Problem finding variable '"//trim(name)//"' in NetCDF file: " // trim(spatial_filename) + stop + endif + + iret = nf90_get_var(ncid, varid, tau0_2d, start=(/xstart,ystart/), count=(/xend-xstart+1,yend-ystart+1/)) +! + name = "rsurfsnow" + iret = nf90_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'ncid = ', ncid + write(*,*) "FATAL ERROR: In read_3d_soil(): Problem finding variable '"//trim(name)//"' in NetCDF file: " // trim(spatial_filename) + stop + endif + + iret = nf90_get_var(ncid, varid, rsurfsnow_2d, start=(/xstart,ystart/), count=(/xend-xstart+1,yend-ystart+1/)) +! + name = "scamax" + iret = nf90_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'ncid = ', ncid + write(*,*) "FATAL ERROR: In read_3d_soil(): Problem finding variable '"//trim(name)//"' in NetCDF file: " // trim(spatial_filename) + stop + endif + + iret = nf90_get_var(ncid, varid, scamax_2d, start=(/xstart,ystart/), count=(/xend-xstart+1,yend-ystart+1/)) + ! Close the NetCDF file ierr = nf90_close(ncid) if (ierr /= 0) stop "FATAL ERROR: In module_hrldas_netcdf_io.F read_3d_soil() - NF90_CLOSE" diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F index 1e1634784..65a5a8df4 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F @@ -64,6 +64,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REFDK_2D,REFKDT_2D,SLOPE_2D, & CWPVT_2D,VCMX25_2D,MP_2D,HVT_2D,MFSNO_2D,RSURFEXP_2D, & AXAJ_2D,BXAJ_2D,XXAJ_2D, & + SSI_2D,SNOWRETFAC_2D,TAU0_2D,RSURFSNOW_2D,SCAMAX_2D, & #endif #ifdef WRF_HYDRO sfcheadrt,INFXSRT,soldrain, & @@ -165,6 +166,11 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: AXAJ_2D ! Xinanjiang: Tension water distribution inflection parameter [-] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: BXAJ_2D ! Xinanjiang: Tension water distribution shape parameter [-] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XXAJ_2D ! Xinanjiang: Free water distribution shape parameter [-] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: SSI_2D ! liquid water holding capacity for snowpack (m3/m3) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: SNOWRETFAC_2D ! snowpack water release timescale factor (1/s) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: TAU0_2D ! tau0 from Yang97 eqn. 10a + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: RSURFSNOW_2D ! surface resistence for snow [s/m] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: SCAMAX_2D ! max fractional snow covered area (0.0-1.0) #endif ! INOUT (with generic LSM equivalent) @@ -667,6 +673,11 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN parameters%axaj = AXAJ_2D(I,J) ! Xinanjiang: Tension water distribution inflection parameter [-] parameters%bxaj = BXAJ_2D(I,J) ! Xinanjiang: Tension water distribution shape parameter [-] parameters%xxaj = XXAJ_2D(I,J) ! Xinanjiang: Free water distribution shape parameter [-] + parameters%ssi = SSI_2D(I,J) ! liquid water holding capacity for snowpack (m3/m3) + parameters%snow_ret_fac = SNOWRETFAC_2D(I,J) ! snowpack water release timescale factor (1/s) + parameters%tau0 = TAU0_2D(I,J) ! tau0 from Yang97 eqn. 10a + parameters%rsurf_snow = RSURFSNOW_2D(I,J) ! surface resistence for snow [s/m] + parameters%scamax = SCAMAX_2D(I,J) ! maximum fractional snow covered area (0.0-1.0) #endif CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,CROPTYPE,parameters) @@ -1162,10 +1173,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%TIMEAN = TIMEAN_TABLE parameters%FSATMX = FSATMX_TABLE parameters%Z0SNO = Z0SNO_TABLE - parameters%SSI = SSI_TABLE - parameters%SNOW_RET_FAC = SNOW_RET_FAC_TABLE parameters%SWEMX = SWEMX_TABLE - parameters%TAU0 = TAU0_TABLE parameters%GRAIN_GROWTH = GRAIN_GROWTH_TABLE parameters%EXTRA_GROWTH = EXTRA_GROWTH_TABLE parameters%DIRT_SOOT = DIRT_SOOT_TABLE @@ -1206,6 +1214,11 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%AXAJ = AXAJ_TABLE(SOILTYPE) parameters%BXAJ = BXAJ_TABLE(SOILTYPE) parameters%XXAJ = XXAJ_TABLE(SOILTYPE) + parameters%SSI = SSI_TABLE + parameters%SNOW_RET_FAC = SNOW_RET_FAC_TABLE + parameters%TAU0 = TAU0_TABLE + parameters%RSURF_SNOW = RSURF_SNOW_TABLE + parameters%SCAMAX = SCAMAX_TABLE #endif ! ---------------------------------------------------------------------- ! Transfer GENPARM parameters diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F index 8e7a4bd9f..f4d1a6945 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F @@ -303,6 +303,7 @@ MODULE MODULE_SF_NOAHMPLSM REAL :: BATS_NIR_DIR !cosz factor for direct NIR snow albedo Yang97 eqn. 16 REAL :: RSURF_SNOW !surface resistance for snow(s/m) REAL :: RSURF_EXP !exponent in the shape parameter for soil resistance option 1 + REAL :: SCAMAX !maximum fractional snow covered area (0.0-1.0) REAL :: SWE_LIMIT !maximum SWE limit (mm) !------------------------------------------------------------------------------------------! @@ -1827,7 +1828,7 @@ SUBROUTINE ENERGY (parameters,ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in IF(SNOWH.GT.0.) THEN BDSNO = SNEQV / SNOWH FMELT = (BDSNO/100.)**parameters%MFSNO - FSNO = TANH( SNOWH /(2.5* Z0 * FMELT)) + FSNO = parameters%SCAMAX * TANH( SNOWH /(2.5* Z0 * FMELT)) ENDIF ! ground roughness length @@ -9266,6 +9267,7 @@ MODULE NOAHMP_TABLES REAL :: BATS_NIR_DIR_TABLE !cosz factor for direct NIR snow albedo Yang97 eqn. 16 REAL :: RSURF_SNOW_TABLE !surface resistance for snow(s/m) REAL :: RSURF_EXP_TABLE !exponent in the shape parameter for soil resistance option 1 + REAL :: SCAMAX_TABLE !maximum fractional snow covered area (0.0-1.0) REAL :: SWE_LIMIT_TABLE !maximum SWE limit (mm) ! MPTABLE.TBL crop parameters @@ -9772,12 +9774,12 @@ subroutine read_mp_global_parameters() REAL :: CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC, & SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& - RSURF_SNOW,RSURF_EXP,SWE_LIMIT + RSURF_SNOW,RSURF_EXP,SWE_LIMIT,SCAMAX NAMELIST / noahmp_global_parameters / CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC, & SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& - RSURF_SNOW,RSURF_EXP,SWE_LIMIT + RSURF_SNOW,RSURF_EXP,SWE_LIMIT,SCAMAX ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. @@ -9802,6 +9804,7 @@ subroutine read_mp_global_parameters() BATS_NIR_DIR_TABLE = -1.E36 RSURF_SNOW_TABLE = -1.E36 RSURF_EXP_TABLE = -1.E36 + SCAMAX_TABLE = -1.E36 SWE_LIMIT_TABLE = -1.E36 inquire( file='MPTABLE.TBL', exist=file_named ) @@ -9840,6 +9843,7 @@ subroutine read_mp_global_parameters() BATS_NIR_DIR_TABLE = BATS_NIR_DIR RSURF_SNOW_TABLE = RSURF_SNOW RSURF_EXP_TABLE = RSURF_EXP + SCAMAX_TABLE = SCAMAX SWE_LIMIT_TABLE = SWE_LIMIT end subroutine read_mp_global_parameters diff --git a/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL b/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL index df6556113..a7f9020cf 100644 --- a/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL +++ b/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL @@ -342,6 +342,7 @@ BATS_NIR_DIR = 0.4 !cosz factor for direct NIR snow albedo Yang97 eqn. 16 RSURF_SNOW = 50.0 !surface resistence for snow [s/m] RSURF_EXP = 5.0 !exponent in the shape parameter for soil resistance option 1 + SCAMAX = 1.0 !maximum fractional snow covered area [0-1] SWE_LIMIT = 5000.0 !maximum SWE limit [mm] / From 462652553bd4294219b35faab951ce82bce0b8cf Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Mon, 24 Aug 2020 17:12:46 -0600 Subject: [PATCH 09/25] Initial commit of adding nexp free parameter to hydro2dtbl. Only setup for subsurface option 1. --- trunk/NDHMS/Data_Rec/rt_include.inc | 1 + trunk/NDHMS/Routing/Noah_distr_routing.F | 12 ++++++++++-- .../Routing/Noah_distr_routing_subsurface.F | 13 +++++++------ .../Subsurface/module_subsurface_properties.F | 17 +++++++++++++++++ trunk/NDHMS/Routing/module_HYDRO_io.F | 2 ++ trunk/NDHMS/Routing/module_RT.F | 3 +++ 6 files changed, 40 insertions(+), 8 deletions(-) diff --git a/trunk/NDHMS/Data_Rec/rt_include.inc b/trunk/NDHMS/Data_Rec/rt_include.inc index d3ba3fd46..bca48858d 100644 --- a/trunk/NDHMS/Data_Rec/rt_include.inc +++ b/trunk/NDHMS/Data_Rec/rt_include.inc @@ -243,6 +243,7 @@ INTEGER, allocatable, DIMENSION(:,:) :: VEGTYP REAL, allocatable, DIMENSION(:,:) :: OV_ROUGH2d !REAL, allocatable, DIMENSION(:) :: SLDPTH + REAL, allocatable, DIMENSION(:,:) :: NEXP !!! define constant/parameter real :: ov_rough(50)!, ZSOIL(100) ! ZSOIL moved to subsurface properties module diff --git a/trunk/NDHMS/Routing/Noah_distr_routing.F b/trunk/NDHMS/Routing/Noah_distr_routing.F index 5d7253d2b..1e89ba872 100644 --- a/trunk/NDHMS/Routing/Noah_distr_routing.F +++ b/trunk/NDHMS/Routing/Noah_distr_routing.F @@ -887,6 +887,7 @@ subroutine disaggregateDomain_drv(did) RT_DOMAIN(did)%INFXSRT, rt_domain(did)%dist_lsm(:,:,9), & RT_DOMAIN(did)%SMCMAX1, RT_DOMAIN(did)%SMCREF1, & RT_DOMAIN(did)%SMCWLT1, RT_DOMAIN(did)%VEGTYP, RT_DOMAIN(did)%LKSAT, & + RT_DOMAIN(did)%NEXP, & rt_domain(did)%overland%properties%distance_to_neighbor, & RT_DOMAIN(did)%INFXSWGT, & RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, & @@ -900,6 +901,7 @@ subroutine disaggregateDomain_drv(did) rt_domain(did)%overland%properties%roughness, & rt_domain(did)%overland%streams_and_lakes%lake_mask, & rt_domain(did)%subsurface%properties%lksatrt, & + rt_domain(did)%subsurface%properties%nexprt, & RT_DOMAIN(did)%OV_ROUGH2d, & RT_DOMAIN(did)%subsurface%properties%sldpth, & RT_DOMAIN(did)%soiltypRT, RT_DOMAIN(did)%soiltyp, & @@ -924,9 +926,9 @@ end subroutine disaggregateDomain_drv !=================================================================================================== subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & SICE, SMC, SH2OX, INFXSRT, area_lsm, SMCMAX1, SMCREF1, & - SMCWLT1, VEGTYP, LKSAT, dist,INFXSWGT,OVROUGHRTFAC, & + SMCWLT1, VEGTYP, LKSAT, NEXP, dist,INFXSWGT,OVROUGHRTFAC, & LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & - SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT, OV_ROUGH2d, & + SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT, NEXPRT, OV_ROUGH2d, & SLDPTH, soiltypRT, soiltyp, elrt, iswater) #ifdef MPP_LAND use module_mpp_land, only: left_id,down_id,right_id, & @@ -953,6 +955,7 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & real, intent(in), dimension(IX,JX) :: SMCREF1 ! coarse grid field capacity real, intent(in), dimension(IX,JX) :: SMCWLT1 ! coarse grid wilting point real, intent(in), dimension(IX,JX) :: LKSAT ! coarse grid lateral ksat (m/s) + real, intent(in), dimension(IX,JX) :: NEXP ! coarse grid n exponent real, intent(in), dimension(ix,jx) :: OV_ROUGH2d ! overland roughness ! LSM states: real, intent(in), dimension(IX,JX,NSOIL) :: SMC ! total soil moisture (m3/m3) @@ -981,6 +984,7 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & real, intent(out), dimension(IXRT,JXRT,NSOIL) :: SMCREFRT ! field capacity on routing grid real, intent(out), dimension(IXRT,JXRT,NSOIL) :: SMCWLTRT ! wilting point on routing grid real, intent(out), dimension(IXRT,JXRT) :: LKSATRT ! lateral ksat on the routing grid (m/s) + real, intent(out), dimension(IXRT,JXRT) :: NEXPRT ! n exponent on the routing grid real, intent(out), dimension(IXRT,JXRT) :: OVROUGHRT ! overland roughness on the routing grid ! States: real, intent(out), dimension(IX,JX,NSOIL) :: SICE ! soil ice content on coarse grid (m3/m3) @@ -1193,6 +1197,9 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & smScaleFact = min(1., smScaleFact) !make sure scale factor doesn't go over 1 LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * smScaleFact + ! n exponent for subsurface routing + nexprt(ixxrt,jyyrt) = nexp(i,j) + ! Lake mask !DJG set up lake mask... !--- modify to make lake mask large here, but not one of the routed lakes!!! @@ -1264,6 +1271,7 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & #ifdef MPP_LAND call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99) call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(NEXPRT,IXRT,JXRT,99) call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99) call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99) do i = 1, NSOIL diff --git a/trunk/NDHMS/Routing/Noah_distr_routing_subsurface.F b/trunk/NDHMS/Routing/Noah_distr_routing_subsurface.F index 1d9d08dba..7b606cbd7 100644 --- a/trunk/NDHMS/Routing/Noah_distr_routing_subsurface.F +++ b/trunk/NDHMS/Routing/Noah_distr_routing_subsurface.F @@ -244,7 +244,8 @@ SUBROUTINE SUBSFC_RTNG(subrt_data, subrt_static, subrt_input, subrt_output, CWAT ! if(subrt_static%rt_option .eq. 1) then CALL ROUTE_SUBSURFACE1(subrt_data%properties%distance_to_neighbor, & subrt_data%properties%zwattablrt, & - subrt_data%properties%lksatrt, subrt_data%properties%soldeprt, & + subrt_data%properties%lksatrt, subrt_data%properties%nexprt, & + subrt_data%properties%soldeprt, & subrt_static%IXRT, subrt_static%JXRT, & subrt_data%properties%surface_slope, & subrt_data%properties%max_surface_slope_index, & @@ -563,7 +564,7 @@ END SUBROUTINE FINDZWAT ! - Adapted from Wigmosta, 1994 ! - Returns qsub=DQSUB which in turn becomes SUBFLO in head calc. !=================================================================================================== -SUBROUTINE ROUTE_SUBSURFACE1(dist, z, latksat, soldep, & +SUBROUTINE ROUTE_SUBSURFACE1(dist, z, latksat, nexp, soldep, & XX, YY, SO8RT, SO8RT_D, & CWATAVAIL, SUBDT, QSUBDRY, QSUBDRYT, qsub) #ifdef MPP_LAND @@ -581,6 +582,7 @@ SUBROUTINE ROUTE_SUBSURFACE1(dist, z, latksat, soldep, & real, intent(in), dimension(XX,YY) :: z ! depth to water table (m) real, intent(in), dimension(XX,YY) :: latksat ! lateral saturated hydraulic conductivity (m/s) + real, intent(in), dimension(XX,YY) :: nexp ! latksat decay coefficient real, intent(in), dimension(XX,YY) :: soldep ! soil depth (m) real, intent(in), dimension(XX,YY,8) :: SO8RT ! terrain slope in all directions (m/m) integer, intent(in), dimension(XX,YY,3) :: SO8RT_D ! steepest terrain slope cell (i, j, index) @@ -603,7 +605,6 @@ SUBROUTINE ROUTE_SUBSURFACE1(dist, z, latksat, soldep, & ! Local arrays real*8, DIMENSION(XX,YY) :: qsub_tmp, QSUBDRY_tmp ! temp trackers for fluxes (m3/s) ! Local parameters - real, parameter :: nexp=1.0 ! local power law exponent real :: tmp_dist(9) ! Initialize temp variables @@ -651,7 +652,7 @@ SUBROUTINE ROUTE_SUBSURFACE1(dist, z, latksat, soldep, & endif ! Do the rest if the lowest grid can be found. - hh = ( 1 - ( z(i,j) / soldep(i,j) ) ) ** nexp + hh = ( 1 - ( z(i,j) / soldep(i,j) ) ) ** nexp(i,j) ksat = latksat(i,j) if (hh .lt. 0.) then @@ -662,7 +663,7 @@ SUBROUTINE ROUTE_SUBSURFACE1(dist, z, latksat, soldep, & ! Calculate flux from cell ! AD_NOTE: gamma and qqsub are negative when flow is out of cell - gamma = -1.0 * ( (dist(i,j,index) * ksat * soldep(i,j)) / nexp ) * beta + gamma = -1.0 * ( (dist(i,j,index) * ksat * soldep(i,j)) / nexp(i,j) ) * beta qqsub = gamma * hh ! AD_NOTE: Moved this water available constraint from outside qsub calc loop @@ -686,7 +687,7 @@ SUBROUTINE ROUTE_SUBSURFACE1(dist, z, latksat, soldep, & "so8RT=",so8RT(i,j,index),"latksat=",ksat, & "tan(beta)=",tan(beta),i,j,z(i,j),z(IXX0,JYY0) print*, "ixx0=",ixx0, "jyy0=",jyy0 - print*, "soldep =", soldep(i,j), "nexp=",nexp + print*, "soldep =", soldep(i,j), "nexp=",nexp(i,j) call hydro_stop("In ROUTE_SUBSURFACE1() - qqsub should be negative") endif diff --git a/trunk/NDHMS/Routing/Subsurface/module_subsurface_properties.F b/trunk/NDHMS/Routing/Subsurface/module_subsurface_properties.F index d2f898942..03cc08db4 100644 --- a/trunk/NDHMS/Routing/Subsurface/module_subsurface_properties.F +++ b/trunk/NDHMS/Routing/Subsurface/module_subsurface_properties.F @@ -47,6 +47,9 @@ module module_subsurface_properties ! centerpoint distance to each neighbor (m) real, pointer, dimension(:,:,:) :: distance_to_neighbor => null() + ! disaggregated lksat decay exponent + real, allocatable, dimension(:,:) :: nexprt + contains procedure :: init => subsurface_properties_init @@ -131,6 +134,14 @@ subroutine subsurface_properties_init(this,ix,jx,nsoil,overland_data) allocation_error = .true. end if + ! allocate the array only if not already allocated + if ( .not. allocated(this%nexprt) ) then + allocate( this%nexprt(ix,jx) ) + this%nexprt = 1.0 + else + allocation_error = .true. + end if + if ( allocation_error ) & write(0,*) "attempt to allocate data in members of subsurface properties structure& &that where already allocated. The allocated members where not changed" @@ -204,6 +215,12 @@ subroutine subsurface_properties_destroy(this) allocation_error = .true. end if + ! only deallocated if already allocated + if ( allocated(this%nexprt) ) then + deallocate( this%nexprt) + else + allocation_error = .true. + end if if ( allocation_error ) & write(0,*) "attempt to deallocate data in members of subsurface properties structure& diff --git a/trunk/NDHMS/Routing/module_HYDRO_io.F b/trunk/NDHMS/Routing/module_HYDRO_io.F index 8a0b3f937..a63cdbd93 100644 --- a/trunk/NDHMS/Routing/module_HYDRO_io.F +++ b/trunk/NDHMS/Routing/module_HYDRO_io.F @@ -11157,6 +11157,7 @@ subroutine hdtbl_out(did) call hdtbl_out_nc(did,ncid, count,count_flag,"SMCWLT1",rt_domain(did)%SMCWLT1,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"LKSAT",rt_domain(did)%LKSAT,"",ixd,jxd) + call hdtbl_out_nc(did,ncid, count,count_flag,"NEXP",rt_domain(did)%NEXP,"",ixd,jxd) end do end subroutine hdtbl_out @@ -11168,6 +11169,7 @@ subroutine hdtbl_in_nc(did) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCWLT1",rt_domain(did)%SMCWLT1) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"LKSAT",rt_domain(did)%LKSAT) + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"NEXP",rt_domain(did)%NEXP) end subroutine hdtbl_in_nc subroutine read2dlsm(did,file,varName,varOut) implicit none diff --git a/trunk/NDHMS/Routing/module_RT.F b/trunk/NDHMS/Routing/module_RT.F index e329d3cf6..b69cca37e 100644 --- a/trunk/NDHMS/Routing/module_RT.F +++ b/trunk/NDHMS/Routing/module_RT.F @@ -291,6 +291,9 @@ subroutine rt_allocate(did,ix,jx,ixrt,jxrt,nsoil,CHANRTSWCRT) allocate( rt_domain(did)%SOLDRAIN (IX,JX) ) rt_domain(did)%SOLDRAIN = 0.0 + allocate( rt_domain(did)%NEXP (IX,JX) ) + rt_domain(did)%NEXP = 1.0 + end if ! neither channel_only nor channelBucket_only From 4095f916a81c2ef08d086b638d82ec01291e6f1b Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Tue, 24 Aug 2021 19:43:54 -0600 Subject: [PATCH 10/25] Fix issue with default nexp value when no parameter found in input file. --- trunk/NDHMS/Routing/module_HYDRO_io.F | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/trunk/NDHMS/Routing/module_HYDRO_io.F b/trunk/NDHMS/Routing/module_HYDRO_io.F index a63cdbd93..29e9662c1 100644 --- a/trunk/NDHMS/Routing/module_HYDRO_io.F +++ b/trunk/NDHMS/Routing/module_HYDRO_io.F @@ -624,7 +624,7 @@ subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & character(len=*), intent(in) :: name integer, intent(in) :: ncid integer, intent(in) :: idim, jdim - real, dimension(idim,jdim), intent(out) :: array + real, dimension(idim,jdim), intent(inout) :: array character(len=256), intent(out) :: units ! fatal_IF_ERROR: an input code value: ! .TRUE. if an error in reading the data should stop the program. @@ -11164,14 +11164,21 @@ end subroutine hdtbl_out subroutine hdtbl_in_nc(did) implicit none integer :: did - call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCMAX1",rt_domain(did)%SMCMAX1) - call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCREF1",rt_domain(did)%SMCREF1) - call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCWLT1",rt_domain(did)%SMCWLT1) - call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D) - call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"LKSAT",rt_domain(did)%LKSAT) - call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"NEXP",rt_domain(did)%NEXP) + integer :: ierr + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCMAX1",rt_domain(did)%SMCMAX1,ierr) + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCREF1",rt_domain(did)%SMCREF1,ierr) + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCWLT1",rt_domain(did)%SMCWLT1,ierr) + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D,ierr) + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"LKSAT",rt_domain(did)%LKSAT,ierr) + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"NEXP",rt_domain(did)%NEXP,ierr) + ! Letting this variable be optional and setting to global default value if not found + if (ierr /= 0) then + write(6,*) "WARNING (hydtbl_in_nc): NEXP not found so setting to global 1.0" + rt_domain(did)%NEXP = 1.0 + endif end subroutine hdtbl_in_nc -subroutine read2dlsm(did,file,varName,varOut) + +subroutine read2dlsm(did,file,varName,varOut,ierr) implicit none integer :: did, ncid ,ierr,iret character(len=*) :: file,varName From 0306cd12caa25131455fd45aa2103047d5c35818 Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Thu, 24 Feb 2022 14:08:53 -0700 Subject: [PATCH 11/25] Fix parallel issue with nexp being overwritten on non-io cores. --- trunk/NDHMS/Routing/module_HYDRO_io.F | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/trunk/NDHMS/Routing/module_HYDRO_io.F b/trunk/NDHMS/Routing/module_HYDRO_io.F index 29e9662c1..dc28e9c25 100644 --- a/trunk/NDHMS/Routing/module_HYDRO_io.F +++ b/trunk/NDHMS/Routing/module_HYDRO_io.F @@ -11179,11 +11179,13 @@ subroutine hdtbl_in_nc(did) end subroutine hdtbl_in_nc subroutine read2dlsm(did,file,varName,varOut,ierr) +use module_mpp_land,only: mpp_land_bcast_int1 implicit none - integer :: did, ncid ,ierr,iret + integer :: did, ncid , iret character(len=*) :: file,varName real,dimension(:,:) :: varOut character(len=256) :: units + integer, intent(out) :: ierr #ifdef MPP_LAND real,allocatable,dimension(:,:) :: tmpArr if(my_id .eq. io_id) then @@ -11196,6 +11198,7 @@ subroutine read2dlsm(did,file,varName,varOut,ierr) allocate(tmpArr(1,1)) endif call decompose_data_real (tmpArr,varOut) + call mpp_land_bcast_int1(ierr) deallocate(tmpArr) #else iret = nf90_open(trim(file), NF90_NOWRITE, ncid) From e5bff605519f4a4b893e732834599de1957c151d Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Mon, 21 Mar 2022 09:23:44 -0600 Subject: [PATCH 12/25] New channel option to bypass actual channel routing solver and just produce inflows (for t-route coupling) (#609) Add channel_option=5 to run NWM musk-cunge channel routing option without running actual channel routing solver. Only channel inputs are calculated. --- trunk/NDHMS/Data_Rec/module_namelist.F | 4 ++++ trunk/NDHMS/Data_Rec/namelist.inc | 2 ++ trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F | 2 +- trunk/NDHMS/OrchestratorLayer/config.f90 | 6 ++++++ trunk/NDHMS/Routing/module_NWM_io.F | 8 ++++++++ trunk/NDHMS/Routing/module_channel_routing.F | 10 ++++++++-- trunk/NDHMS/template/HYDRO/hydro.namelist | 3 ++- 7 files changed, 31 insertions(+), 4 deletions(-) diff --git a/trunk/NDHMS/Data_Rec/module_namelist.F b/trunk/NDHMS/Data_Rec/module_namelist.F index 758db5c85..1e7afc8df 100644 --- a/trunk/NDHMS/Data_Rec/module_namelist.F +++ b/trunk/NDHMS/Data_Rec/module_namelist.F @@ -720,6 +720,10 @@ subroutine rt_nlst_check(nlst) call hydro_stop('hydro.namelist ERROR: Invalid CHANRTSWCRT specified') endif if(nlst%CHANRTSWCRT .eq. 1) then + if ( nlst%channel_option .eq. 5 ) then + nlst%channel_option = 2 + nlst%channel_bypass = .TRUE. + endif if( (nlst%channel_option .lt. 1 ) .or. (nlst%channel_option .gt. 3) ) then call hydro_stop('hydro.namelist ERROR: Invalid channel_option specified') endif diff --git a/trunk/NDHMS/Data_Rec/namelist.inc b/trunk/NDHMS/Data_Rec/namelist.inc index 9598ef7bf..7584a5920 100644 --- a/trunk/NDHMS/Data_Rec/namelist.inc +++ b/trunk/NDHMS/Data_Rec/namelist.inc @@ -74,6 +74,8 @@ integer :: rtFlag integer ::khour + logical :: channel_bypass = .FALSE. + !#ifdef WRF_HYDRO_NUDGING character(len=256) :: nudgingParamFile character(len=256) :: netwkReExFile diff --git a/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F b/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F index ea5fb3f0d..d132136d9 100644 --- a/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F +++ b/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F @@ -960,7 +960,7 @@ subroutine driveChannelRouting(did) , rt_domain(did)%nlinksize, nlst(did)%OVRTSWCRT & , nlst(did)%SUBRTSWCRT & , nlst(did)%channel_only , nlst(did)%channelBucket_only & - ) + , nlst(did)%channel_bypass ) else diff --git a/trunk/NDHMS/OrchestratorLayer/config.f90 b/trunk/NDHMS/OrchestratorLayer/config.f90 index 136030f50..c594bd443 100644 --- a/trunk/NDHMS/OrchestratorLayer/config.f90 +++ b/trunk/NDHMS/OrchestratorLayer/config.f90 @@ -158,6 +158,8 @@ module config_base integer :: nLastObs integer :: bucket_loss + logical :: channel_bypass = .FALSE. + contains procedure, pass(self) :: check => rt_nlst_check @@ -332,6 +334,10 @@ subroutine rt_nlst_check(self) call hydro_stop('hydro.namelist ERROR: Invalid CHANRTSWCRT specified') endif if(self%CHANRTSWCRT .eq. 1) then + if ( self%channel_option .eq. 5 ) then + self%channel_option = 2 + self%channel_bypass = .TRUE. + endif if( (self%channel_option .lt. 1 ) .or. (self%channel_option .gt. 3) ) then call hydro_stop('hydro.namelist ERROR: Invalid channel_option specified') endif diff --git a/trunk/NDHMS/Routing/module_NWM_io.F b/trunk/NDHMS/Routing/module_NWM_io.F index 48a688ea9..67eaba620 100644 --- a/trunk/NDHMS/Routing/module_NWM_io.F +++ b/trunk/NDHMS/Routing/module_NWM_io.F @@ -212,6 +212,14 @@ subroutine output_chrt_NWM(domainId) call nwmCheck(diagFlag,1,'ERROR: Invalid IOC flag provided by namelist file.') endif + ! Turn off streamflow, velocity, head for special external channel routing config + if (nlst(domainId)%channel_bypass) then + fileMeta%outFlag(1) = 0 + fileMeta%outFlag(2) = 0 + fileMeta%outFlag(4) = 0 + fileMeta%outFlag(5) = 0 + endif + ! call the GetModelConfigType function modelConfigType = GetModelConfigType(nlst(1)%io_config_outputs) diff --git a/trunk/NDHMS/Routing/module_channel_routing.F b/trunk/NDHMS/Routing/module_channel_routing.F index 8ebf788de..ff26557e4 100644 --- a/trunk/NDHMS/Routing/module_channel_routing.F +++ b/trunk/NDHMS/Routing/module_channel_routing.F @@ -1610,7 +1610,8 @@ subroutine drive_CHANNEL_RSL(did, UDMP_OPT,KT, IXRT,JXRT, & , qSfcLatRunoff, qBucket & , QLateral, velocity, qloss & , HLINK & - , nsize , OVRTSWCRT, SUBRTSWCRT, channel_only, channelBucket_only) + , nsize , OVRTSWCRT, SUBRTSWCRT, channel_only, channelBucket_only, & + channel_bypass) use module_UDMAP, only: LNUMRSL, LUDRSL use config_base, only: nlst @@ -1652,6 +1653,8 @@ subroutine drive_CHANNEL_RSL(did, UDMP_OPT,KT, IXRT,JXRT, & real , intent(INOUT), dimension(:,:) :: QLINK real , intent(INOUT), dimension(:) :: HLINK + logical, intent(in) :: channel_bypass + #ifdef WRF_HYDRO_NUDGING !! inout for applying previous nudge to upstream components of flow at gages real, intent(inout), dimension(:) :: nudge @@ -1882,6 +1885,8 @@ subroutine drive_CHANNEL_RSL(did, UDMP_OPT,KT, IXRT,JXRT, & if(nlst(1)%output_channelBucket_influx .eq. 3) & accBucket(1:NLINKSL) = accBucket(1:NLINKSL) + qout_gwsubbas(1:NLINKSL) * DT +! Skip this section if we are NOT running any actual channel routing +if (.not. channel_bypass) then !--------------------------------------------- ! QLateral = QLateral / nsteps @@ -1909,7 +1914,6 @@ subroutine drive_CHANNEL_RSL(did, UDMP_OPT,KT, IXRT,JXRT, & endif #endif - do k = 1,NLINKSL Quc = 0 @@ -2026,6 +2030,8 @@ subroutine drive_CHANNEL_RSL(did, UDMP_OPT,KT, IXRT,JXRT, & end do ! nsteps +endif ! channel_bypass + if (KT .eq. 1) KT = KT + 1 #ifdef MPP_LAND diff --git a/trunk/NDHMS/template/HYDRO/hydro.namelist b/trunk/NDHMS/template/HYDRO/hydro.namelist index 380c36878..8afa8eee9 100644 --- a/trunk/NDHMS/template/HYDRO/hydro.namelist +++ b/trunk/NDHMS/template/HYDRO/hydro.namelist @@ -137,7 +137,8 @@ rt_option = 1 ! Switch to activate channel routing...(0=no, 1=yes) CHANRTSWCRT = 1 -! Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded +! Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded, +! 5=Bypass channel routing (only active for UDMP=1 and reach configuration) channel_option = 3 ! Specify the reach file for reach-based routing options (e.g.: "Route_Link.nc") From 6f314bc9f38301f61790a87f429bfeadfed80aae Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Mon, 21 Mar 2022 10:02:14 -0600 Subject: [PATCH 13/25] New impervious runoff adjustment options (#608) * Remove hard-coding of urban soil properties for imperv options != 0 * Add impervious fraction variable. * Add in impervious adjustment to surface runoff and infiltration partitioning. * Add in adjustment for effective imperviousness. * Add imperv parameter to template MPTABLE. * Add high-res impervious fraction ingest. * Replace hard-coded FCR with variable impervious. * Adjust top layer FCR to match impervious configuration options. * Overland roughness adjustment by impervious fraction. Need to move this whole parameter regridding outside of disagg routine - only needs to be done once. * Add in retdep impervious adjustment. * Add namelist option for impervious parameter adjustments. * Make impervious param read optional and remove Sutherland option (works fine, just not enough data to parameterize). * Setup new option to more clearly separate old model behavior from no imperv adjustment. Fix overwriting of frozen soil impermeable variable. * Update default urban impervious fraction to match code assumption. * Set IMPERVFRAC to be required if imperv_adj=1 --- trunk/NDHMS/Data_Rec/module_namelist.F | 11 +++- trunk/NDHMS/Data_Rec/namelist.inc | 2 +- trunk/NDHMS/Data_Rec/rt_include.inc | 1 + trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F | 40 ++++++------- .../IO_code/module_NoahMP_hrldas_driver.F | 15 ++++- .../NoahMP/IO_code/module_hrldas_netcdf_io.F | 38 +++++++++++++ .../NoahMP/phys/module_sf_noahmpdrv.F | 30 +++++++--- .../NoahMP/phys/module_sf_noahmplsm.F | 57 ++++++++++++++++--- .../NDHMS/Land_models/NoahMP/run/MPTABLE.TBL | 1 + trunk/NDHMS/OrchestratorLayer/config.f90 | 15 ++++- trunk/NDHMS/Routing/Noah_distr_routing.F | 21 +++++-- trunk/NDHMS/Routing/module_HYDRO_io.F | 16 +++++- trunk/NDHMS/Routing/module_RT.F | 16 ++++-- trunk/NDHMS/template/HYDRO/hydro.namelist | 3 + trunk/NDHMS/template/NoahMP/namelist.hrldas | 1 + 15 files changed, 213 insertions(+), 54 deletions(-) diff --git a/trunk/NDHMS/Data_Rec/module_namelist.F b/trunk/NDHMS/Data_Rec/module_namelist.F index 1e7afc8df..18cf4bfba 100644 --- a/trunk/NDHMS/Data_Rec/module_namelist.F +++ b/trunk/NDHMS/Data_Rec/module_namelist.F @@ -46,7 +46,7 @@ subroutine read_rt_nlst(nlst) GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & sys_cpl, rst_typ, rst_bi_in, rst_bi_out, & gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, gwsoilcpl, & - UDMP_OPT, io_form_outputs, bucket_loss + UDMP_OPT, io_form_outputs, bucket_loss, imperv_adj real:: DTRT_TER,DTRT_CH,dxrt, gwChanCondConstIn, gwChanCondConstOut, gwIhShift character(len=256) :: route_topo_f="" character(len=256) :: route_chan_f="" @@ -138,7 +138,7 @@ subroutine read_rt_nlst(nlst) CHRTOUT_DOMAIN,CHANOBS_DOMAIN,CHRTOUT_GRID,LSMOUT_DOMAIN,& RTOUT_DOMAIN, output_gw, outlake, & frxst_pts_out, udmap_file, UDMP_OPT, GWBUCKPARM_file, bucket_loss, & - io_config_outputs, io_form_outputs, hydrotbl_f, t0OutputFlag, output_channelBucket_influx + io_config_outputs, io_form_outputs, hydrotbl_f, t0OutputFlag, output_channelBucket_influx, imperv_adj #ifdef WRF_HYDRO_NUDGING namelist /NUDGING_nlist/ nudgingParamFile, netwkReExFile, & @@ -173,6 +173,7 @@ subroutine read_rt_nlst(nlst) reservoir_rfc_forecasts = .FALSE. reservoir_rfc_forecasts_lookback_hours = 24 reservoir_type_specified = .FALSE. + imperv_adj = 0 #ifdef WRF_HYDRO_NUDGING ! Default values for NUDGING_nlist @@ -359,6 +360,7 @@ subroutine read_rt_nlst(nlst) call mpp_land_bcast_int1(RTOUT_DOMAIN) call mpp_land_bcast_int1(UDMP_OPT) call mpp_land_bcast_int1(reservoir_data_ingest) + call mpp_land_bcast_int1(imperv_adj) #ifdef WRF_HYDRO_NUDGING call mpp_land_bcast_char(256, nudgingParamFile ) call mpp_land_bcast_char(256, netwkReExFile ) @@ -450,6 +452,7 @@ subroutine read_rt_nlst(nlst) nlst%rst_bi_out = rst_bi_out nlst%order_to_write = order_to_write nlst%compound_channel = compound_channel + nlst%imperv_adj = imperv_adj ! files nlst%route_topo_f = route_topo_f @@ -533,6 +536,7 @@ subroutine read_rt_nlst(nlst) write(6,*) " nlst%gwstrmfil ", gwstrmfil write(6,*) " nlst%geo_finegrid_flnm ", geo_finegrid_flnm write(6,*) " nlst%reservoir_data_ingest ", reservoir_data_ingest + write(6,*) " nlst%imperv_adj ", imperv_adj #ifdef WRF_HYDRO_NUDGING write(6,*) " nlst%nudgingParamFile ", trim(nudgingParamFile) write(6,*) " nlst%netWkReExFile ", trim(netWkReExFile) @@ -784,6 +788,9 @@ subroutine rt_nlst_check(nlst) inquire(file=trim(nlst%route_lake_f),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: route_lake_f not found.') endif + if( (nlst%imperv_adj .lt. 0 ) .or. (nlst%imperv_adj .gt. 1) ) then + call hydro_stop('hydro.namelist ERROR: Invalid imperv_adj specified') + endif ! Only allow lakes to be ran with gridded routing or NWM routing if(len(trim(nlst%route_lake_f)) .ne. 0) then if(nlst%channel_option .ne. 3) then diff --git a/trunk/NDHMS/Data_Rec/namelist.inc b/trunk/NDHMS/Data_Rec/namelist.inc index 7584a5920..1e598cc1a 100644 --- a/trunk/NDHMS/Data_Rec/namelist.inc +++ b/trunk/NDHMS/Data_Rec/namelist.inc @@ -34,7 +34,7 @@ SUBRTSWCRT, OVRTSWCRT, AGGFACTRT, & GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & sys_cpl, gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, & - gwsoilcpl, UDMP_OPT, bucket_loss + gwsoilcpl, UDMP_OPT, bucket_loss, imperv_adj logical:: GwPreDiag, GwSpinUp real:: DTRT_TER,DTRT_CH, DTCT, dxrt0, gwChanCondConstIn, gwChanCondConstOut, gwIhShift character(len=256) :: route_topo_f="" diff --git a/trunk/NDHMS/Data_Rec/rt_include.inc b/trunk/NDHMS/Data_Rec/rt_include.inc index bca48858d..1ccc7c793 100644 --- a/trunk/NDHMS/Data_Rec/rt_include.inc +++ b/trunk/NDHMS/Data_Rec/rt_include.inc @@ -66,6 +66,7 @@ REAL, allocatable, DIMENSION(:,:) :: INFXSRT,LKSAT,LKSATRT !REAL, allocatable, DIMENSION(:,:) :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC ! SFCHEADSUBRT, INFXSUBRT moved to overland control module REAL, allocatable, DIMENSION(:,:) :: LKSATFAC + REAL, allocatable, DIMENSION(:,:) :: IMPERVFRAC !REAL, allocatable, DIMENSION(:,:) :: SOLDEPRT ! QSUBRT, QSUBBDRYRT moved to subsurface io module, SOLDEPRT, ZWATTABLRT move to susurface properties REAL, allocatable, DIMENSION(:,:) :: SUB_RESID REAL, allocatable, DIMENSION(:,:) :: q_sfcflx_x,q_sfcflx_y diff --git a/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F b/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F index d132136d9..daeaa1c35 100644 --- a/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F +++ b/trunk/NDHMS/HYDRO_drv/module_HYDRO_drv.F @@ -40,7 +40,7 @@ module module_HYDRO_drv use module_gw_gw2d_data, only: gw2d use module_channel_routing, only: drive_channel, drive_channel_rsl use orchestrator_base - use config_base, only: nlst + use config_base, only: nlst, noah_lsm use module_routing, only: getChanDim, landrt_ini use module_HYDRO_utils use module_lsm_forcing, only: geth_newdate @@ -1770,21 +1770,15 @@ subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) do i = 1, RT_DOMAIN(did)%ix !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) - IF(rt_domain(did)%VEGTYP(i,j) == rt_domain(did)%isurban ) THEN ! urban - rt_domain(did)%SMCMAX1(i,j) = 0.45 - rt_domain(did)%SMCREF1(i,j) = 0.42 - rt_domain(did)%SMCWLT1(i,j) = 0.40 - else - rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) - rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) - rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) - !ADCHANGE: Add some sanity checks in case calibration knocks the order of these out of sequence. - !The min diffs were pulled from the existing HYDRO.TBL defaults. - !Currently water is 0, so enforcing 0 as the absolute min. - rt_domain(did)%SMCMAX1(i,j) = min(rt_domain(did)%SMCMAX1(i,j), 1.0) - rt_domain(did)%SMCREF1(i,j) = max(min(rt_domain(did)%SMCREF1(i,j), rt_domain(did)%SMCMAX1(i,j) - 0.01), 0.0) - rt_domain(did)%SMCWLT1(i,j) = max(min(rt_domain(did)%SMCWLT1(i,j), rt_domain(did)%SMCREF1(i,j) - 0.01), 0.0) - ENDIF + rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) + rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) + rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) + !ADCHANGE: Add some sanity checks in case calibration knocks the order of these out of sequence. + !The min diffs were pulled from the existing HYDRO.TBL defaults. + !Currently water is 0, so enforcing 0 as the absolute min. + rt_domain(did)%SMCMAX1(i,j) = min(rt_domain(did)%SMCMAX1(i,j), 1.0) + rt_domain(did)%SMCREF1(i,j) = max(min(rt_domain(did)%SMCREF1(i,j), rt_domain(did)%SMCMAX1(i,j) - 0.01), 0.0) + rt_domain(did)%SMCWLT1(i,j) = max(min(rt_domain(did)%SMCWLT1(i,j), rt_domain(did)%SMCREF1(i,j) - 0.01), 0.0) IF(rt_domain(did)%VEGTYP(i,j) > 0 ) THEN ! created 2d ov_rough rt_domain(did)%OV_ROUGH2d(i,j) = RT_DOMAIN(did)%OV_ROUGH(rt_domain(did)%VEGTYP(I,J)) endif @@ -1796,12 +1790,14 @@ subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) ! input from HYDRO.TBL.nc file print*, "reading from hydrotbl_f(HYDRO.TBL.nc) file ...." call hdtbl_in_nc(did) - !ADCHANGE: For consistency, mirror urban and param value checks used in table read - where (rt_domain(did)%VEGTYP == rt_domain(did)%isurban) - rt_domain(did)%SMCMAX1 = 0.45 - rt_domain(did)%SMCREF1 = 0.42 - rt_domain(did)%SMCWLT1 = 0.40 - endwhere + if (noah_lsm%imperv_option .eq. 9) then + !ADCHANGE: For consistency, mirror urban and param value checks used in table read + where (rt_domain(did)%VEGTYP == rt_domain(did)%isurban) + rt_domain(did)%SMCMAX1 = 0.45 + rt_domain(did)%SMCREF1 = 0.42 + rt_domain(did)%SMCWLT1 = 0.40 + endwhere + endif where (rt_domain(did)%SMCMAX1 .gt. 1.0) rt_domain(did)%SMCMAX1 = 1.0 rt_domain(did)%SMCREF1 = max(min(rt_domain(did)%SMCREF1, rt_domain(did)%SMCMAX1 - 0.01), 0.0) rt_domain(did)%SMCWLT1 = max(min(rt_domain(did)%SMCWLT1, rt_domain(did)%SMCREF1 - 0.01), 0.0) diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F index 78bed4bce..571bbd83e 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F @@ -118,6 +118,8 @@ module module_NoahMP_hrldas_driver INTEGER :: IOPT_SOIL ! soil configuration option INTEGER :: IOPT_PEDO ! soil pedotransfer function option INTEGER :: IOPT_CROP ! crop model option (0->none; 1->Liu et al.) + INTEGER :: IOPT_IMPERV !imperviousness infiltration adjustment (0->none; 1->total; + !2->Alley&Veenhuis; 9->old) REAL, ALLOCATABLE, DIMENSION(:,:,:) :: T_PHY ! 3D atmospheric temperature valid at mid-levels [K] REAL, ALLOCATABLE, DIMENSION(:,:,:) :: QV_CURR ! 3D water vapor mixing ratio [kg/kg_dry] REAL, ALLOCATABLE, DIMENSION(:,:,:) :: U_PHY ! 3D U wind component [m/s] @@ -159,6 +161,7 @@ module module_NoahMP_hrldas_driver REAL, ALLOCATABLE, DIMENSION(:,:) :: axaj_2D ! Tension water distribution inflection parameter [-] REAL, ALLOCATABLE, DIMENSION(:,:) :: bxaj_2D ! Tension water distribution shape parameter [-] REAL, ALLOCATABLE, DIMENSION(:,:) :: xxaj_2D ! Free water distribution shape parameter [-] + REAL, ALLOCATABLE, DIMENSION(:,:) :: imperv_2D ! impervious fraction REAL, ALLOCATABLE, DIMENSION(:,:) :: ssi_2D ! liquid water holding capacity for snowpack (m3/m3) REAL, ALLOCATABLE, DIMENSION(:,:) :: snowretfac_2D ! snowpack water release timescale factor (1/s) REAL, ALLOCATABLE, DIMENSION(:,:) :: tau0_2D ! tau0 from Yang97 eqn. 10a @@ -448,6 +451,7 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) IOPT_SOIL = noah_lsm%soil_data_option IOPT_PEDO = noah_lsm%pedotransfer_option IOPT_CROP = noah_lsm%crop_option + IOPT_IMPERV = noah_lsm%imperv_option khour = noah_lsm%khour @@ -752,6 +756,7 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) ALLOCATE ( axaj_2D (XSTART:XEND,YSTART:YEND) ) ! Tension water distribution inflection parameter [-] ALLOCATE ( bxaj_2D (XSTART:XEND,YSTART:YEND) ) ! Tension water distribution shape parameter [-] ALLOCATE ( xxaj_2D (XSTART:XEND,YSTART:YEND) ) ! Free water distribution shape parameter [-] + ALLOCATE ( imperv_2D (XSTART:XEND,YSTART:YEND) ) ! impervious fraction ALLOCATE ( ssi_2D (XSTART:XEND,YSTART:YEND) ) ! liquid water holding capacity for snowpack (m3/m3) ALLOCATE ( snowretfac_2D (XSTART:XEND,YSTART:YEND) ) ! snowpack water release timescale factor (1/s) ALLOCATE ( tau0_2D (XSTART:XEND,YSTART:YEND) ) ! tau0 from Yang97 eqn. 10a @@ -1109,6 +1114,12 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) CALL READ_XAJ_RUNOFF(noah_lsm%SPATIAL_FILENAME,XSTART, XEND, YSTART, YEND, & AXAJ_2D,BXAJ_2D,XXAJ_2D) end if + + if (noah_lsm%imperv_option > 0 .and. noah_lsm%imperv_option < 9) then + CALL READ_IMPERV(noah_lsm%SPATIAL_FILENAME,XSTART, XEND, YSTART, YEND, & + IMPERV_2D) + end if + #endif !------------------------------------------------------------------------ @@ -1652,7 +1663,8 @@ subroutine land_driver_exe(itime, state) XLAND, XICE, XICE_THRESHOLD, & IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF, IOPT_TBOT, IOPT_STC, & - IOPT_GLA, IOPT_RSF,IOPT_SOIL,IOPT_PEDO, IOPT_CROP, IZ0TLND, & + IOPT_GLA, IOPT_RSF,IOPT_SOIL,IOPT_PEDO, IOPT_CROP, & + IOPT_IMPERV, IZ0TLND, & T_PHY, QV_CURR, U_PHY, V_PHY, SWDOWN, GLW, & P8W, RAINBL, SR, & TSK, HFX, QFX, LH, GRDFLX, SMSTAV, & @@ -1681,6 +1693,7 @@ subroutine land_driver_exe(itime, state) REFDK_2D,REFKDT_2D,SLOPE_2D, & CWPVT_2D,VCMX25_2D,MP_2D,HVT_2D,MFSNO_2D,RSURFEXP_2D, & AXAJ_2D,BXAJ_2D,XXAJ_2D, & + IMPERV_2D, & SSI_2D,SNOWRETFAC_2D,TAU0_2D,RSURFSNOW_2D,SCAMAX_2D, & #endif #ifdef WRF_HYDRO diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F index 10de07c19..588b836a3 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F @@ -832,6 +832,44 @@ subroutine read_xaj_runoff(spatial_filename,xstart, xend,ystart, yend, end subroutine read_xaj_runoff +!--------------------------------------------------------------------------------------------------------- + + subroutine read_imperv(spatial_filename, xstart, xend, ystart, yend, imperv_2d) + + implicit none + character(len=*), intent(in) :: spatial_filename + integer, intent(in) :: xstart, xend, ystart, yend + real, dimension(xstart:xend,ystart:yend), intent(out) :: imperv_2d + + character(len=24) :: name + character(len=256) :: units + integer :: ierr,iret, varid + integer :: ncid + real, dimension(xstart:xend,ystart:yend) :: xdum +!------------------------------------------------------------------------------------------------------ + + ierr = nf90_open(spatial_filename, NF90_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("FATAL ERROR: In read_imperv(): Problem opening soil file: ''", A, "''")') trim(spatial_filename) + stop + endif + + name = "imperv" + iret = nf90_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'ncid = ', ncid + write(*,*) "FATAL ERROR: In read_imperv(): Problem finding variable '"//trim(name)//"' in NetCDF file: " // trim(spatial_filename) + stop + endif + + iret = nf90_get_var(ncid, varid, imperv_2d, start=(/xstart,ystart/), count=(/xend-xstart+1,yend-ystart+1/)) +! + ! Close the NetCDF file + ierr = nf90_close(ncid) + if (ierr /= 0) stop "FATAL ERROR: In module_hrldas_netcdf_io.F read_imperv() - NF90_CLOSE" + + end subroutine read_imperv + !--------------------------------------------------------------------------------------------------------- subroutine read_3d_soil(spatial_filename,xstart, xend,ystart, yend, & diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F index 65a5a8df4..2a438986c 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F @@ -35,7 +35,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN XLAND, XICE,XICE_THRES, & ! IN : Vegetation/Soil characteristics IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & ! IN : User options IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF,IOPT_TBOT, IOPT_STC, & ! IN : User options - IOPT_GLA, IOPT_RSF, IOPT_SOIL,IOPT_PEDO,IOPT_CROP, IZ0TLND, & ! IN : User options + IOPT_GLA, IOPT_RSF, IOPT_SOIL,IOPT_PEDO,IOPT_CROP, & ! IN : User options + IOPT_IMPERV, IZ0TLND, & ! IN : User options T3D, QV3D, U_PHY, V_PHY, SWDOWN, GLW, & ! IN : Forcing P8W3D,PRECIP_IN, SR, & ! IN : Forcing TSK, HFX, QFX, LH, GRDFLX, SMSTAV, & ! IN/OUT LSM eqv @@ -64,6 +65,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REFDK_2D,REFKDT_2D,SLOPE_2D, & CWPVT_2D,VCMX25_2D,MP_2D,HVT_2D,MFSNO_2D,RSURFEXP_2D, & AXAJ_2D,BXAJ_2D,XXAJ_2D, & + IMPERV_2D, & SSI_2D,SNOWRETFAC_2D,TAU0_2D,RSURFSNOW_2D,SCAMAX_2D, & #endif #ifdef WRF_HYDRO @@ -123,6 +125,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN INTEGER, INTENT(IN ) :: IOPT_SOIL ! soil configuration option INTEGER, INTENT(IN ) :: IOPT_PEDO ! soil pedotransfer function option INTEGER, INTENT(IN ) :: IOPT_CROP ! crop model option (0->none; 1->Liu et al.) + INTEGER, INTENT(IN ) :: IOPT_IMPERV !imperviousness infiltration adjustment (0->none; 1->total; + !9->old) INTEGER, INTENT(IN ) :: IZ0TLND ! option of Chen adjustment of Czil (not used) REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: T3D ! 3D atmospheric temperature valid at mid-levels [K] REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: QV3D ! 3D water vapor mixing ratio [kg/kg_dry] @@ -166,6 +170,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: AXAJ_2D ! Xinanjiang: Tension water distribution inflection parameter [-] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: BXAJ_2D ! Xinanjiang: Tension water distribution shape parameter [-] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XXAJ_2D ! Xinanjiang: Free water distribution shape parameter [-] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: IMPERV_2D ! impervious fraction REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: SSI_2D ! liquid water holding capacity for snowpack (m3/m3) REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: SNOWRETFAC_2D ! snowpack water release timescale factor (1/s) REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: TAU0_2D ! tau0 from Yang97 eqn. 10a @@ -486,7 +491,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN CALL NOAHMP_OPTIONS(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & IOPT_INF ,IOPT_RAD ,IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC , & - IOPT_RSF ,IOPT_SOIL ,IOPT_PEDO ,IOPT_CROP ) + IOPT_RSF ,IOPT_SOIL ,IOPT_PEDO ,IOPT_CROP, IOPT_IMPERV ) IPRINT = .false. ! debug printout @@ -673,13 +678,14 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN parameters%axaj = AXAJ_2D(I,J) ! Xinanjiang: Tension water distribution inflection parameter [-] parameters%bxaj = BXAJ_2D(I,J) ! Xinanjiang: Tension water distribution shape parameter [-] parameters%xxaj = XXAJ_2D(I,J) ! Xinanjiang: Free water distribution shape parameter [-] + parameters%imperv = IMPERV_2D(I,J) ! impervious fraction parameters%ssi = SSI_2D(I,J) ! liquid water holding capacity for snowpack (m3/m3) parameters%snow_ret_fac = SNOWRETFAC_2D(I,J) ! snowpack water release timescale factor (1/s) parameters%tau0 = TAU0_2D(I,J) ! tau0 from Yang97 eqn. 10a parameters%rsurf_snow = RSURFSNOW_2D(I,J) ! surface resistence for snow [s/m] parameters%scamax = SCAMAX_2D(I,J) ! maximum fractional snow covered area (0.0-1.0) #endif - CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,CROPTYPE,parameters) + CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,CROPTYPE,parameters,iopt_imperv) GRAIN = 0.0 ! mass of grain [g/m2] GDD = 0.0 ! growing degree days @@ -1016,7 +1022,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN END SUBROUTINE noahmplsm !------------------------------------------------------ -SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE,parameters) +SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE,parameters,iopt_imperv) USE NOAHMP_TABLES USE MODULE_SF_NOAHMPLSM @@ -1028,6 +1034,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, INTEGER, INTENT(IN) :: SLOPETYPE INTEGER, INTENT(IN) :: SOILCOLOR INTEGER, INTENT(IN) :: CROPTYPE + INTEGER, INTENT(IN) :: iopt_imperv type (noahmp_parameters), intent(inout) :: parameters @@ -1214,6 +1221,11 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%AXAJ = AXAJ_TABLE(SOILTYPE) parameters%BXAJ = BXAJ_TABLE(SOILTYPE) parameters%XXAJ = XXAJ_TABLE(SOILTYPE) + IF (parameters%URBAN_FLAG) THEN + parameters%IMPERV = IMPERV_URBAN_TABLE + ELSE + parameters%IMPERV = 0.0 + ENDIF parameters%SSI = SSI_TABLE parameters%SNOW_RET_FAC = SNOW_RET_FAC_TABLE parameters%TAU0 = TAU0_TABLE @@ -1231,10 +1243,12 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%KDT = parameters%REFKDT * parameters%DKSAT(1) / parameters%REFDK IF(parameters%URBAN_FLAG)THEN ! Hardcoding some urban parameters for soil - parameters%SMCMAX = 0.45 - parameters%SMCREF = 0.42 - parameters%SMCWLT = 0.40 - parameters%SMCDRY = 0.40 + if (iopt_imperv .eq. 9) then + parameters%SMCMAX = 0.45 + parameters%SMCREF = 0.42 + parameters%SMCWLT = 0.40 + parameters%SMCDRY = 0.40 + endif parameters%CSOIL = 3.E6 ENDIF diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F index f4d1a6945..8ac28df68 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F @@ -169,6 +169,13 @@ MODULE MODULE_SF_NOAHMPLSM ! **0 -> No crop model, will run default dynamic vegetation ! 1 -> Liu, et al. 2016 + INTEGER :: OPT_IMPERV ! options for imperviousness infiltration adjustment + ! 0 -> no imperviousness adjustment + ! 1 -> use total imperviousness + ! 2 -> use effective imperviousness from Alley & Veenhuis + ! **9 -> older model behavior (urban soil parameter adjustment + ! and mixed runoff adjustment depending on runoff scheme) + !------------------------------------------------------------------------------------------! ! Physical Constants: ! !------------------------------------------------------------------------------------------! @@ -303,6 +310,7 @@ MODULE MODULE_SF_NOAHMPLSM REAL :: BATS_NIR_DIR !cosz factor for direct NIR snow albedo Yang97 eqn. 16 REAL :: RSURF_SNOW !surface resistance for snow(s/m) REAL :: RSURF_EXP !exponent in the shape parameter for soil resistance option 1 + REAL :: IMPERV !impervious fraction REAL :: SCAMAX !maximum fractional snow covered area (0.0-1.0) REAL :: SWE_LIMIT !maximum SWE limit (mm) @@ -6909,6 +6917,9 @@ SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in REAL :: SMCTOT !2-m averaged soil moisture (m3/m3) REAL :: DZTOT !2-m soil depth (m) REAL, PARAMETER :: A = 4.0 + + REAL :: imperv_eff !local impervious adjustment (fraction, 0-1) + ! ---------------------------------------------------------------------- RUNSRF = 0.0 PDDUM = 0.0 @@ -6953,7 +6964,20 @@ SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in !surface runoff and infiltration rate using different schemes !jref impermable surface at urban - IF ( parameters%urban_flag ) FCR(1)= 0.95 +! We are updating surface runoff adjustment as an area-mean +! of impervious and frozen soil impermeable adjustments. + IF (OPT_IMPERV == 1) THEN + ! Use total imperviousness + imperv_eff = parameters%imperv + FCR(1) = imperv_eff + (1.0 - imperv_eff) * FCR(1) + ELSE IF (OPT_IMPERV == 2) THEN + ! Effective imperviousness from Alley & Veenhuis + imperv_eff = 0.0015 * ( (100. * parameters%imperv)**1.41 ) + FCR(1) = imperv_eff + (1.0 - imperv_eff) * FCR(1) + ELSE IF (OPT_IMPERV == 9) THEN + ! Fixed value for urban type (older configuration) + IF ( parameters%urban_flag ) FCR(1)=0.95 + END IF IF(OPT_RUN == 1) THEN FFF = 6.0 @@ -7206,6 +7230,7 @@ SUBROUTINE INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in REAL :: INFMAX REAL, DIMENSION(1:NSOIL) :: DMAX INTEGER, PARAMETER :: CVFRZ = 3 + REAL :: imperv_eff !effective imperviousness ! -------------------------------------------------------------------------------- IF (QINSUR > 0.0) THEN @@ -7253,14 +7278,26 @@ SUBROUTINE INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in INFMAX = INFMAX * FCR -! jref for urban areas -! IF ( parameters%urban_flag ) INFMAX == INFMAX * 0.05 +! imperviousness adjustment + + IF (OPT_IMPERV == 1) THEN + ! Use total imperviousness + imperv_eff = parameters%imperv + ELSE IF (OPT_IMPERV == 2) THEN + ! Effective imperviousness from Alley & Veenhuis + imperv_eff = 0.0015 * ( (100. * parameters%imperv)**1.41 ) + ELSE ! options 0 and 9 both have no impervious adjustment + ! No imperviousness adjustment + imperv_eff = 0.0 + END IF + + RUNSRF = QINSUR * imperv_eff CALL WDFCND2 (parameters,WDF,WCND,SH2O(1),SICEMAX,1) INFMAX = MAX (INFMAX,WCND) INFMAX = MIN (INFMAX,PX) - RUNSRF= MAX(0., QINSUR - INFMAX) + RUNSRF = RUNSRF + MAX(0., (QINSUR * (1. - imperv_eff)) - INFMAX) PDDUM = QINSUR - RUNSRF END IF @@ -9080,7 +9117,7 @@ END SUBROUTINE PSN_CROP subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & - iopt_rsf , iopt_soil, iopt_pedo, iopt_crop ) + iopt_rsf , iopt_soil, iopt_pedo, iopt_crop, iopt_imperv ) implicit none @@ -9102,6 +9139,8 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc INTEGER, INTENT(IN) :: iopt_soil !soil parameters set-up option INTEGER, INTENT(IN) :: iopt_pedo !pedo-transfer function (1->Saxton and Rawls) INTEGER, INTENT(IN) :: iopt_crop !crop model option (0->none; 1->Liu et al.) + INTEGER, INTENT(IN) :: iopt_imperv !imperviousness infiltration adjustment (0->none; 1->total imperviousness; + !2->Alley&Veenhuis) ! ------------------------------------------------------------------------------------------------- @@ -9122,6 +9161,7 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc opt_soil = iopt_soil opt_pedo = iopt_pedo opt_crop = iopt_crop + opt_imperv = iopt_imperv end subroutine noahmp_options @@ -9267,6 +9307,7 @@ MODULE NOAHMP_TABLES REAL :: BATS_NIR_DIR_TABLE !cosz factor for direct NIR snow albedo Yang97 eqn. 16 REAL :: RSURF_SNOW_TABLE !surface resistance for snow(s/m) REAL :: RSURF_EXP_TABLE !exponent in the shape parameter for soil resistance option 1 + REAL :: IMPERV_URBAN_TABLE !imperviousness fraction REAL :: SCAMAX_TABLE !maximum fractional snow covered area (0.0-1.0) REAL :: SWE_LIMIT_TABLE !maximum SWE limit (mm) @@ -9774,12 +9815,12 @@ subroutine read_mp_global_parameters() REAL :: CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC, & SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& - RSURF_SNOW,RSURF_EXP,SWE_LIMIT,SCAMAX + RSURF_SNOW,RSURF_EXP,IMPERV_URBAN,SWE_LIMIT,SCAMAX NAMELIST / noahmp_global_parameters / CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SNOW_RET_FAC, & SWEMX,TAU0,GRAIN_GROWTH,EXTRA_GROWTH,DIRT_SOOT,& BATS_COSZ,BATS_VIS_NEW,BATS_NIR_NEW,BATS_VIS_AGE,BATS_NIR_AGE,BATS_VIS_DIR,BATS_NIR_DIR,& - RSURF_SNOW,RSURF_EXP,SWE_LIMIT,SCAMAX + RSURF_SNOW,RSURF_EXP,IMPERV_URBAN,SWE_LIMIT,SCAMAX ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. @@ -9804,6 +9845,7 @@ subroutine read_mp_global_parameters() BATS_NIR_DIR_TABLE = -1.E36 RSURF_SNOW_TABLE = -1.E36 RSURF_EXP_TABLE = -1.E36 +IMPERV_URBAN_TABLE = -1.E36 SCAMAX_TABLE = -1.E36 SWE_LIMIT_TABLE = -1.E36 @@ -9843,6 +9885,7 @@ subroutine read_mp_global_parameters() BATS_NIR_DIR_TABLE = BATS_NIR_DIR RSURF_SNOW_TABLE = RSURF_SNOW RSURF_EXP_TABLE = RSURF_EXP +IMPERV_URBAN_TABLE = IMPERV_URBAN SCAMAX_TABLE = SCAMAX SWE_LIMIT_TABLE = SWE_LIMIT diff --git a/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL b/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL index a7f9020cf..e829d6232 100644 --- a/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL +++ b/trunk/NDHMS/Land_models/NoahMP/run/MPTABLE.TBL @@ -342,6 +342,7 @@ BATS_NIR_DIR = 0.4 !cosz factor for direct NIR snow albedo Yang97 eqn. 16 RSURF_SNOW = 50.0 !surface resistence for snow [s/m] RSURF_EXP = 5.0 !exponent in the shape parameter for soil resistance option 1 + IMPERV_URBAN = 0.95 !impervious fraction to use for urban type [0-1] SCAMAX = 1.0 !maximum fractional snow covered area [0-1] SWE_LIMIT = 5000.0 !maximum SWE limit [mm] diff --git a/trunk/NDHMS/OrchestratorLayer/config.f90 b/trunk/NDHMS/OrchestratorLayer/config.f90 index c594bd443..25727f05c 100644 --- a/trunk/NDHMS/OrchestratorLayer/config.f90 +++ b/trunk/NDHMS/OrchestratorLayer/config.f90 @@ -40,6 +40,7 @@ module config_base integer :: soil_data_option = 1 integer :: pedotransfer_option = 0 integer :: crop_option = 0 + integer :: imperv_option = 9 integer :: split_output_count = 1 integer :: khour @@ -157,6 +158,7 @@ module config_base character(len=256) :: timeSlicePath integer :: nLastObs integer :: bucket_loss + integer :: imperv_adj logical :: channel_bypass = .FALSE. @@ -449,6 +451,10 @@ subroutine rt_nlst_check(self) endif end if + if( (self%imperv_adj .lt. 0 ) .or. (self%imperv_adj .gt. 1) ) then + call hydro_stop('hydro.namelist ERROR: Invalid imperv_adj specified') + endif + end subroutine rt_nlst_check subroutine init_namelist_rt_field(did) @@ -462,7 +468,7 @@ subroutine init_namelist_rt_field(did) GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & sys_cpl, rst_typ, rst_bi_in, rst_bi_out, & gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, gwsoilcpl, & - UDMP_OPT, io_form_outputs, bucket_loss + UDMP_OPT, io_form_outputs, bucket_loss, imperv_adj real:: DTRT_TER,DTRT_CH,dxrt, gwChanCondConstIn, gwChanCondConstOut, gwIhShift character(len=256) :: route_topo_f="" character(len=256) :: route_chan_f="" @@ -553,7 +559,7 @@ subroutine init_namelist_rt_field(did) CHRTOUT_DOMAIN,CHANOBS_DOMAIN,CHRTOUT_GRID,LSMOUT_DOMAIN,& RTOUT_DOMAIN, output_gw, outlake, & frxst_pts_out, udmap_file, UDMP_OPT, GWBUCKPARM_file, bucket_loss, & - io_config_outputs, io_form_outputs, hydrotbl_f, t0OutputFlag, output_channelBucket_influx + io_config_outputs, io_form_outputs, hydrotbl_f, t0OutputFlag, output_channelBucket_influx, imperv_adj #ifdef WRF_HYDRO_NUDGING namelist /NUDGING_nlist/ nudgingParamFile, netwkReExFile, & @@ -589,6 +595,7 @@ subroutine init_namelist_rt_field(did) reservoir_rfc_forecasts = .FALSE. reservoir_rfc_forecasts_lookback_hours = 24 reservoir_type_specified = .FALSE. + imperv_adj = 0 #ifdef WRF_HYDRO_NUDGING ! Default values for NUDGING_nlist @@ -761,6 +768,7 @@ subroutine init_namelist_rt_field(did) nlst(did)%order_to_write = order_to_write nlst(did)%compound_channel = compound_channel nlst(did)%channel_loss_option = channel_loss_option + nlst(did)%imperv_adj = imperv_adj ! files nlst(did)%route_topo_f = route_topo_f nlst(did)%route_chan_f = route_chan_f @@ -882,6 +890,7 @@ subroutine init_noah_lsm_and_wrf_hydro() integer :: soil_data_option = 1 integer :: pedotransfer_option = 0 integer :: crop_option = 0 + integer :: imperv_option = 9 integer :: split_output_count = 1 integer :: khour = -999 integer :: kday = -999 @@ -915,6 +924,7 @@ subroutine init_noah_lsm_and_wrf_hydro() glacier_option, surface_resistance_option, & soil_data_option, pedotransfer_option, crop_option, & + imperv_option, & split_output_count, & khour, kday, zlvl, hrldas_setup_file, mmf_runoff_file, & @@ -1015,6 +1025,7 @@ subroutine init_noah_lsm_and_wrf_hydro() noah_lsm%soil_data_option = soil_data_option noah_lsm%pedotransfer_option = pedotransfer_option noah_lsm%crop_option = crop_option + noah_lsm%imperv_option = imperv_option noah_lsm%split_output_count = split_output_count diff --git a/trunk/NDHMS/Routing/Noah_distr_routing.F b/trunk/NDHMS/Routing/Noah_distr_routing.F index 1e89ba872..04bec13b5 100644 --- a/trunk/NDHMS/Routing/Noah_distr_routing.F +++ b/trunk/NDHMS/Routing/Noah_distr_routing.F @@ -878,8 +878,7 @@ end subroutine MPP_seq_land_SO8 subroutine disaggregateDomain_drv(did) use module_RT_data, only: rt_domain - use config_base, only: nlst - + use config_base, only: nlst, noah_lsm integer :: did call disaggregateDomain( RT_DOMAIN(did)%IX, RT_DOMAIN(did)%JX, nlst(did)%NSOIL, & RT_DOMAIN(did)%IXRT, RT_DOMAIN(did)%JXRT, nlst(did)%AGGFACTRT, & @@ -905,7 +904,8 @@ subroutine disaggregateDomain_drv(did) RT_DOMAIN(did)%OV_ROUGH2d, & RT_DOMAIN(did)%subsurface%properties%sldpth, & RT_DOMAIN(did)%soiltypRT, RT_DOMAIN(did)%soiltyp, & - rt_domain(did)%ELRT, RT_DOMAIN(did)%iswater) + rt_domain(did)%ELRT, RT_DOMAIN(did)%iswater, & + rt_domain(did)%IMPERVFRAC, nlst(did)%imperv_adj) end subroutine disaggregateDomain_drv !=================================================================================================== @@ -929,7 +929,7 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & SMCWLT1, VEGTYP, LKSAT, NEXP, dist,INFXSWGT,OVROUGHRTFAC, & LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT, NEXPRT, OV_ROUGH2d, & - SLDPTH, soiltypRT, soiltyp, elrt, iswater) + SLDPTH, soiltypRT, soiltyp, elrt, iswater, impervfrac, imperv_adj) #ifdef MPP_LAND use module_mpp_land, only: left_id,down_id,right_id, & up_id,mpp_land_com_real, my_id, io_id, numprocs, & @@ -948,6 +948,7 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & integer, intent(in) :: NSOIL ! number of soil layers integer, intent(in) :: iswater ! water veg class (from geogrid attrib) real, intent(in), dimension(NSOIL) :: SLDPTH ! array soil layer depth intervals (m) + integer, intent(in) :: imperv_adj ! impervious configuration option from hydro.namelist ! LSM grid parameters: real, intent(in), dimension(IX,JX) :: area_lsm ! cell area on the coarse grid (m2) integer, intent(in), dimension(IX,JX) :: VEGTYP, soiltyp ! coarse grid veg and soil types @@ -970,6 +971,7 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & real, intent(in), dimension(IXRT,JXRT) :: LKSATFAC ! lateral ksat adj factor real, intent(in), dimension(IXRT,JXRT) :: elrt ! elevation grid (m) integer, intent(in), dimension(IXRT,JXRT) :: CH_NETRT ! channel network routing grid + real, intent(in), dimension(IXRT,JXRT) :: impervfrac ! impervious fraction ! Routing states: real, intent(in), dimension(IXRT,JXRT) :: INFXSWGT ! infiltration excess weighting grid real, intent(in), dimension(IXRT,JXRT,NSOIL) :: SH2OWGT ! soil moisture weighting grid @@ -1174,7 +1176,16 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & IF (VEGTYP(I,J).LE.0) then OVROUGHRT(IXXRT,JYYRT) = 0.1 !COWS mask test ELSE - OVROUGHRT(IXXRT,JYYRT) = OV_ROUGH2d(i,j)*OVROUGHRTFAC(IXXRT,JYYRT) + OVROUGHRT(IXXRT,JYYRT) = OV_ROUGH2d(i,j) + ! Modify based on impervious fraction + ! See Liong et al. 1989 for linear weighting of "smoothness" (1/roughness) + ! Assuming roughness of 0.02 for impervious and native cell roughness for pervious + if (imperv_adj .ne. 0) then + OVROUGHRT(IXXRT,JYYRT) = 1. / ((1./0.02)*impervfrac(IXXRT,JYYRT) + & ! impervious fraction + (1./OVROUGHRT(IXXRT,JYYRT))*(1.-impervfrac(IXXRT,JYYRT))) ! pervious fraction + endif + ! Apply user-supplied adjustment factor + OVROUGHRT(IXXRT,JYYRT) = OVROUGHRT(IXXRT,JYYRT)*OVROUGHRTFAC(IXXRT,JYYRT) END IF ! Lateral ksat diff --git a/trunk/NDHMS/Routing/module_HYDRO_io.F b/trunk/NDHMS/Routing/module_HYDRO_io.F index dc28e9c25..9d2e653e1 100644 --- a/trunk/NDHMS/Routing/module_HYDRO_io.F +++ b/trunk/NDHMS/Routing/module_HYDRO_io.F @@ -5641,7 +5641,8 @@ end SUBROUTINE MPP_READ_ROUTEDIM #endif SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo_f, & - route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC,channel_option, UDMP_OPT) + route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC,IMPERVFRAC, & + channel_option, UDMP_OPT, imperv_adj) INTEGER, INTENT(IN) :: IXRT,JXRT @@ -5651,8 +5652,9 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo !Dummy inverted grids REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: IMPERVFRAC - integer :: I,J, iret, jj, channel_option, UDMP_OPT + integer :: I,J, iret, jj, channel_option, UDMP_OPT, imperv_adj CHARACTER(len=256) :: var_name CHARACTER(len=* ) :: route_topo_f CHARACTER(len=* ) :: route_chan_f @@ -5711,6 +5713,16 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo trim(geo_finegrid_flnm)) where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists +!Read in new optional impervious layer + var_name = "IMPERVFRAC" + IMPERVFRAC = -9999.9 + if (imperv_adj > 0) then + call nreadRT2d_real(var_name,IMPERVFRAC,ixrt,jxrt,& + trim(geo_finegrid_flnm), fatalErr=.true.) + where (IMPERVFRAC < 0.) IMPERVFRAC = 0.0 ! reset grid to = 0.0 if non-valid value exists + else + IMPERVFRAC = 0.0 + endif #ifdef HYDRO_D write(6,*) "finish READ_ROUTING_seq" diff --git a/trunk/NDHMS/Routing/module_RT.F b/trunk/NDHMS/Routing/module_RT.F index b69cca37e..1c4ebce3d 100644 --- a/trunk/NDHMS/Routing/module_RT.F +++ b/trunk/NDHMS/Routing/module_RT.F @@ -183,6 +183,10 @@ subroutine rt_allocate(did,ix,jx,ixrt,jxrt,nsoil,CHANRTSWCRT) !rt_domain(did)%LKSATRT = 0.0 allocate( rt_domain(did)%LKSATFAC (IXRT,JXRT) ) rt_domain(did)%LKSATFAC = 0.0 + + allocate( rt_domain(did)%IMPERVFRAC (IXRT,JXRT) ) + rt_domain(did)%IMPERVFRAC = 0.0 + !allocate( rt_domain(did)%subsurface%state%qsubrt (IXRT,JXRT) ) !rt_domain(did)%subsurface%state%qsubrt = 0.0 !allocate( rt_domain(did)%subsurface%properties%zwattablrt (IXRT,JXRT) ) @@ -653,7 +657,7 @@ end subroutine getChanDim subroutine LandRT_ini(did) use module_noah_chan_param_init_rt - use config_base, only: nlst + use config_base, only: nlst, noah_lsm use module_RT_data, only: rt_domain use module_gw_gw2d_data, only: gw2d #ifdef HYDRO_D @@ -713,8 +717,8 @@ subroutine LandRT_ini(did) rt_domain(did)%CH_LNKRT, & rt_domain(did)%LKSATFAC,trim(nlst(did)%route_topo_f),& nlst(did)%route_chan_f,nlst(did)%geo_finegrid_flnm , & - rt_domain(did)%OVROUGHRTFAC,rt_domain(did)%RETDEPRTFAC, & - nlst(did)%channel_option, nlst(did)%udmp_opt) + rt_domain(did)%OVROUGHRTFAC,rt_domain(did)%RETDEPRTFAC, rt_domain(did)%IMPERVFRAC, & + nlst(did)%channel_option, nlst(did)%udmp_opt, nlst(did)%imperv_adj) !yw CALL READ_ROUTING_old(rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%overland%streams_and_lakes%ch_netrt, & @@ -1201,10 +1205,14 @@ subroutine LandRT_ini(did) end do end do + !Apply impervious adjustment to retdeprt (AD) + if (nlst(did)%imperv_adj .ne. 0) then + rt_domain(did)%overland%properties%retention_depth = rt_domain(did)%overland%properties%retention_depth*(1.-rt_domain(did)%impervfrac) + end if !Apply calibration scaling factors to sfc roughness and retention depth here... rt_domain(did)%overland%properties%retention_depth = rt_domain(did)%overland%properties%retention_depth * rt_domain(did)%RETDEPRTFAC - rt_domain(did)%overland%properties%roughness = rt_domain(did)%overland%properties%roughness * rt_domain(did)%OVROUGHRTFAC + ! Removing roughness parameter update since it has not been populated yet... currently happens in Noah_dist_routing (AD) !ADCHANGE: Moved this channel cell setting from OV_RTNG so it is outside !of overland routine (frequently called) and time loop. diff --git a/trunk/NDHMS/template/HYDRO/hydro.namelist b/trunk/NDHMS/template/HYDRO/hydro.namelist index 8afa8eee9..54821f10f 100644 --- a/trunk/NDHMS/template/HYDRO/hydro.namelist +++ b/trunk/NDHMS/template/HYDRO/hydro.namelist @@ -134,6 +134,9 @@ OVRTSWCRT = 1 ! NOTE: Currently subsurface flow is only steepest descent rt_option = 1 +! Specify whether to adjust overland flow parameters based on imperviousness +imperv_adj = 0 + ! Switch to activate channel routing...(0=no, 1=yes) CHANRTSWCRT = 1 diff --git a/trunk/NDHMS/template/NoahMP/namelist.hrldas b/trunk/NDHMS/template/NoahMP/namelist.hrldas index a123eec53..551de2159 100644 --- a/trunk/NDHMS/template/NoahMP/namelist.hrldas +++ b/trunk/NDHMS/template/NoahMP/namelist.hrldas @@ -34,6 +34,7 @@ TBOT_OPTION = 2 TEMP_TIME_SCHEME_OPTION = 3 GLACIER_OPTION = 2 SURFACE_RESISTANCE_OPTION = 4 +IMPERV_OPTION = 9 !(0->none; 1->total; 2->Alley&Veenhuis; 9->orig) ! Timesteps in units of seconds FORCING_TIMESTEP = 3600 From c20829c9046d5c1a98410581d5d87a6b67f4c802 Mon Sep 17 00:00:00 2001 From: Soren Rasmussen Date: Mon, 21 Mar 2022 12:16:14 -0700 Subject: [PATCH 14/25] Add Crocus snowpack/glacier model to WRF-Hydro (#607) * Add Crocus to Noah-MP * Move lat lon in snowcro since they are not used * Move max SWE limit to a parameter in MPTABLE. * Fix energy NAs over large snowpacks due to very small numbers being rounded to 0, so number/number=NA instead of 1. Switched to an if statement. * Add swe_limit into crocus specific calls * Add outputs (flow from glacier snow or glacier ice) * Add crocus outputs to retro config. * Move a series of files that module_snowcro.F needs to the surfex directory for a cleaner build, and modify Makefile as necessary * Move a series of files from Land_models/NoahMP/phys directory into a subdirectory and update the Makefile paths to those files and include the new surfex subdirectory * Increase max SWE in glacier module to 5m to match standard snow model max value. * Remove swe max limit. * Add Aubreys changes for energy balance * Add option to add visible albedo map * Add possibility to read visible ice albedo from netcdf file * Add Crocus namelist to end of namelist.hrldas * Crocus: Set the ldasOutDict numLev to the act_lev input from the namelist file * Crocus: crocus can be turned off and on with crocus_opt * Crocus: code cleanup and formatting * Crocus: if vis_icealb is not present, set it to NaN * Crocus: removed dev comments and reformatted code * Crocus: Trude fix of SNOW being updated, rather than SNEQVOXY * Crocus: bug fix, certain values needed to be reset while iterating over array * Crocus: Trude fix for when snowthickness becomes zero in the top layer * Crocus: bugfix to albedo output. Code from Trude Eidhammer * Bugfix: ALBSND and ALBSNI should be undefined when NOAHMP_SFLX isn't called. Fixes some output file differences Co-authored-by: Trude Eidhammer Co-authored-by: Aubrey Dugger Co-authored-by: Ryan Cabell --- .../NDHMS/Land_models/NoahMP/IO_code/Makefile | 6 +- .../IO_code/module_NoahMP_hrldas_driver.F | 340 +- .../NoahMP/IO_code/module_hrldas_netcdf_io.F | 144 +- trunk/NDHMS/Land_models/NoahMP/phys/Makefile | 30 +- .../NoahMP/phys/module_sf_noahmp_glacier.F | 238 +- .../NoahMP/phys/module_sf_noahmpdrv.F | 814 ++- .../Land_models/NoahMP/phys/module_snowcro.F | 5661 +++++++++++++++++ .../Land_models/NoahMP/phys/surfex/Makefile | 31 + .../Land_models/NoahMP/phys/surfex/ini_csts.F | 329 + .../NoahMP/phys/surfex/modd_csts.F | 95 + .../NoahMP/phys/surfex/modd_snow_metamo.F | 151 + .../NoahMP/phys/surfex/modd_snow_par.F | 403 ++ .../NoahMP/phys/surfex/modd_surf_atm.F | 88 + .../NoahMP/phys/surfex/mode_snow3l.F | 2360 +++++++ .../NoahMP/phys/surfex/mode_surf_coefs.F | 485 ++ .../NoahMP/phys/surfex/mode_thermos.F | 1314 ++++ .../phys/surfex/tridiag_ground_snowcro.F | 344 + trunk/NDHMS/Land_models/NoahMP/run/Makefile | 23 +- trunk/NDHMS/MPP/module_mpp_GWBUCKET.F | 2 - trunk/NDHMS/OrchestratorLayer/config.f90 | 74 +- trunk/NDHMS/Routing/module_NWM_io.F | 101 +- trunk/NDHMS/Routing/module_NWM_io_dict.F | 138 +- trunk/NDHMS/Routing/module_lsm_forcing.F | 21 +- trunk/NDHMS/template/NoahMP/namelist.hrldas | 5 + 24 files changed, 12785 insertions(+), 412 deletions(-) create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/module_snowcro.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/Makefile create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/ini_csts.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_csts.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_metamo.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_par.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_surf_atm.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_snow3l.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_surf_coefs.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_thermos.F create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/tridiag_ground_snowcro.F diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/Makefile b/trunk/NDHMS/Land_models/NoahMP/IO_code/Makefile index f5101eac4..7464c5738 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/Makefile +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/Makefile @@ -1,4 +1,4 @@ -# Makefile +# Makefile # .SUFFIXES: .SUFFIXES: .o .F @@ -20,13 +20,13 @@ NoahMP : $(OBJS_NoahMP) $(OBJS) module_NoahMP_hrldas_driver.o: module_NoahMP_hrldas_driver.F ../../../HYDRO_drv/module_HYDRO_drv.o ../../../Data_Rec/module_namelist.o ../../../Data_Rec/module_RT_data.o @echo "" $(COMPILERF90) $(CPPINVOKE) $(CPPFLAGS) $(CPPHRLDAS) -o $(@) -c $(F90FLAGS) $(FREESOURCE) $(MODFLAG) -I. \ - -I../phys -I../Utility_routines -I../../../mod $(NETCDFMOD) $(*).F + -I../phys -I../phys/surfex -I../Utility_routines -I../../../mod $(NETCDFMOD) $(*).F @echo "" main_hrldas_driver.o: ../../../OrchestratorLayer/orchestrator.o main_hrldas_driver.F @echo "" $(COMPILERF90) $(CPPINVOKE) $(CPPFLAGS) $(CPPHRLDAS) -o $(@) -c $(F90FLAGS) $(LDFLAGS) $(FREESOURCE) -I ../MPP -I. \ - -I../phys -I../Utility_routines -I../../../mod -I../../../MPP -I../data_structures $(NETCDFMOD) $(*).F + -I../phys -I../phys/surfex -I../Utility_routines -I../../../mod -I../../../MPP -I../data_structures $(NETCDFMOD) $(*).F # $(COMPILERF90) -o $(@) -c $(F90FLAGS) $(FREESOURCE) -I ../MPP -I. \ # -I../phys -I../Utility_routines $(NETCDFMOD) $(*).f90 @echo "" diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F index 571bbd83e..0b4873cf9 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F @@ -26,6 +26,7 @@ module module_NoahMP_hrldas_driver USE module_date_utilities USE orchestrator_base USE config_base, only: wrf_hydro, noah_lsm + USE modi_ini_csts #ifdef MPP_LAND use module_mpp_land, only: MPP_LAND_PAR_INI, mpp_land_init, getLocalXY, mpp_land_bcast_char, mpp_land_sync use module_mpp_land, only: check_land, node_info, numprocs @@ -66,7 +67,9 @@ module module_NoahMP_hrldas_driver REAL, ALLOCATABLE, DIMENSION(:,:) :: SOILSAT ! column integrated soil saturation [fraction] REAL, ALLOCATABLE, DIMENSION(:,:) :: SOILICE ! fraction of soil moisture that is ice [fraction] REAL, ALLOCATABLE, DIMENSION(:,:) :: SNOWT_AVG ! snowpack average temperature (by layer mass) [K] ** DIAGNOSTIC VARIABLE - character(len=15), DIMENSION(100) :: IOCVARS + integer, parameter :: max_ioc_num_vars = 200 + integer, parameter :: ioc_var_len = 20 + character(len=ioc_var_len), DIMENSION(max_ioc_num_vars) :: IOCVARS #endif character(len=9), parameter :: version = "v20150506" @@ -88,9 +91,14 @@ module module_NoahMP_hrldas_driver REAL, ALLOCATABLE, DIMENSION(:) :: DZS ! thickness of soil layers [m] INTEGER :: NSOIL ! number of soil layers INTEGER :: NUM_SOIL_LAYERS ! number of soil layers + INTEGER :: crocus_opt + INTEGER :: act_lev REAL :: DX ! horizontal grid spacing [m] INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IVGTYP ! vegetation type INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ISLTYP ! soil type + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: GLACINFO ! location of glacier + REAL, ALLOCATABLE, DIMENSION(:,:) :: GLACT ! glacier thickness + REAL, ALLOCATABLE, DIMENSION(:,:) :: VIS_ICEALB! map of visible ice albedo REAL, ALLOCATABLE, DIMENSION(:,:) :: VEGFRA ! vegetation fraction [] REAL, ALLOCATABLE, DIMENSION(:,:) :: TMN ! deep soil temperature [K] REAL, ALLOCATABLE, DIMENSION(:,:) :: XLAND ! =2 ocean; =1 land/seaice @@ -314,6 +322,27 @@ module module_NoahMP_hrldas_driver REAL :: WTDDT = 30.0 ! frequency of groundwater call [minutes] INTEGER :: STEPWTD ! step of groundwater call +!------------------------------------------------------------------------ +! Crocus +!------------------------------------------------------------------------ + + REAL, ALLOCATABLE, DIMENSION(:,:) :: PSNOWTHRUFALXY + REAL, ALLOCATABLE, DIMENSION(:,:) :: PSNOWALBXY + REAL, ALLOCATABLE, DIMENSION(:,:) :: PSNOWHEIGHTXY + REAL, ALLOCATABLE, DIMENSION(:,:) :: PSNOWTOTSWEXY + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLOW_SNOW + REAL, ALLOCATABLE, DIMENSION(:,:) :: FLOW_ICE + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWHEATXY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWRHOXY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWSWEXY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWGRAN1XY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWGRAN2XY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWAGEXY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWLIQXY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWTEMPXY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWDZXY + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: PSNOWHISTXY + !------------------------------------------------------------------------ ! 2D variables not used in WRF - should be removed? !------------------------------------------------------------------------ @@ -434,23 +463,25 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) dtbl = real(noah_lsm%noah_timestep) num_soil_layers = noah_lsm%nsoil ! because surface driver uses the long form - IDVEG = noah_lsm%dynamic_veg_option ! transfer from namelist to driver format - IOPT_CRS = noah_lsm%canopy_stomatal_resistance_option - IOPT_BTR = noah_lsm%btr_option - IOPT_RUN = noah_lsm%runoff_option - IOPT_SFC = noah_lsm%surface_drag_option - IOPT_FRZ = noah_lsm%supercooled_water_option - IOPT_INF = noah_lsm%frozen_soil_option - IOPT_RAD = noah_lsm%radiative_transfer_option - IOPT_ALB = noah_lsm%snow_albedo_option - IOPT_SNF = noah_lsm%pcp_partition_option - IOPT_TBOT = noah_lsm%tbot_option - IOPT_STC = noah_lsm%temp_time_scheme_option - IOPT_GLA = noah_lsm%glacier_option - IOPT_RSF = noah_lsm%surface_resistance_option - IOPT_SOIL = noah_lsm%soil_data_option - IOPT_PEDO = noah_lsm%pedotransfer_option - IOPT_CROP = noah_lsm%crop_option + act_lev = noah_lsm%act_lev + crocus_opt = noah_lsm%crocus_opt + IDVEG = noah_lsm%dynamic_veg_option ! transfer from namelist to driver format + IOPT_CRS = noah_lsm%canopy_stomatal_resistance_option + IOPT_BTR = noah_lsm%btr_option + IOPT_RUN = noah_lsm%runoff_option + IOPT_SFC = noah_lsm%surface_drag_option + IOPT_FRZ = noah_lsm%supercooled_water_option + IOPT_INF = noah_lsm%frozen_soil_option + IOPT_RAD = noah_lsm%radiative_transfer_option + IOPT_ALB = noah_lsm%snow_albedo_option + IOPT_SNF = noah_lsm%pcp_partition_option + IOPT_TBOT = noah_lsm%tbot_option + IOPT_STC = noah_lsm%temp_time_scheme_option + IOPT_GLA = noah_lsm%glacier_option + IOPT_RSF = noah_lsm%surface_resistance_option + IOPT_SOIL = noah_lsm%soil_data_option + IOPT_PEDO = noah_lsm%pedotransfer_option + IOPT_CROP = noah_lsm%crop_option IOPT_IMPERV = noah_lsm%imperv_option khour = noah_lsm%khour @@ -656,23 +687,24 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) noah_lsm%start_year, noah_lsm%start_month, noah_lsm%start_day, noah_lsm%start_hour, noah_lsm%start_min, 0 startdate = olddate - + #ifdef MPP_LAND ix = ix_tmp jx = jx_tmp #endif - + #ifdef WRF_HYDRO forcdate = olddate #endif - - ! Convenience variables + + ! Convenience variables xstart = noah_lsm%xstart ystart = noah_lsm%ystart xend = noah_lsm%xend yend = noah_lsm%yend nsoil = noah_lsm%nsoil - + act_lev = noah_lsm%act_lev + crocus_opt = noah_lsm%crocus_opt ids = xstart ide = xend jds = ystart @@ -714,6 +746,11 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) ALLOCATE ( IVGTYP (XSTART:XEND,YSTART:YEND) ) ! vegetation type ALLOCATE ( ISLTYP (XSTART:XEND,YSTART:YEND) ) ! soil type ALLOCATE ( VEGFRA (XSTART:XEND,YSTART:YEND) ) ! vegetation fraction [] + if (crocus_opt /= 0) then + ALLOCATE (GLACINFO(XSTART:XEND,YSTART:YEND) ) ! loacation of glacier + ALLOCATE (GLACT (XSTART:XEND,YSTART:YEND) ) ! glacier thickness [m] + ALLOCATE (VIS_ICEALB(XSTART:XEND,YSTART:YEND)) + end if ALLOCATE ( TMN (XSTART:XEND,YSTART:YEND) ) ! deep soil temperature [K] ALLOCATE ( XLAND (XSTART:XEND,YSTART:YEND) ) ! =2 ocean; =1 land/seaice ALLOCATE ( XICE (XSTART:XEND,YSTART:YEND) ) ! fraction of grid that is seaice @@ -904,6 +941,24 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) ALLOCATE ( CHSTARXY (XSTART:XEND,YSTART:YEND) ) ! for consistency with MP_init; delete later ALLOCATE ( SEAICE (XSTART:XEND,YSTART:YEND) ) ! seaice fraction + if (crocus_opt /= 0) then + ALLOCATE ( PSNOWTHRUFALXY (XSTART:XEND,YSTART:YEND) ) + ALLOCATE ( PSNOWALBXY (XSTART:XEND,YSTART:YEND) ) + ALLOCATE ( PSNOWHEIGHTXY (XSTART:XEND,YSTART:YEND) ) + ALLOCATE ( PSNOWTOTSWEXY (XSTART:XEND,YSTART:YEND) ) + ALLOCATE ( FLOW_SNOW (XSTART:XEND,YSTART:YEND) ) + ALLOCATE ( FLOW_ICE (XSTART:XEND,YSTART:YEND) ) + ALLOCATE ( PSNOWHEATXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWRHOXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWSWEXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWGRAN1XY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWGRAN2XY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWAGEXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWLIQXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWTEMPXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWDZXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + ALLOCATE ( PSNOWHISTXY (XSTART:XEND,1:act_lev,YSTART:YEND) ) + end if ! crocus_opt /= 0 #ifdef WRF_HYDRO allocate( greenfrac (XSTART:XEND,YSTART:YEND)) @@ -931,6 +986,11 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) DZ8W = undefined_real DZS = undefined_real IVGTYP = undefined_int + if (crocus_opt /= 0) then + GLACINFO = undefined_int + GLACT = undefined_real + VIS_ICEALB = undefined_real + end if ISLTYP = undefined_int VEGFRA = undefined_real GVFMAX = undefined_real @@ -1093,12 +1153,69 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) ! Read Landuse Type and Soil Texture and Other Information !---------------------------------------------------------------------- - CALL READLAND_HRLDAS(noah_lsm%HRLDAS_SETUP_FILE, XSTART, XEND, YSTART, YEND, & - ISWATER, ISLAKE, IVGTYP, ISLTYP, TERRAIN, TMN, XLAT_URB2D, XLONIN, XLAND, & - SEAICE, MSFTX, MSFTY) + CALL READLAND_HRLDAS(noah_lsm%HRLDAS_SETUP_FILE, XSTART, XEND, YSTART, & + YEND, ISWATER, ISLAKE, IVGTYP, & + ISLTYP, TERRAIN, TMN, XLAT_URB2D, & + XLONIN, XLAND, SEAICE, MSFTX, & + MSFTY, crocus_opt, GLACINFO, GLACT, & + VIS_ICEALB) WHERE(SEAICE > 0.0) XICE = 1.0 +!---------------------------------------------------------------------- +! Crocus: Initialize glacier +!---------------------------------------------------------------------- + if (crocus_opt /= 0) then + PSNOWLIQXY = undefined_real + PSNOWTEMPXY = undefined_real + PSNOWDZXY = undefined_real + PSNOWHEATXY = undefined_real + PSNOWRHOXY = undefined_real + PSNOWSWEXY = undefined_real + PSNOWGRAN1XY = undefined_real + PSNOWGRAN2XY = undefined_real + PSNOWHISTXY = undefined_real + PSNOWALBXY = undefined_real + PSNOWTHRUFALXY = undefined_real + PSNOWHEIGHTXY = undefined_real + PSNOWTOTSWEXY = undefined_real + FLOW_SNOW = undefined_real + FLOW_ICE = undefined_real + PSNOWAGEXY = undefined_real + + PSNOWLIQXY = 0 + PSNOWTEMPXY = 0 + PSNOWDZXY = 0 + PSNOWHEATXY = 0 + PSNOWRHOXY = 0 + PSNOWSWEXY = 0 + PSNOWGRAN1XY = 0 + PSNOWGRAN2XY = 0 + PSNOWHISTXY = 0 + PSNOWALBXY = 0 + PSNOWTHRUFALXY = 0 + PSNOWHEIGHTXY = 0 + PSNOWTOTSWEXY = 0 + FLOW_ICE = 0 + FLOW_SNOW = 0 + PSNOWAGEXY = 0 + + WHERE(GLACINFO > 0.0) PSNOWALBXY=0.35 + + do kk = 1, act_lev + WHERE(GLACINFO > 0.0) PSNOWRHOXY (:,kk,:) = 900. + WHERE(GLACINFO > 0.0) PSNOWDZXY (:,kk,:) = GLACT/act_lev + WHERE(GLACINFO > 0.0) PSNOWSWEXY (:,kk,:) = PSNOWDZXY(:,kk,:)*PSNOWRHOXY(:,KK,:) + WHERE(GLACINFO > 0.0) PSNOWHEATXY (:,kk,:) = -PSNOWSWEXY(:,kk,:)*333231.05 + WHERE(GLACINFO > 0.0) PSNOWGRAN1XY(:,kk,:) = 0.0009 + WHERE(GLACINFO > 0.0) PSNOWGRAN2XY(:,kk,:) = 99 ! 1 + WHERE(GLACINFO > 0.0) PSNOWAGEXY (:,kk,:) = 20000 + enddo + + CALL INI_CSTS + end if ! crocus_opt /= 0 + + !------------------------------------------------------------------------ ! For spatially-varying soil parameters, read in necessary extra fields !------------------------------------------------------------------------ @@ -1207,6 +1324,24 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "QSFC" , QSFC ) call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "SFCRUNOFF",SFCRUNOFF ) call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "UDRUNOFF" ,UDRUNOFF ) + if (crocus_opt /= 0) then + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWAGE", PSNOWAGEXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWDZ", PSNOWDZXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWGRAN1", PSNOWGRAN1XY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWGRAN2", PSNOWGRAN2XY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWHEAT", PSNOWHEATXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWHIST", PSNOWHISTXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWLIQ", PSNOWLIQXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWRHO", PSNOWRHOXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWSWE", PSNOWSWEXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWTEMP", PSNOWTEMPXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWALB", PSNOWALBXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWHEIGHT", PSNOWHEIGHTXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWTHRUFAL", PSNOWTHRUFALXY) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "PSNOWTOTSWE", PSNOWTOTSWEXY ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "FLOW_SNOW", FLOW_SNOW ) + call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "FLOW_ICE", FLOW_ICE ) + end if ! crocus_opt /= 0 #ifdef WRF_HYDRO if(checkRstV("ACCPRCP") .eq. 0) call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "ACCPRCP" ,ACCPRCP ) if(checkRstV("ACCECAN") .eq. 0) call get_from_restart(xstart, xend, xstart, ixfull, jxfull, "ACCECAN" ,ACCECAN ) @@ -1374,6 +1509,8 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) call system_clock(count=clock_count_1) ! Start a timer + if (crocus_opt /= 0) & + PSNOWTHRUFALXY(:,:) = 0. #ifdef WRF_HYDRO allocate( infxsrt (ix,jx) ) @@ -1425,7 +1562,10 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) 'IRG,SHG,EVG,GHV,SAG,IRB,SHB,EVB,GHB,TRAD,TG,TV,TAH,TGV,TGB,T2MV,T2MB,Q2MV,Q2MB,EAH,FWET,ZSNSO_SN,SNICE,' // & 'SNLIQ,SOIL_T,SOIL_W,SNOW_T,SOIL_M,SNOWH,SNEQV,QSNOW,ISNOW,FSNO,ACSNOW,ACSNOM,CM,CH,CHV,CHB,CHLEAF,CHUC,' // & 'CHV2,CHB2,LFMASS,RTMASS,STMASS,WOOD,STBLCP,FASTCP,NEE,GPP,NPP,PSN,APAR,ACCET,CANWAT,SOILICE,SOILSAT_TOP,'// & - 'SOILSAT,SNOWT_AVG,QRAIN' + 'SOILSAT,SNOWT_AVG,QRAIN,glacier,glacier_thickness,PSNOWALB,PSNOWTHRUFAL,PSNOWHEIGHT,PSNOWTOTSWE,'// & + 'PSNOWGRAN1,PSNOWGRAN2,PSNOWAGE,PSNOWTEMP,PSNOWDZ,PSNOWHIST,PSNOWLIQ,PSNOWHEAT,PSNOWRHO,PSNOWSWE,'// & + 'FLOW_ICE,FLOW_SNOW' + endif if (io_config_outputs .eq. 1) then VARLIST = 'SNOWH,SNEQV,FSNO,SOILSAT_TOP,SNOWT_AVG,ACCET' @@ -1448,15 +1588,29 @@ subroutine land_driver_ini(NTIME_out, state, wrfits,wrfite,wrfjts,wrfjte) !!--- Parse into character array. Constructor not valid with uneven !!--- strings in f90 so using brute force. + do while (brkflag .eq. 0) - if (index(VARLIST, ',') .eq. 0) then - IOCVARS(varind) = adjustl(VARLIST) - brkflag = 1 - else - IOCVARS(varind) = adjustl(VARLIST(1:(index(VARLIST, ',')-1))) - VARLIST = VARLIST((index(VARLIST, ',')+1):) - varind = varind + 1 - endif + if (index(VARLIST, ',') .eq. 0) then + IOCVARS(varind) = adjustl(VARLIST) + brkflag = 1 + if (varind > max_ioc_num_vars) then +#ifdef MPP_LAND + call fatal_error_stop("ERROR: number of vars is greater than current max_num_vars") +#else + stop "Error: number of vars is greater than current max_num_vars" +#endif + endif + else +#ifdef HYDRO_D + if (len(adjustl(VARLIST(1:(index(VARLIST, ',')-1)))) > ioc_var_len) then + print *,"WARNING: length of ", adjustl(VARLIST(1:(index(VARLIST, ',')-1))), & + " is longer than ioc_var_len" + end if +#endif + IOCVARS(varind) = adjustl(VARLIST(1:(index(VARLIST, ',')-1))) + VARLIST = VARLIST((index(VARLIST, ',')+1):) + varind = varind + 1 + endif end do if(wrf_hydro%finemesh .ne. 0 ) then @@ -1687,6 +1841,11 @@ subroutine land_driver_exe(itime, state) SHGXY, SHCXY, SHBXY, EVGXY, EVBXY, GHVXY, & GHBXY, IRGXY, IRCXY, IRBXY, TRXY, EVCXY, & CHLEAFXY, CHUCXY, CHV2XY, CHB2XY, & + PSNOWLIQXY, PSNOWTEMPXY, PSNOWDZXY, PSNOWHEATXY, & + PSNOWRHOXY, PSNOWSWEXY, PSNOWGRAN1XY, PSNOWGRAN2XY, & + PSNOWHISTXY, PSNOWALBXY, PSNOWAGEXY, act_lev, & + PSNOWHEIGHTXY, PSNOWTOTSWEXY, PSNOWTHRUFALXY, GLACINFO, & + GLACT, FLOW_ICE, FLOW_SNOW, crocus_opt, & #ifdef SPATIAL_SOIL BEXP_3D,SMCDRY_3D,SMCWLT_3D,SMCREF_3D,SMCMAX_3D, & DKSAT_3D,DWSAT_3D,PSISAT_3D,QUARTZ_3D, & @@ -1704,13 +1863,15 @@ subroutine land_driver_exe(itime, state) its,ite, jts,jte, kts,kte, & ! variables below are optional MP_RAINC = RAINCV, MP_RAINNC = RAINNCV, MP_SHCV = RAINSHV,& - MP_SNOW = SNOWNCV, MP_GRAUP = GRAUPELNCV, MP_HAIL = HAILNCV & + MP_SNOW = SNOWNCV, MP_GRAUP = GRAUPELNCV, MP_HAIL = HAILNCV, & + VIS_ICEALB=VIS_ICEALB & #ifdef WRF_HYDRO , ACCPRCP=ACCPRCP, ACCECAN=ACCECAN, ACCETRAN=ACCETRAN, ACCEDIR=ACCEDIR & , SOILSAT_TOP=SOILSAT_TOP, SOILSAT=SOILSAT, SOILICE=SOILICE, SNOWT_AVG=SNOWT_AVG & #endif ) + call system_clock(count=count_after_sflx, count_rate=clock_rate) sflx_count_sum = sflx_count_sum + ( count_after_sflx - count_before_sflx ) @@ -2052,6 +2213,27 @@ subroutine ldas_output(itime, state) call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,2,ALBSNDXY,IVGTYP,96) call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,2,ALBSNIXY,IVGTYP,97) call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,QRAINXY,IVGTYP,98) + if (crocus_opt /= 0) then + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,float(GLACINFO),IVGTYP,99) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,(GLACT),IVGTYP,100) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,PSNOWALBXY,IVGTYP,101) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,PSNOWTHRUFALXY,IVGTYP,102) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,PSNOWHEIGHTXY,IVGTYP,103) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,PSNOWTOTSWEXY,IVGTYP,104) + + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWGRAN1XY,IVGTYP,105) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWGRAN2XY,IVGTYP,106) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWAGEXY,IVGTYP,107) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWTEMPXY,IVGTYP,108) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWDZXY,IVGTYP,109) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWHISTXY,IVGTYP,110) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,(PSNOWLIQXY),IVGTYP,111) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWHEATXY,IVGTYP,112) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWRHOXY ,IVGTYP,113) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,noah_lsm%act_lev,PSNOWSWEXY,IVGTYP,114) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,FLOW_ICE,IVGTYP,115) + call output_NoahMP_NWM(trim(noah_lsm%outdir),igrid,noah_lsm%output_timestep,itime,startdate,olddate,ixpar,jxpar,1,FLOW_SNOW,IVGTYP,116) + end if ! crocus_opt /= 0 #endif /* WRF_HYDRO */ !#ifdef WRF_HYDRO @@ -2072,10 +2254,14 @@ subroutine lsm_restart(state) print*, 'Write restart at '//olddate(1:13) #endif - call prepare_restart_file (trim(noah_lsm%outdir), version, igrid, llanduse, olddate, startdate, & - ixfull, jxfull, ixpar, jxpar, xstartpar, ystartpar, & - nsoil, nsnow, dx, dy, truelat1, truelat2, mapproj, lat1, lon1, & - cen_lon, iswater, ivgtyp) + call prepare_restart_file (trim(noah_lsm%outdir), version, igrid, llanduse, & + olddate, startdate, ixfull, jxfull, & + ixpar, jxpar, xstartpar, ystartpar, & + nsoil, nsnow, dx, dy, & + truelat1, truelat2, mapproj, lat1, & + lon1, cen_lon, iswater, ivgtyp, & + glacinfo, glact, act_lev, VIS_ICEALB) + write(tmpStr, '(A,"/RESTART.",A10,"_DOMAIN",I1)') trim(noah_lsm%outdir), olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13), igrid @@ -2132,6 +2318,24 @@ subroutine lsm_restart(state) call add_to_restart(ncid,QSFC , "QSFC" ) call add_to_restart(ncid,SFCRUNOFF , "SFCRUNOFF") call add_to_restart(ncid,UDRUNOFF , "UDRUNOFF" ) + if (crocus_opt /= 0) then + call add_to_restart(ncid, PSNOWAGEXY , "PSNOWAGE" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWDZXY , "PSNOWDZ" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWGRAN1XY , "PSNOWGRAN1", LAYERS="MAXS") + call add_to_restart(ncid, PSNOWGRAN2XY , "PSNOWGRAN2", LAYERS="MAXS") + call add_to_restart(ncid, PSNOWHEATXY , "PSNOWHEAT" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWHISTXY , "PSNOWHIST" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWLIQXY , "PSNOWLIQ" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWRHOXY , "PSNOWRHO" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWSWEXY , "PSNOWSWE" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWTEMPXY , "PSNOWTEMP" , LAYERS="MAXS") + call add_to_restart(ncid, PSNOWALBXY , "PSNOWALB" ) + call add_to_restart(ncid, PSNOWHEIGHTXY , "PSNOWHEIGHT" ) + call add_to_restart(ncid, PSNOWTHRUFALXY, "PSNOWTHRUFAL") + call add_to_restart(ncid, PSNOWTOTSWEXY , "PSNOWTOTSWE" ) + call add_to_restart(ncid, FLOW_ICE , "FLOW_ICE" ) + call add_to_restart(ncid, FLOW_SNOW , "FLOW_SNOW" ) + end if ! crocus_opt /= 0 #ifdef WRF_HYDRO call add_to_restart(ncid,ACCPRCP , "ACCPRCP" ) call add_to_restart(ncid,ACCECAN , "ACCECAN" ) @@ -2250,6 +2454,24 @@ subroutine lsm_rst_bi_out(state) write(iunit,ERR=101) QSFC write(iunit,ERR=101) SFCRUNOFF write(iunit,ERR=101) UDRUNOFF + if (crocus_opt /= 0) then + write(iunit,ERR=101) PSNOWAGEXY + write(iunit,ERR=101) PSNOWDZXY + write(iunit,ERR=101) PSNOWGRAN1XY + write(iunit,ERR=101) PSNOWGRAN2XY + write(iunit,ERR=101) PSNOWHEATXY + write(iunit,ERR=101) PSNOWHISTXY + write(iunit,ERR=101) PSNOWLIQXY + write(iunit,ERR=101) PSNOWRHOXY + write(iunit,ERR=101) PSNOWSWEXY + write(iunit,ERR=101) PSNOWTEMPXY + write(iunit,ERR=101) PSNOWALBXY + write(iunit,ERR=101) PSNOWHEIGHTXY + write(iunit,ERR=101) PSNOWTHRUFALXY + write(iunit,ERR=101) PSNOWTOTSWEXY + write(iunit,ERR=101) FLOW_SNOW + write(iunit,ERR=101) FLOW_ICE + end if ! crocus_opt /= 0 ! #ifndef REALTIME ! #ifdef WRF_HYDRO ! write(iunit,ERR=101) ACCPRCP @@ -2380,6 +2602,26 @@ subroutine lsm_rst_bi_in(state) read(iunit,ERR=101) QSFC read(iunit,ERR=101) SFCRUNOFF read(iunit,ERR=101) UDRUNOFF + if (crocus_opt /= 0) then + read(iunit,ERR=101) PSNOWAGEXY + read(iunit,ERR=101) PSNOWDZXY + read(iunit,ERR=101) PSNOWGRAN1XY + read(iunit,ERR=101) PSNOWGRAN2XY + read(iunit,ERR=101) PSNOWHEATXY + read(iunit,ERR=101) PSNOWHISTXY + read(iunit,ERR=101) PSNOWLIQXY + read(iunit,ERR=101) PSNOWRHOXY + read(iunit,ERR=101) PSNOWSWEXY + read(iunit,ERR=101) PSNOWTEMPXY + read(iunit,ERR=101) PSNOWALBXY + read(iunit,ERR=101) PSNOWHEIGHTXY + read(iunit,ERR=101) PSNOWTHRUFALXY + read(iunit,ERR=101) PSNOWTOTSWEXY + read(iunit,ERR=101) FLOW_SNOW + read(iunit,ERR=101) FLOW_ICE + end if ! crocus_opt /= 0 + + ! read(iunit,ERR=101) PSNOWLIQXY ! #ifndef REALTIME ! #ifdef WRF_HYDRO ! read(iunit,ERR=101) ACCPRCP @@ -2485,6 +2727,24 @@ subroutine define_rst_variables(ncid, state) call define_rst_var(ncid,QSFC , "QSFC" ) call define_rst_var(ncid,SFCRUNOFF , "SFCRUNOFF") call define_rst_var(ncid,UDRUNOFF , "UDRUNOFF" ) + if (crocus_opt /= 0) then + call define_rst_var(ncid,PSNOWAGEXY , "PSNOWAGE" , layers="MAXS") + call define_rst_var(ncid,PSNOWDZXY , "PSNOWDZ" , layers="MAXS") + call define_rst_var(ncid,PSNOWGRAN1XY , "PSNOWGRAN1", layers="MAXS") + call define_rst_var(ncid,PSNOWGRAN2XY , "PSNOWGRAN2", layers="MAXS") + call define_rst_var(ncid,PSNOWHEATXY , "PSNOWHEAT" , layers="MAXS") + call define_rst_var(ncid,PSNOWHISTXY , "PSNOWHIST" , layers="MAXS") + call define_rst_var(ncid,PSNOWLIQXY , "PSNOWLIQ" , layers="MAXS") + call define_rst_var(ncid,PSNOWRHOXY , "PSNOWRHO" , layers="MAXS") + call define_rst_var(ncid,PSNOWSWEXY , "PSNOWSWE" , layers="MAXS") + call define_rst_var(ncid,PSNOWTEMPXY , "PSNOWTEMP" , layers="MAXS") + call define_rst_var(ncid,PSNOWALBXY , "PSNOWALB" ) + call define_rst_var(ncid,PSNOWHEIGHTXY , "PSNOWHEIGHT" ) + call define_rst_var(ncid,PSNOWTHRUFALXY, "PSNOWTHRUFAL") + call define_rst_var(ncid,PSNOWTOTSWEXY , "PSNOWTOTSWE" ) + call define_rst_var(ncid,FLOW_SNOW , "FLOW_SNOW" ) + call define_rst_var(ncid,FLOW_ICE , "FLOW_ICE" ) + end if ! crocus_opt /= 0 #ifdef WRF_HYDRO call define_rst_var(ncid,ACCPRCP , "ACCPRCP" ) call define_rst_var(ncid,ACCECAN , "ACCECAN" ) diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F index 588b836a3..b1817661c 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_hrldas_netcdf_io.F @@ -22,6 +22,7 @@ module module_hrldas_netcdf_io use module_date_utilities use netcdf use module_hydro_stop, only:HYDRO_stop + use, intrinsic :: ieee_arithmetic, only: IEEE_Value, IEEE_QUIET_NAN #ifdef MPP_LAND use module_mpp_land, only:mpp_land_bcast_int1, decompose_data_real, mpp_land_bcast_real1, decompose_data_int, & @@ -63,6 +64,8 @@ module module_hrldas_netcdf_io integer, private :: dimid_times_remember integer, private :: dimid_layers_remember integer, private :: dimid_snow_layers_remember + integer, private :: dimid_glacier_layers_remember + integer, private :: crocus_opt = 0 interface define_rst_var module procedure define_3d_real,define_2d_real,define_2d_int @@ -584,13 +587,16 @@ subroutine readland_hrldas(wrfinput_flnm, & xstart, xend, & ystart, yend, & iswater, islake, vegtyp, soltyp, terrain, tbot_2d, latitude, & - longitude, xland, seaice, msftx, msfty) + longitude, xland, seaice, msftx, msfty, & + local_crocus_opt, glacinfo, glact, vis_icealb) implicit none character(len=*), intent(in) :: wrfinput_flnm integer, intent(in) :: xstart, xend, ystart, yend integer, intent(in) :: iswater integer, intent(in) :: islake integer, dimension(xstart:xend,ystart:yend), intent(out) :: vegtyp, soltyp + integer, intent(in) :: local_crocus_opt + integer, dimension(xstart:xend,ystart:yend), intent(out), optional :: glacinfo real, dimension(xstart:xend,ystart:yend), intent(out) :: terrain real, dimension(xstart:xend,ystart:yend), intent(out) :: tbot_2d real, dimension(xstart:xend,ystart:yend), intent(out) :: latitude @@ -599,6 +605,8 @@ subroutine readland_hrldas(wrfinput_flnm, & real, dimension(xstart:xend,ystart:yend), intent(out) :: seaice real, dimension(xstart:xend,ystart:yend), intent(out) :: msftx real, dimension(xstart:xend,ystart:yend), intent(out) :: msfty + real, dimension(xstart:xend,ystart:yend), intent(out), optional :: glact + real, dimension(xstart:xend,ystart:yend), intent(out), optional :: vis_icealb character(len=256) :: units integer :: ierr @@ -606,6 +614,8 @@ subroutine readland_hrldas(wrfinput_flnm, & real, dimension(xstart:xend,ystart:yend) :: xdum integer :: rank + crocus_opt = local_crocus_opt ! setting module scope variable + #ifdef _PARALLEL_ call MPI_COMM_RANK(HYDRO_COMM_WORLD, rank, ierr) if (ierr /= MPI_SUCCESS) stop "FATAL ERROR: In module_hrldas_netcdf_io.F readland_hrldas()"// & @@ -671,10 +681,40 @@ subroutine readland_hrldas(wrfinput_flnm, & if (ierr /= 0) print*, 'Did not find MAPFAC_MY, only needed for iopt_run=5' ! Get Dominant Land Use categories (use) - call get_landuse_netcdf(ncid, xdum , units, xstart, xend, ystart, yend) + call get_landuse_or_glacinfo_netcdf("landuse",ncid, xdum , units, xstart, xend, ystart, yend, FATAL, ierr) vegtyp = nint(xdum) ! print*, 'vegtyp(xstart,ystart) = ', vegtyp(xstart,ystart) + ! Get Glacier info (glacinfo) + ! - crocus_opt = 0 : don't read in + ! - crocus_opt = 1 + ! - no glacier or glacier_thickness: ERROR + ! - glacier = 0: WARNING + if (crocus_opt /= 0) then + call get_landuse_or_glacinfo_netcdf("glacinfo", ncid, xdum , units, xstart, xend, ystart, yend, NOT_FATAL, ierr) + if (ierr == 0) then + glacinfo = nint(xdum) + else + stop "FATAL ERROR: In module_hrldas_netcdf_io.F readland_hrldas()"// & + " - crocus_opt on but netcdf read of glacinfo returned non-zero" + end if + ! Get Glacier thickness (glact) + call get_2d_netcdf("glacier_thickness", ncid, glact, units, xstart, xend, ystart, yend, NOT_FATAL, ierr) + if (ierr /= 0) then + glact = 0.0 + print *, "WARNING: crocus_opt on but get_2d_netcdf of glacier_thickness returned", ierr, & + ". Setting glacier thickness to 0.0" + end if + + ! Get visible ice albedo map (vis_icealb) + call get_2d_netcdf("min_vis", ncid, vis_icealb, units, xstart, xend, ystart, yend, NOT_FATAL, ierr) + if (ierr /= 0) then + vis_icealb = IEEE_VALUE(vis_icealb, IEEE_QUIET_NAN) + print*, 'WARNING: crocus_opt on but did not find min_vis, setting to NaN' + end if + end if ! crocus_opt /= 0 + + ! Get Dominant Soil Type categories in the top layer (stl) call get_soilcat_netcdf(ncid, xdum , units, xstart, xend, ystart, yend) soltyp = nint(xdum) @@ -1189,34 +1229,63 @@ subroutine read_3d_soil(spatial_filename,xstart, xend,ystart, yend, & end subroutine read_3d_soil +!--------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------- - subroutine get_landuse_netcdf(ncid, array, units, xstart, xend, ystart, yend) + subroutine get_landuse_or_glacinfo_netcdf(in_name, ncid, array, units, & + xstart, xend, ystart, yend, & + fatal, ierr) implicit none + character(len=*), intent(in) :: in_name integer, intent(in) :: ncid integer, intent(in) :: xstart, xend, ystart, yend + logical, intent(in) :: fatal real, dimension(xstart:xend,ystart:yend), intent(out) :: array character(len=256), intent(out) :: units + integer, intent(out) :: ierr integer :: iret, varid - character(len=24), parameter :: name = "IVGTYP" - + character(len=24) :: name + ierr = 0 units = " " + if (trim(in_name) == "landuse") then + name = "IVGTYP" + else if (trim(in_name) == "glacinfo") then + name = "glacier" + end if + + iret = nf90_inq_varid(ncid, trim(name), varid) if (iret /= 0) then - print*, 'name = "', trim(name)//'"' - stop "FATAL ERROR: In module_hrldas_netcdf_io.F get_landuse_netcdf()"// & - " - MODULE_NOAHLSM_HRLDAS_INPUT: nf90_inq_varid" - endif + ierr = iret + call report_landuse_or_glacinfo_error(name, fatal) + end if iret = nf90_get_var(ncid, varid, array, (/xstart, ystart/), (/xend-xstart+1, yend-ystart+1/)) if (iret /= 0) then - print*, 'name = "', trim(name)//'"' - stop "FATAL ERROR: In module_hrldas_netcdf_io.F get_landuse_netcdf()"// & - " - MODULE_NOAHLSM_HRLDAS_INPUT: nf90_get_var" - endif + ierr = iret + call report_landuse_or_glacinfo_error(name, fatal) + end if + end subroutine get_landuse_or_glacinfo_netcdf - end subroutine get_landuse_netcdf + subroutine report_landuse_or_glacinfo_error(name, fatal) + implicit none + character(len=24), intent(in) :: name + logical, intent(in) :: fatal + character(len=142), parameter :: land_error = & + "FATAL ERROR: In module_hrldas_netcdf_io.F get_landuse_or_glacinfo_netcdf() & + &- MODULE_NOAHLSM_HRLDAS_INPUT: nf90_inq_varid for variable landuse" + character(len=142), parameter :: glacier_error = & + "FATAL ERROR: In module_hrldas_netcdf_io.F get_landuse_or_glacinfo_netcdf() & + &- MODULE_NOAHLSM_HRLDAS_INPUT: nf90_inq_varid for variable glacier" + if (fatal .eqv. .true.) return + print*, 'name = "', trim(name)//'"' + if (trim(name) == "landuse") then + stop land_error + else + stop glacier_error + end if + end subroutine report_landuse_or_glacinfo_error !--------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------- @@ -2255,12 +2324,12 @@ end subroutine READSNOW_HRLDAS !--------------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------------- #ifdef MPP_LAND - subroutine prepare_output_file_mpp(outdir, version, igrid, & + subroutine prepare_output_file_mpp(outdir, version, igrid, & output_timestep, llanduse, split_output_count, hgrid, & ixfull, jxfull, ixpar, jxpar, xstartpar, ystartpar, iswater, & mapproj, lat1, lon1, dx, dy, truelat1, truelat2, cen_lon, & nsoil, nsnow, sldpth, startdate, date, & - vegtyp, soltyp) + vegtyp, soltyp, act_level) implicit none @@ -2288,6 +2357,7 @@ subroutine prepare_output_file_mpp(outdir, version, igrid, & real, intent(in) :: cen_lon integer, intent(in) :: nsoil integer, intent(in) :: nsnow + integer, optional, intent(in) :: act_level real, dimension(nsoil), intent(in) :: sldpth character(len=19), intent(in) :: startdate character(len=19), intent(in) :: date @@ -2296,7 +2366,6 @@ subroutine prepare_output_file_mpp(outdir, version, igrid, & integer, dimension(global_nx,global_ny) :: g_vegtyp integer, dimension(global_nx,global_ny) :: g_soltyp - call write_io_int(vegtyp, g_vegtyp) call write_io_int(soltyp, g_soltyp) @@ -2306,7 +2375,7 @@ subroutine prepare_output_file_mpp(outdir, version, igrid, & global_nx, global_ny, global_nx, global_ny, xstartpar, ystartpar, iswater, & mapproj, lat1, lon1, dx, dy, truelat1, truelat2, cen_lon, & nsoil, nsnow, sldpth, startdate, date, & - g_vegtyp, g_soltyp) + g_vegtyp, g_soltyp, act_level) end if end subroutine prepare_output_file_mpp @@ -2317,7 +2386,7 @@ subroutine prepare_output_file_seq(outdir, version, igrid, & ixfull, jxfull, ixpar, jxpar, xstartpar, ystartpar, iswater, & mapproj, lat1, lon1, dx, dy, truelat1, truelat2, cen_lon, & nsoil, nsnow, sldpth, startdate, date, & - vegtyp, soltyp) + vegtyp, soltyp, act_level) ! To prepare the output file, we create the file, write dimensions and attributes, write the time variable. ! At the end of this routine, the output file is out of define mode. implicit none @@ -2347,6 +2416,7 @@ subroutine prepare_output_file_seq(outdir, version, igrid, & real, intent(in) :: cen_lon integer, intent(in) :: nsoil integer, intent(in) :: nsnow + integer, optional, intent(in) :: act_level real, dimension(nsoil), intent(in) :: sldpth character(len=19), intent(in) :: startdate character(len=19), intent(in) :: date @@ -2357,6 +2427,7 @@ subroutine prepare_output_file_seq(outdir, version, igrid, & integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n integer :: dimid_dum, dimid_layers, dimid_snow_layers + integer :: dimid_glacier_layers integer :: iret character(len=256) :: output_flnm character(len=19) :: date19 @@ -2397,7 +2468,8 @@ subroutine prepare_output_file_seq(outdir, version, igrid, & !iret = nf90_def_dim(ncid, "south_north_stag", jxfull+1, dimid_dum) iret = nf90_def_dim(ncid, "soil_layers_stag", nsoil, dimid_layers) iret = nf90_def_dim(ncid, "snow_layers", nsnow, dimid_snow_layers) - + if (crocus_opt /= 0) & + iret = nf90_def_dim(ncid, "glacier_levels", act_level, dimid_glacier_layers) iret = nf90_put_att(ncid, NF90_GLOBAL, "TITLE", "OUTPUT FROM HRLDAS "//version) iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -1.E33) @@ -2453,6 +2525,8 @@ subroutine prepare_output_file_seq(outdir, version, igrid, & dimid_times_remember = dimid_times dimid_layers_remember = dimid_layers dimid_snow_layers_remember = dimid_snow_layers + if (crocus_opt /= 0) & + dimid_glacier_layers_remember = dimid_glacier_layers iswater_remember = iswater allocate(vegtyp_remember(ixpar,jxpar)) @@ -2530,7 +2604,6 @@ subroutine finalize_output_file(split_output_count) !yw deallocate(vegtyp_remember) if(allocated(vegtyp_remember)) deallocate(vegtyp_remember) - end subroutine finalize_output_file !--------------------------------------------------------------------------------------------------------- @@ -2690,6 +2763,8 @@ subroutine add_to_output_3d ( array, name, description, units, snow_or_soil, var zdimid = dimid_layers_remember elseif (snow_or_soil == "SNOW") then zdimid = dimid_snow_layers_remember + elseif (snow_or_soil == "MAXS") then + zdimid = dimid_glacier_layers_remember else write(*,'("SNOW_OR_SOIL unrecognized: ", A)') adjustl(trim(snow_or_soil)) stop "FATAL ERROR: In module_hrldas_netcdf_io.F add_to_output_3d() - SNOW_OR_SOIL" @@ -2911,9 +2986,11 @@ end subroutine finalize_restart_file #ifdef MPP_LAND subroutine prepare_restart_file_mpp(outdir, version, igrid, llanduse, olddate, startdate, & - ixfull, jxfull, ixpar, jxpar, xstartpar, ystartpar, & - nsoil, nsnow, dx, dy, truelat1, truelat2, mapproj, lat1, lon1, cen_lon, & - iswater, vegtyp) + ixfull, jxfull, ixpar, jxpar, xstartpar, ystartpar, & + nsoil, nsnow, dx, dy, truelat1, truelat2, mapproj, & + lat1, lon1, cen_lon, iswater, vegtyp, glacinfo, & + glact, act_level, vis_icealb) + implicit none @@ -2931,6 +3008,7 @@ subroutine prepare_restart_file_mpp(outdir, version, igrid, llanduse, olddate, s integer, intent(in) :: ystartpar integer, intent(in) :: nsoil integer, intent(in) :: nsnow + integer, optional, intent(in) :: act_level real, intent(in) :: dx, dy real, intent(in) :: truelat1, truelat2 integer, intent(in) :: mapproj @@ -2938,13 +3016,16 @@ subroutine prepare_restart_file_mpp(outdir, version, igrid, llanduse, olddate, s integer, intent(in) :: iswater integer, dimension(ixpar,jxpar), intent(in) :: vegtyp integer, dimension(global_nx,global_ny) :: gvegtyp + integer, dimension(ixpar,jxpar), optional, intent(in) :: glacinfo + real, dimension(ixpar,jxpar), optional, intent(in) :: glact + real, dimension(ixpar,jxpar), intent(in) :: vis_icealb call write_io_int(vegtyp, gvegtyp) if(my_id .eq. io_id) then call prepare_restart_file_seq(outdir, version, igrid, llanduse, olddate, startdate, & global_nx, global_ny, global_nx, global_ny, xstartpar, ystartpar, & nsoil, nsnow, dx, dy, truelat1, truelat2, mapproj, lat1, lon1, cen_lon, & - iswater, gvegtyp) + iswater, gvegtyp, act_level) endif call mpp_land_sync() @@ -2955,7 +3036,7 @@ end subroutine prepare_restart_file_mpp subroutine prepare_restart_file_seq(outdir, version, igrid, llanduse, olddate, startdate, & ixfull, jxfull, ixpar, jxpar, xstartpar, ystartpar, & nsoil, nsnow, dx, dy, truelat1, truelat2, mapproj, lat1, lon1, cen_lon, & - iswater, vegtyp) + iswater, vegtyp, act_level) implicit none #include @@ -2974,6 +3055,7 @@ subroutine prepare_restart_file_seq(outdir, version, igrid, llanduse, olddate, s integer, intent(in) :: ystartpar integer, intent(in) :: nsoil integer, intent(in) :: nsnow + integer, optional, intent(in) :: act_level real, intent(in) :: dx, dy real, intent(in) :: truelat1, truelat2 integer, intent(in) :: mapproj @@ -2987,6 +3069,7 @@ subroutine prepare_restart_file_seq(outdir, version, igrid, llanduse, olddate, s integer :: ierr integer :: varid integer :: dimid_times, dimid_datelen, dimid_ix, dimid_jx, dimid_dum, dimid_layers, dimid_snow_layers, dimid_sosn_layers + integer :: dimid_glacier_layers character(len=19) :: date19 integer :: rank @@ -3002,7 +3085,6 @@ subroutine prepare_restart_file_seq(outdir, version, igrid, llanduse, olddate, s #endif - write(output_flnm, '(A,"/RESTART.",A10,"_DOMAIN",I1)') trim(outdir), olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13), igrid if (rank==0) then #ifdef HYDRO_D @@ -3036,6 +3118,8 @@ subroutine prepare_restart_file_seq(outdir, version, igrid, llanduse, olddate, s ierr = nf90_def_dim(ncid, "soil_layers_stag", nsoil, dimid_layers) ierr = nf90_def_dim(ncid, "snow_layers", nsnow, dimid_snow_layers) ierr = nf90_def_dim(ncid, "sosn_layers", nsnow+nsoil, dimid_sosn_layers) + if (crocus_opt /= 0) & + ierr = nf90_def_dim(ncid, "glacier_levels", act_level, dimid_glacier_layers) ierr = nf90_put_att(ncid, NF90_GLOBAL, "TITLE", "RESTART FILE FROM HRLDAS "//version) ierr = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -1.E33) @@ -3851,10 +3935,14 @@ subroutine define_3d_real(ncid, array,name,units,description, layers) ierr = nf90_inq_dimid(ncid, "sosn_layers", dimid_kx) call error_handler(ierr, "In module_hrldas_netcdf_io.F add_to_restart_3d() - "// & "Problem nf90_inq_dimid for 'sosn_layers'") + else if (output_layers == "MAXS" .and. crocus_opt /= 0) then + ierr = nf90_inq_dimid(ncid, "glacier_levels", dimid_kx) + call error_handler(ierr, "In module_hrldas_netcdf_io.F add_to_restart_3d() - "// & + "Problem nf90_inq_dimid for 'glacier_levels'") else stop "FATAL ERROR: In module_hrldas_netcdf_io.F add_to_restart_3d() - PANIC!" endif - call make_var_att_3d(ncid, dimid_ix, dimid_jx, dimid_times, NF90_FLOAT, dimid_kx, name, "", "") + call make_var_att_3d(ncid, dimid_ix, dimid_jx, dimid_times, NF90_FLOAT, dimid_kx, name, "", "") end subroutine define_3d_real diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/Makefile b/trunk/NDHMS/Land_models/NoahMP/phys/Makefile index 3cdaf1097..a53592f5e 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/Makefile +++ b/trunk/NDHMS/Land_models/NoahMP/phys/Makefile @@ -1,35 +1,33 @@ -# Makefile +# Makefile # -.SUFFIXES: -.SUFFIXES: .o .F - include ../user_build_options -OBJS = \ - module_sf_noahmpdrv.o \ - module_sf_noahmplsm.o \ - module_sf_noahmp_glacier.o \ - module_sf_noahmp_groundwater.o - +SRCS := $(wildcard *.F) +OBJS := $(SRCS:%.F=%.o) +SUR_SRCS := $(wildcard surfex/*.F) +SUR_OBJS := $(SUR_SRCS:%.F=%.o) CPPHRLDAS = -D_HRLDAS_OFFLINE_ -all: $(OBJS) +all: $(OBJS) -.F.o: +%.o:%.F @echo "" - $(COMPILERF90) $(CPPINVOKE) $(CPPFLAGS) $(CPPHRLDAS) -o $(@) -c -I../Utility_routines $(F90FLAGS) $(LDFLAGS) $(FREESOURCE) $(*).F + $(COMPILERF90) $(CPPINVOKE) $(CPPFLAGS) $(CPPHRLDAS) -o $(@) -c -I../Utility_routines -Isurfex $(F90FLAGS) $(LDFLAGS) $(FREESOURCE) $(*).F @echo "" +surfex/%.o: + $(MAKE) --directory=surfex/ + # # Dependencies: # -module_sf_noahmpdrv.o: module_sf_noahmplsm.o module_sf_noahmp_glacier.o module_sf_noahmp_groundwater.o +module_sf_noahmpdrv.o: module_sf_noahmplsm.o module_sf_noahmp_glacier.o module_sf_noahmp_groundwater.o module_snowcro.o module_sf_noahmp_groundwater.o: module_sf_noahmplsm.o +module_snowcro.o: $(SUR_OBJS) # # This command cleans up object (etc) files: # - clean: + $(MAKE) clean --directory=surfex $(RM) *.o *.mod *.stb *~ - diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F index a9bfba175..1818b372f 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmp_glacier.F @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: MODULE NOAHMP_GLACIER_GLOBALS @@ -63,7 +63,7 @@ MODULE NOAHMP_GLACIER_GLOBALS INTEGER :: OPT_TBOT != 2 !(suggested 2) -! options for snow/soil temperature time scheme (only layer 1) +! options for snow/soil teperature time scheme (only layer 1) ! 1 -> semi-implicit; 2 -> full implicit (original Noah) INTEGER :: OPT_STC != 1 !(suggested 1) @@ -97,13 +97,13 @@ MODULE NOAHMP_GLACIER_ROUTINES private :: CSNOW_GLACIER private :: RADIATION_GLACIER private :: SNOW_AGE_GLACIER - private :: SNOWALB_BATS_GLACIER + private :: SNOWALB_BATS_GLACIER private :: SNOWALB_CLASS_GLACIER private :: GLACIER_FLUX - private :: SFCDIF1_GLACIER + private :: SFCDIF1_GLACIER private :: TSNOSOI_GLACIER private :: HRT_GLACIER - private :: HSTEP_GLACIER + private :: HSTEP_GLACIER private :: ROSR12_GLACIER private :: PHASECHANGE_GLACIER @@ -127,10 +127,10 @@ SUBROUTINE NOAHMP_GLACIER (& SFCTMP ,SFCPRS ,UU ,VV ,Q2 ,SOLDN , & ! IN : Forcing PRCP ,LWDN ,TBOT ,ZLVL ,FICEOLD ,ZSOIL , & ! IN : Forcing SWE_LIMIT , & ! IN : Forcing - QSNOW, QRAIN, SNEQVO, ALBOLD, CM, CH ,ISNOW , & ! IN/OUT : + QSNOW, QRAIN, SNEQVO, ALBOLD, CM, CH ,ISNOW , & ! IN/OUT : SNEQV ,SMC ,ZSNSO ,SNOWH ,SNICE ,SNLIQ , & ! IN/OUT : - TG ,STC ,SH2O ,TAUSS ,QSFC , & ! IN/OUT : - FSA ,FSR ,FIRA ,FSH ,FGEV ,SSOIL , & ! OUT : + TG ,STC ,SH2O ,TAUSS ,QSFC , & ! IN/OUT : + FSA ,FSR ,FIRA ,FSH ,FGEV ,SSOIL , & ! OUT : TRAD ,EDIR ,RUNSRF ,RUNSUB ,SAG ,ALBEDO , & ! OUT : QSNBOT ,PONDING ,PONDING1,PONDING2,T2M ,Q2E , & ! OUT : EMISSI, FPICE, CH2B & ! OUT : @@ -149,8 +149,8 @@ SUBROUTINE NOAHMP_GLACIER (& INTEGER , INTENT(IN) :: ILOC !grid index INTEGER , INTENT(IN) :: JLOC !grid index REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER , INTENT(IN) :: NSOIL !no. of soil layers + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !no. of soil layers REAL , INTENT(IN) :: DT !time step [sec] REAL , INTENT(IN) :: SFCTMP !surface air temperature [K] REAL , INTENT(IN) :: SFCPRS !pressure (pa) @@ -201,7 +201,7 @@ SUBROUTINE NOAHMP_GLACIER (& REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] REAL , INTENT(OUT) :: TRAD !surface radiative temperature (k) REAL , INTENT(OUT) :: EDIR !soil surface evaporation rate (mm/s] - REAL , INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(OUT) :: RUNSRF !surface runoff [mm/s] REAL , INTENT(OUT) :: RUNSUB !baseflow (saturation excess) [mm/s] REAL , INTENT(OUT) :: SAG !solar rad absorbed by ground (w/m2) REAL , INTENT(OUT) :: ALBEDO !surface albedo [-] @@ -235,14 +235,14 @@ SUBROUTINE NOAHMP_GLACIER (& REAL :: QMELT !internal pack melt REAL :: SWDOWN !downward solar [w/m2] REAL :: BEG_WB !beginning water for error check - REAL :: ZBOT = -8.0 + REAL :: ZBOT = -8.0 CHARACTER*256 message ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing - CALL ATM_GLACIER (SFCPRS ,SFCTMP ,Q2 ,SOLDN ,COSZ ,THAIR , & + CALL ATM_GLACIER (SFCPRS ,SFCTMP ,Q2 ,SOLDN ,COSZ ,THAIR , & QAIR ,EAIR ,RHOAIR ,SOLAD ,SOLAI ,SWDOWN ) BEG_WB = SNEQV @@ -257,7 +257,7 @@ SUBROUTINE NOAHMP_GLACIER (& END IF END DO -! compute energy budget (momentum & energy fluxes and phase changes) +! compute energy budget (momentum & energy fluxes and phase changes) CALL ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !in EAIR ,SFCPRS ,QAIR ,SFCTMP ,LWDN ,UU , & !in @@ -270,7 +270,7 @@ SUBROUTINE NOAHMP_GLACIER (& SAG ,FSA ,FSR ,FIRA ,FSH ,FGEV , & !out TRAD ,T2M ,SSOIL ,LATHEA ,Q2E ,EMISSI, CH2B ) !out - SICE = MAX(0.0, SMC - SH2O) + SICE = MAX(0.0, SMC - SH2O) SNEQVO = SNEQV QVAP = MAX( FGEV/LATHEA, 0.) ! positive part of fgev [mm/s] > 0 @@ -298,7 +298,7 @@ SUBROUTINE NOAHMP_GLACIER (& WRITE(message,*) "GLACIER HAS MELTED AT:",ILOC,JLOC," ARE YOU SURE THIS SHOULD BE A GLACIER POINT?" CALL wrf_debug(10,TRIM(message)) END IF - + ! water and energy balance check CALL ERROR_GLACIER (ILOC ,JLOC ,SWDOWN ,FSA ,FSR ,FIRA , & @@ -315,13 +315,13 @@ SUBROUTINE NOAHMP_GLACIER (& ELSE ALBEDO = -999.9 END IF - + END SUBROUTINE NOAHMP_GLACIER ! ================================================================================================== SUBROUTINE ATM_GLACIER (SFCPRS ,SFCTMP ,Q2 ,SOLDN ,COSZ ,THAIR , & QAIR ,EAIR ,RHOAIR ,SOLAD ,SOLAI , & - SWDOWN ) + SWDOWN ) ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing ! -------------------------------------------------------------------------------------------------- @@ -351,18 +351,18 @@ SUBROUTINE ATM_GLACIER (SFCPRS ,SFCTMP ,Q2 ,SOLDN ,COSZ ,THAIR , & ! -------------------------------------------------------------------------------------------------- PAIR = SFCPRS ! atm bottom level pressure (pa) - THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) + THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) ! QAIR = Q2 / (1.0+Q2) ! mixing ratio to specific humidity [kg/kg] QAIR = Q2 ! In WRF, driver converts to specific humidity EAIR = QAIR*SFCPRS / (0.622+0.378*QAIR) RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP) - IF(COSZ <= 0.) THEN + IF(COSZ <= 0.) THEN SWDOWN = 0. ELSE SWDOWN = SOLDN - END IF + END IF SOLAD(1) = SWDOWN*0.7*0.5 ! direct vis SOLAD(2) = SWDOWN*0.7*0.5 ! direct nir @@ -391,7 +391,7 @@ SUBROUTINE ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !i IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! inputs - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers INTEGER , INTENT(IN) :: NSOIL !number of soil layers INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers REAL , INTENT(IN) :: DT !time step [sec] @@ -408,7 +408,7 @@ SUBROUTINE ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !i REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAI !incoming diffuse solar rad. (w/m2) REAL , INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) REAL , INTENT(IN) :: ZREF !reference height (m) - REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. (k) + REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. (k) REAL , INTENT(IN) :: ZBOT !depth for TBOT [m] REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bottom depth from snow surf [m] REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !depth of snow & soil layer-bottom [m] @@ -514,7 +514,7 @@ SUBROUTINE ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !i EAIR ,STC ,SAG ,SNOWH ,LATHEA ,SH2O , & !in CM ,CH ,TG ,QSFC , & !inout FIRA ,FSH ,FGEV ,SSOIL , & !out - T2M ,Q2E ,CH2B) !out + T2M ,Q2E ,CH2B) !out !energy balance at surface: SAG=(IRB+SHB+EVB+GHB) @@ -528,7 +528,7 @@ SUBROUTINE ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !i ! When we're computing a TRAD, subtract from the emitted IR the ! reflected portion of the incoming LWDN, so we're just ! considering the IR originating in the canopy/ground system. - + TRAD = ( ( FIRE - (1-EMISSI)*LWDN ) / (EMISSI*SB) ) ** 0.25 ! 3L snow & 4L soil temperatures @@ -558,13 +558,13 @@ SUBROUTINE THERMOPROP_GLACIER (NSOIL ,NSNOW ,ISNOW ,DZSNSO , & !in DT ,SNOWH ,SNICE ,SNLIQ , & !in DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out FACT ) !out -! ------------------------------------------------------------------------------------------------- +! ------------------------------------------------------------------------------------------------- ! ------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! inputs INTEGER , INTENT(IN) :: NSOIL !number of soil layers - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers REAL , INTENT(IN) :: DT !time step [s] REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) @@ -585,7 +585,10 @@ SUBROUTINE THERMOPROP_GLACIER (NSOIL ,NSNOW ,ISNOW ,DZSNSO , & !in INTEGER :: IZ, IZ2 REAL, DIMENSION(-NSNOW+1: 0) :: CVSNO !volumetric specific heat (j/m3/k) REAL, DIMENSION(-NSNOW+1: 0) :: TKSNO !snow thermal conductivity (j/m3/k) - REAL :: ZMID !mid-point soil depth + +!++ Model crashed (divided by zero) with REAL instead of REAL*8 + REAL*8 :: ZMID !mid-point soil depth + ! -------------------------------------------------------------------------------------------------- ! compute snow thermal conductivity and heat capacity @@ -608,7 +611,7 @@ SUBROUTINE THERMOPROP_GLACIER (NSOIL ,NSNOW ,ISNOW ,DZSNSO , & !in HCPCT(IZ) = 1.E6 * ( 0.8194 + 0.1309*ZMID ) DF(IZ) = 0.32333 + ( 0.10073 * ZMID ) END DO - + ! combine a temporary variable used for melting/freezing of snow and frozen soil DO IZ = ISNOW+1,NSOIL @@ -618,7 +621,7 @@ SUBROUTINE THERMOPROP_GLACIER (NSOIL ,NSNOW ,ISNOW ,DZSNSO , & !in ! snow/soil interface IF(ISNOW == 0) THEN - DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH) / (SNOWH +DZSNSO(1)) + DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH) / (SNOWH +DZSNSO(1)) ELSE DF(1) = (DF(1)*DZSNSO(1)+DF(0)*DZSNSO(0)) / (DZSNSO(0)+DZSNSO(1)) END IF @@ -636,11 +639,11 @@ SUBROUTINE CSNOW_GLACIER (ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , !--------------------------------------------------------------------------------------------------- ! inputs - INTEGER, INTENT(IN) :: ISNOW !number of snow layers (-) - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: ISNOW !number of snow layers (-) + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers INTEGER , INTENT(IN) :: NSOIL !number of soil layers REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] ! outputs @@ -749,7 +752,7 @@ SUBROUTINE RADIATION_GLACIER (DT ,TG ,SNEQVO ,SNEQV ,COSZ , & !i SAG = 0. FSA = 0. FSR = 0. - + FSNO = 0.0 IF(SNEQV > 0.0) FSNO = 1.0 @@ -765,10 +768,10 @@ SUBROUTINE RADIATION_GLACIER (DT ,TG ,SNEQVO ,SNEQV ,COSZ , & !i ABS = SOLAD(IB)*(1.-ALBSND(IB)) + SOLAI(IB)*(1.-ALBSNI(IB)) SAG = SAG + ABS FSA = FSA + ABS - + REF = SOLAD(IB)*ALBSND(IB) + SOLAI(IB)*ALBSNI(IB) FSR = FSR + REF - + END DO END SUBROUTINE RADIATION_GLACIER @@ -849,7 +852,7 @@ SUBROUTINE SNOWALB_BATS_GLACIER (NBAND,COSZ,FAGE,ALBSND,ALBSNI) REAL :: SL2 !2.*SL REAL :: SL1 !1/SL REAL :: SL !adjustable parameter - REAL, PARAMETER :: C1 = 0.2 !default in BATS + REAL, PARAMETER :: C1 = 0.2 !default in BATS REAL, PARAMETER :: C2 = 0.5 !default in BATS ! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's ! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) @@ -867,8 +870,8 @@ SUBROUTINE SNOWALB_BATS_GLACIER (NBAND,COSZ,FAGE,ALBSND,ALBSNI) CF1=((1.+SL1)/(1.+SL2*COSZ)-SL1) FZEN=AMAX1(CF1,0.) - ALBSNI(1)=0.95*(1.-C1*FAGE) - ALBSNI(2)=0.65*(1.-C2*FAGE) + ALBSNI(1)=0.95*(1.-C1*FAGE) + ALBSNI(2)=0.65*(1.-C2*FAGE) ALBSND(1)=ALBSNI(1)+0.4*FZEN*(1.-ALBSNI(1)) ! vis direct ALBSND(2)=ALBSNI(2)+0.4*FZEN*(1.-ALBSNI(2)) ! nir direct @@ -890,7 +893,7 @@ SUBROUTINE SNOWALB_CLASS_GLACIER (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI) ! in & out - REAL, INTENT(INOUT) :: ALB ! + REAL, INTENT(INOUT) :: ALB ! ! output REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) @@ -927,7 +930,7 @@ SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z EAIR ,STC ,SAG ,SNOWH ,LATHEA ,SH2O , & !in CM ,CH ,TGB ,QSFC , & !inout IRB ,SHB ,EVB ,GHB , & !out - T2MB ,Q2B ,EHB2) !out + T2MB ,Q2B ,EHB2) !out ! -------------------------------------------------------------------------------------------------- ! use newton-raphson iteration to solve ground (tg) temperature @@ -941,7 +944,7 @@ SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z IMPLICIT NONE ! ---------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers INTEGER, INTENT(IN) :: NSOIL !number of soil layers REAL, INTENT(IN) :: EMG !ground emissivity INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers @@ -984,7 +987,7 @@ SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z REAL, INTENT(OUT) :: EHB2 !sensible heat conductance for diagnostics -! local variables +! local variables INTEGER :: NITERB !number of iterations for surface temperature REAL :: MPE !prevents overflow error if division by zero REAL :: DTG !change in tg, last iteration (k) @@ -1039,7 +1042,7 @@ SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z ! ----------------------------------------------------------------- loop3: DO ITER = 1, NITERB ! begin stability iteration - Z0H = Z0M + Z0H = Z0M ! For now, only allow SFCDIF1 until others can be fixed @@ -1133,7 +1136,7 @@ SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z Q2B = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF) ENDIF -! update CH +! update CH CH = 1./RAHB END SUBROUTINE GLACIER_FLUX @@ -1249,7 +1252,7 @@ SUBROUTINE SFCDIF1_GLACIER(ITER ,ZLVL ,ZPD ,Z0H ,Z0M , & !in ! Monin-Obukhov stability parameter moz for next iteration MOZOLD = MOZ - + IF(ZLVL <= ZPD) THEN write(*,*) 'WARNING: critical glacier problem: ZLVL <= ZPD; model stops', zlvl, zpd call wrf_error_fatal("STOP in Noah-MP glacier") @@ -1340,7 +1343,7 @@ SUBROUTINE SFCDIF1_GLACIER(ITER ,ZLVL ,ZPD ,Z0H ,Z0M , & !in CM = VKC*VKC/(CMFM*CMFM) CH = VKC*VKC/(CMFM*CHFH) CH2 = VKC*VKC/(CM2FM2*CH2FH2) - + ! friction velocity FV = UR * SQRT(CM) @@ -1406,7 +1409,7 @@ SUBROUTINE TSNOSOI_GLACIER (NSOIL ,NSNOW ,ISNOW ,DT ,TBOT , & !in CALL HSTEP_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT , & AI ,BI ,CI ,RHSTS , & - STC ) + STC ) END SUBROUTINE TSNOSOI_GLACIER ! ================================================================================================== @@ -1474,7 +1477,7 @@ SUBROUTINE HRT_GLACIER (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & !in DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) TEMP1 = ZSNSO(K-1) - ZSNSO(K) IF(OPT_TBOT == 1) THEN - BOTFLX = 0. + BOTFLX = 0. END IF IF(OPT_TBOT == 2) THEN DTSDZ(K) = (STC(K) - TBOT) / ( 0.5*(ZSNSO(K-1)+ZSNSO(K)) - ZBOT) @@ -1490,16 +1493,16 @@ SUBROUTINE HRT_GLACIER (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & !in CI(K) = - DF(K) * DDZ(K) / DENOM(K) IF (OPT_STC == 1 .OR. OPT_STC == 3) THEN BI(K) = - CI(K) - END IF + END IF IF (OPT_STC == 2) THEN BI(K) = - CI(K) + DF(K)/(0.5*ZSNSO(K)*ZSNSO(K)*HCPCT(K)) END IF ELSE IF (K < NSOIL) THEN - AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) - CI(K) = - DF(K ) * DDZ(K ) / DENOM(K) + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = - DF(K ) * DDZ(K ) / DENOM(K) BI(K) = - (AI(K) + CI (K)) ELSE IF (K == NSOIL) THEN - AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) CI(K) = 0.0 BI(K) = - (AI(K) + CI(K)) END IF @@ -1584,7 +1587,7 @@ SUBROUTINE ROSR12_GLACIER (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW) ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: NTOP + INTEGER, INTENT(IN) :: NTOP INTEGER, INTENT(IN) :: NSOIL,NSNOW INTEGER :: K, KK @@ -1663,8 +1666,8 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM !energy residual [w/m2] REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM !melting or freezing water [kg/m2] REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0 - REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0 - REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE !soil/snow ice mass [mm] REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ !soil/snow liquid water mass [mm] REAL, DIMENSION(-NSNOW+1:NSOIL) :: HEATR !energy residual or loss after melting/freezing @@ -1692,12 +1695,12 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & WLIQ0(J) = MLIQ(J) WMASS0(J) = MICE(J) + MLIQ(J) ENDDO - + DO J = ISNOW+1,0 - IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting + IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting IMELT(J) = 1 ENDIF - IF (MLIQ(J) > 0. .AND. STC(J) < TFRZ) THEN ! freezing + IF (MLIQ(J) > 0. .AND. STC(J) < TFRZ) THEN ! freezing IMELT(J) = 2 ENDIF @@ -1719,17 +1722,17 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & HM(J) = 0. IMELT(J) = 0 ENDIF - XM(J) = HM(J)*DT/HFUS + XM(J) = HM(J)*DT/HFUS ENDDO ! The rate of melting and freezing for snow without a layer, opt_gla==1 treated below -IF (OPT_GLA == 2) THEN +IF (OPT_GLA == 2) THEN - IF (ISNOW == 0 .AND. SNEQV > 0. .AND. STC(1) >= TFRZ) THEN + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. STC(1) >= TFRZ) THEN HM(1) = (STC(1)-TFRZ)/FACT(1) ! available heat STC(1) = TFRZ ! set T to freezing - XM(1) = HM(1)*DT/HFUS ! total snow melt possible + XM(1) = HM(1)*DT/HFUS ! total snow melt possible TEMP1 = SNEQV SNEQV = MAX(0.,TEMP1-XM(1)) ! snow remaining @@ -1737,7 +1740,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & SNOWH = MAX(0.,PROPOR * SNOWH) ! new snow height HEATR(1) = HM(1) - HFUS*(TEMP1-SNEQV)/DT ! excess heat IF (HEATR(1) > 0.) THEN - XM(1) = HEATR(1)*DT/HFUS + XM(1) = HEATR(1)*DT/HFUS STC(1) = STC(1) + FACT(1)*HEATR(1) ! re-heat ice ELSE XM(1) = 0. ! heat used up @@ -1756,11 +1759,11 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN HEATR(J) = 0. - IF (XM(J) > 0.) THEN + IF (XM(J) > 0.) THEN MICE(J) = MAX(0., WICE0(J)-XM(J)) HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT - ELSE IF (XM(J) < 0.) THEN - MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) + ELSE IF (XM(J) < 0.) THEN + MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT ENDIF @@ -1791,12 +1794,12 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & WLIQ0(J) = MLIQ(J) WMASS0(J) = MICE(J) + MLIQ(J) ENDDO - + DO J = 1,NSOIL - IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting + IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting IMELT(J) = 1 ENDIF - IF (MLIQ(J) > 0. .AND. STC(J) < TFRZ) THEN ! freezing + IF (MLIQ(J) > 0. .AND. STC(J) < TFRZ) THEN ! freezing IMELT(J) = 2 ENDIF @@ -1824,25 +1827,25 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & HM(J) = 0. IMELT(J) = 0 ENDIF - XM(J) = HM(J)*DT/HFUS + XM(J) = HM(J)*DT/HFUS ENDDO ! The rate of melting and freezing for snow without a layer, needs more work. - IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN TEMP1 = SNEQV - SNEQV = MAX(0.,TEMP1-XM(1)) + SNEQV = MAX(0.,TEMP1-XM(1)) PROPOR = SNEQV/TEMP1 SNOWH = MAX(0.,PROPOR * SNOWH) - HEATR(1) = HM(1) - HFUS*(TEMP1-SNEQV)/DT + HEATR(1) = HM(1) - HFUS*(TEMP1-SNEQV)/DT IF (HEATR(1) > 0.) THEN - XM(1) = HEATR(1)*DT/HFUS - HM(1) = HEATR(1) - IMELT(1) = 1 + XM(1) = HEATR(1)*DT/HFUS + HM(1) = HEATR(1) + IMELT(1) = 1 ELSE XM(1) = 0. HM(1) = 0. - IMELT(1) = 0 + IMELT(1) = 0 ENDIF QMELT = MAX(0.,(TEMP1-SNEQV))/DT XMF = HFUS*QMELT @@ -1855,11 +1858,11 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN HEATR(J) = 0. - IF (XM(J) > 0.) THEN + IF (XM(J) > 0.) THEN MICE(J) = MAX(0., WICE0(J)-XM(J)) HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT - ELSE IF (XM(J) < 0.) THEN - MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) + ELSE IF (XM(J) < 0.) THEN + MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT ENDIF @@ -1888,7 +1891,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & IF (ANY(STC(1:4) > TFRZ) .AND. ANY(STC(1:4) < TFRZ)) THEN DO J = 1,NSOIL - IF ( STC(J) > TFRZ ) THEN + IF ( STC(J) > TFRZ ) THEN HEATR(J) = (STC(J)-TFRZ)/FACT(J) DO K = 1,NSOIL IF (J .NE. K .AND. STC(K) < TFRZ .AND. HEATR(J) > 0.1) THEN @@ -1913,7 +1916,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & IF (ANY(STC(1:4) > TFRZ) .AND. ANY(STC(1:4) < TFRZ)) THEN DO J = 1,NSOIL - IF ( STC(J) < TFRZ ) THEN + IF ( STC(J) < TFRZ ) THEN HEATR(J) = (STC(J)-TFRZ)/FACT(J) DO K = 1,NSOIL IF (J .NE. K .AND. STC(K) > TFRZ .AND. HEATR(J) < -0.1) THEN @@ -1938,9 +1941,9 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & IF (ANY(STC(1:4) > TFRZ) .AND. ANY(MICE(1:4) > 0.)) THEN DO J = 1,NSOIL - IF ( STC(J) > TFRZ ) THEN + IF ( STC(J) > TFRZ ) THEN HEATR(J) = (STC(J)-TFRZ)/FACT(J) - XM(J) = HEATR(J)*DT/HFUS + XM(J) = HEATR(J)*DT/HFUS DO K = 1,NSOIL IF (J .NE. K .AND. MICE(K) > 0. .AND. XM(J) > 0.1) THEN IF (MICE(K) > XM(J)) THEN ! LAYER ABSORBS ALL @@ -1967,9 +1970,9 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & IF (ANY(STC(1:4) < TFRZ) .AND. ANY(MLIQ(1:4) > 0.)) THEN DO J = 1,NSOIL - IF ( STC(J) < TFRZ ) THEN + IF ( STC(J) < TFRZ ) THEN HEATR(J) = (STC(J)-TFRZ)/FACT(J) - XM(J) = HEATR(J)*DT/HFUS + XM(J) = HEATR(J)*DT/HFUS DO K = 1,NSOIL IF (J .NE. K .AND. MLIQ(K) > 0. .AND. XM(J) < -0.1) THEN IF (MLIQ(K) > ABS(XM(J))) THEN ! LAYER ABSORBS ALL @@ -1991,7 +1994,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & END IF END DO END IF - + END IF ! OPT_GLA == 1 DO J = ISNOW+1,0 ! snow @@ -2000,16 +2003,16 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & END DO DO J = 1, NSOIL ! soil - IF(OPT_GLA == 1) THEN + IF(OPT_GLA == 1) THEN SH2O(J) = MLIQ(J) / (1000. * DZSNSO(J)) SH2O(J) = MAX(0.0,MIN(1.0,SH2O(J))) ! SMC(J) = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J)) - ELSEIF(OPT_GLA == 2) THEN + ELSEIF(OPT_GLA == 2) THEN SH2O(J) = 0.0 ! ice, assume all frozen...forever END IF - SMC(J) = 1.0 + SMC(J) = 1.0 END DO - + END SUBROUTINE PHASECHANGE_GLACIER ! ================================================================================================== SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in @@ -2021,7 +2024,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in , sfcheadrt & #endif ) !out -! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- ! Code history: ! Initial code: Guo-Yue Niu, Oct. 2007 ! ---------------------------------------------------------------------- @@ -2055,7 +2058,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in REAL , INTENT(INOUT) :: FSH !total sensible heat (w/m2) [+ to atm] ! output - REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] REAL, INTENT(OUT) :: RUNSUB !baseflow (sturation excess) [mm/s] REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] REAL, INTENT(OUT) :: QRAIN !rain at ground srf (mm/s) [+] @@ -2150,7 +2153,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out !PONDING: melting water from snow when there is no layer - + RUNSRF = (PONDING+PONDING1+PONDING2)/DT IF(ISNOW == 0) THEN @@ -2162,20 +2165,20 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in #ifdef WRF_HYDRO RUNSRF = RUNSRF + sfcheadrt/DT !sfcheadrt units (mm) #endif - + IF(OPT_GLA == 1) THEN REPLACE = 0.0 DO ILEV = 1,NSOIL REPLACE = REPLACE + DZSNSO(ILEV)*(SICE(ILEV) - SICE_SAVE(ILEV) + SH2O(ILEV) - SH2O_SAVE(ILEV)) END DO REPLACE = REPLACE * 1000.0 / DT ! convert to [mm/s] - + SICE = MIN(1.0,SICE_SAVE) ELSEIF(OPT_GLA == 2) THEN SICE = 1.0 END IF SH2O = 1.0 - SICE - + ! use RUNSUB as a water balancer, SNOFLOW is snow that disappears, REPLACE is ! water from below that replaces glacier loss @@ -2271,7 +2274,7 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in ZSNSO(IZ) = 0. ENDDO - CALL SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + CALL SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in QRAIN , & !in ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout SNLIQ ,SH2O ,SICE ,STC , & !inout @@ -2279,15 +2282,16 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in QSNBOT ) !out !to obtain equilibrium state of snow in glacier region - + IF(SNEQV > SWE_LIMIT) THEN ! 2000 mm -> maximum water depth BDSNOW = SNICE(0) / DZSNSO(0) SNOFLOW = (SNEQV - SWE_LIMIT) - SNICE(0) = SNICE(0) - SNOFLOW + SNICE(0) = SNICE(0) - SNOFLOW DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW SNOFLOW = SNOFLOW / DT END IF + ! sum up snow mass for layered snow IF(ISNOW /= 0) THEN @@ -2362,7 +2366,7 @@ SUBROUTINE SNOWFALL_GLACIER (NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , & !in END IF ! creating a new layer - + IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.05) THEN ISNOW = -1 NEWNODE = 1 @@ -2407,11 +2411,11 @@ SUBROUTINE COMPACT_GLACIER (NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in ! local REAL, PARAMETER :: C2 = 21.e-3 ![m3/kg] ! default 21.e-3 - REAL, PARAMETER :: C3 = 2.5e-6 ![1/s] + REAL, PARAMETER :: C3 = 2.5e-6 ![1/s] REAL, PARAMETER :: C4 = 0.04 ![1/k] REAL, PARAMETER :: C5 = 2.0 ! REAL, PARAMETER :: DM = 100.0 !upper Limit on destructive metamorphism compaction [kg/m3] - REAL, PARAMETER :: ETA0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + REAL, PARAMETER :: ETA0 = 0.8e+6 !viscosity coefficient [kg-s/m2] !according to Anderson, it is between 0.52e6~1.38e6 REAL :: BURDEN !pressure of overlying snow [kg/m2] REAL :: DDZ1 !rate of settling of snow pack due to destructive metamorphism. @@ -2672,7 +2676,7 @@ SUBROUTINE COMBO_GLACIER(DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2) REAL, INTENT(INOUT) :: WICE !ice of element 1 [kg/m2] REAL, INTENT(INOUT) :: T !node temperature of element 1 [k] -! local +! local REAL :: DZC !total thickness of nodes 1 and 2 (DZC=DZ+DZ2). REAL :: WLIQC !combined liquid water [kg/m2] @@ -2718,7 +2722,7 @@ SUBROUTINE DIVIDE_GLACIER (NSNOW ,NSOIL , & !in ! input and output - INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers + INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] @@ -2831,7 +2835,7 @@ SUBROUTINE DIVIDE_GLACIER (NSNOW ,NSOIL , & !in END SUBROUTINE DIVIDE_GLACIER ! ================================================================================================== - SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in QRAIN , & !in ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout SNLIQ ,SH2O ,SICE ,STC , & !inout @@ -2897,7 +2901,7 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in ! for shallow snow without a layer ! snow surface sublimation may be larger than existing snow mass. To conserve water, -! excessive sublimation is used to reduce soil water. Smaller time steps would tend +! excessive sublimation is used to reduce soil water. Smaller time steps would tend ! to aviod this problem. IF(ISNOW == 0 .and. SNEQV > 0.) THEN @@ -2945,7 +2949,7 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in SNLIQ(ISNOW+1) = SNLIQ(ISNOW+1) + QRAIN * DT SNLIQ(ISNOW+1) = MAX(0., SNLIQ(ISNOW+1)) ENDIF - + ENDIF !KWM -- Can the ENDIF be moved toward the end of the subroutine (Just set QSNBOT=0)? ! Porosity and partial volume @@ -3013,7 +3017,7 @@ SUBROUTINE ERROR_GLACIER (ILOC ,JLOC ,SWDOWN ,FSA ,FSR ,FIRA , & REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) REAL , INTENT(IN) :: EDIR !soil surface evaporation rate[mm/s] - REAL , INTENT(IN) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(IN) :: RUNSRF !surface runoff [mm/s] REAL , INTENT(IN) :: RUNSUB !baseflow (saturation excess) [mm/s] REAL , INTENT(IN) :: SNEQV !snow water eqv. [mm] REAL , INTENT(IN) :: DT !time step [sec] @@ -3081,14 +3085,14 @@ SUBROUTINE NOAHMP_OPTIONS_GLACIER(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iop ! ------------------------------------------------------------------------------------------------- - opt_alb = iopt_alb - opt_snf = iopt_snf - opt_tbot = iopt_tbot + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot opt_stc = iopt_stc opt_gla = iopt_gla - + end subroutine noahmp_options_glacier - + END MODULE NOAHMP_GLACIER_ROUTINES ! ================================================================================================== diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F index 2a438986c..d6c48a6bc 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: MODULE module_sf_noahmpdrv @@ -30,7 +30,7 @@ MODULE module_sf_noahmpdrv CONTAINS ! SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN : Time/Space-related - DZ8W, DT, DZS, NSOIL, DX, & ! IN : Model configuration + DZ8W, DT, DZS, NSOIL, DX, & ! IN : Model configuration IVGTYP, ISLTYP, VEGFRA, VEGMAX, TMN, & ! IN : Vegetation/Soil characteristics XLAND, XICE,XICE_THRES, & ! IN : Vegetation/Soil characteristics IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & ! IN : User options @@ -59,6 +59,14 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN SHGXY, SHCXY, SHBXY, EVGXY, EVBXY, GHVXY, & ! OUT Noah MP only GHBXY, IRGXY, IRCXY, IRBXY, TRXY, EVCXY, & ! OUT Noah MP only CHLEAFXY, CHUCXY, CHV2XY, CHB2XY, & ! OUT Noah MP only + PSNOWLIQXY, PSNOWTEMPXY, PSNOWDZXY, & ! OUT for crocus + PSNOWHEATXY, PSNOWRHOXY, PSNOWSWEXY, & ! IN/OUT for crocus + PSNOWGRAN1XY, PSNOWGRAN2XY, PSNOWHISTXY, & ! IN/OUT for crocus + PSNOWALBXY, PSNOWAGEXY, act_level, & ! IN/OUT for crocus + PSNOWHEIGHTXY, PSNOWTOTSWEXY, PSNOWTHRUFALXY, & ! OUT for crocus + GLACINFO ,GLACT, & ! IN/OUT for crocus + FLOW_ICE, FLOW_SNOW, & ! OUT for crocus + crocus_opt, & ! IN for crocus #ifdef SPATIAL_SOIL BEXP_3D,SMCDRY_3D,SMCWLT_3D,SMCREF_3D,SMCMAX_3D, & DKSAT_3D,DWSAT_3D,PSISAT_3D,QUARTZ_3D, & @@ -74,7 +82,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - MP_RAINC, MP_RAINNC, MP_SHCV, MP_SNOW, MP_GRAUP, MP_HAIL & + MP_RAINC, MP_RAINNC, MP_SHCV, MP_SNOW, MP_GRAUP, MP_HAIL, & + VIS_ICEALB & #ifdef WRF_HYDRO , ACCPRCP, ACCECAN, ACCETRAN, ACCEDIR & ! NEW output accumulator variables , SOILSAT_TOP, SOILSAT, SOILICE, SNOWT_AVG & ! NEW soil saturation and snow temp @@ -84,6 +93,9 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN USE MODULE_SF_NOAHMPLSM USE module_sf_noahmp_glacier USE NOAHMP_TABLES, ONLY: ISICE_TABLE, CO2_TABLE, O2_TABLE, HVB_TABLE, HVT_TABLE + USE module_snowcro + USE MODD_SNOW_PAR, ONLY: XZ0SN, XZ0HSN + !---------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------- @@ -108,7 +120,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAND ! =2 ocean; =1 land/seaice REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XICE ! fraction of grid that is seaice REAL, INTENT(IN ) :: XICE_THRES! fraction of grid determining seaice - INTEGER, INTENT(IN ) :: IDVEG ! dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + INTEGER, INTENT(IN ) :: IDVEG ! dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 INTEGER, INTENT(IN ) :: IOPT_CRS ! canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) INTEGER, INTENT(IN ) :: IOPT_BTR ! soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) INTEGER, INTENT(IN ) :: IOPT_RUN ! runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) @@ -240,7 +252,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(INOUT) :: SMOISEQ ! eq volumetric soil moisture [m3/m3] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SMCWTDXY ! soil moisture content in the layer to the water table when deep REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DEEPRECHXY ! recharge to the water table when deep - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RECHXY ! recharge to the water table (diagnostic) + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RECHXY ! recharge to the water table (diagnostic) ! OUT (with no Noah LSM equivalent) @@ -286,10 +298,10 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: IRBXY ! bare net longwave rad. [w/m2] [+ to atm] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: TRXY ! transpiration [w/m2] [+ to atm] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: EVCXY ! canopy evaporation heat [w/m2] [+ to atm] - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHLEAFXY ! leaf exchange coefficient - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHUCXY ! under canopy exchange coefficient - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHV2XY ! veg 2m exchange coefficient - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHB2XY ! bare 2m exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHLEAFXY ! leaf exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHUCXY ! under canopy exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHV2XY ! veg 2m exchange coefficient + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT ) :: CHB2XY ! bare 2m exchange coefficient INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ! d -> domain & ims,ime, jms,jme, kms,kme, & ! m -> memory & its,ite, jts,jte, kts,kte ! t -> tile @@ -338,7 +350,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ! INOUT (with generic LSM equivalent) REAL :: FSH ! total sensible heat (w/m2) [+ to atm] - REAL :: SSOIL ! soil heat heat (w/m2) + REAL :: SSOIL ! soil heat heat (w/m2) REAL :: SALB ! surface albedo (-) REAL :: FSNO ! snow cover fraction (-) REAL, DIMENSION( 1:NSOIL) :: SMCEQ ! eq vol. soil moisture (m3/m3) @@ -372,7 +384,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL :: WT ! groundwater storage [mm] REAL :: SMCWTD ! soil moisture content in the layer to the water table when deep REAL :: DEEPRECH ! recharge to the water table when deep - REAL :: RECH ! recharge to the water table (diagnostic) + REAL :: RECH ! recharge to the water table (diagnostic) REAL, DIMENSION(-2:NSOIL) :: ZSNSO ! snow layer depth [m] REAL, DIMENSION(-2: 0) :: SNICE ! snow layer ice [mm] REAL, DIMENSION(-2: 0) :: SNLIQ ! snow layer liquid water [mm] @@ -437,14 +449,14 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL :: GHB ! bare ground heat flux [w/m2] [+ to soil] REAL :: TR ! transpiration [w/m2] [+ to atm] REAL :: EVC ! canopy evaporation heat [w/m2] [+ to atm] - REAL :: CHLEAF ! leaf exchange coefficient - REAL :: CHUC ! under canopy exchange coefficient - REAL :: CHV2 ! veg 2m exchange coefficient - REAL :: CHB2 ! bare 2m exchange coefficient - REAL :: PAHV !precipitation advected heat - vegetation net (W/m2) - REAL :: PAHG !precipitation advected heat - under canopy net (W/m2) - REAL :: PAHB !precipitation advected heat - bare ground net (W/m2) - REAL :: PAH !precipitation advected heat - total (W/m2) + REAL :: CHLEAF ! leaf exchange coefficient + REAL :: CHUC ! under canopy exchange coefficient + REAL :: CHV2 ! veg 2m exchange coefficient + REAL :: CHB2 ! bare 2m exchange coefficient + REAL :: PAHV ! precipitation advected heat - vegetation net (W/m2) + REAL :: PAHG ! precipitation advected heat - under canopy net (W/m2) + REAL :: PAHB ! precipitation advected heat - bare ground net (W/m2) + REAL :: PAH ! precipitation advected heat - total (W/m2) ! Intermediate terms @@ -477,7 +489,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN INTEGER :: SLOPETYP LOGICAL :: IPRINT - INTEGER :: SOILCOLOR ! soil color index + INTEGER :: SOILCOLOR ! soil color index INTEGER :: IST ! surface type 1-soil; 2-lake INTEGER :: YEARLEN @@ -487,6 +499,131 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN type(noahmp_parameters) :: parameters + INTEGER, INTENT(IN) :: act_level + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: PSNOWALBXY ! Prognostic surface snow albedo + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWHEATXY + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWRHOXY + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWSWEXY + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWGRAN1XY ! Snow layer(s) grain parameter 1 + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWGRAN2XY ! Snow layer(s) grain parameter 2 + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWHISTXY ! Snow layer(s) grain historical parameter + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWAGEXY ! Snow grain age + + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWLIQXY + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWTEMPXY + REAL, DIMENSION(:,:,:), INTENT(INOUT), allocatable :: PSNOWDZXY + + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: PSNOWTHRUFALXY ! rate that liquid water leaves snow pack [kg/(m2 s)] (should only be out) + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: PSNOWHEIGHTXY ! integrated crocus snowheight PSNOWDZXY + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: PSNOWTOTSWEXY ! crocus snowheight PSNOWSWE + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: FLOW_ICE + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: FLOW_SNOW + INTEGER,DIMENSION(:,:), INTENT(INOUT), allocatable :: GLACINFO + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: GLACT + INTEGER, INTENT(IN) :: crocus_opt + REAL, DIMENSION(:,:), INTENT(INOUT), allocatable :: VIS_ICEALB + + INTEGER :: GLACINFOH,GLACR ! glacier info + CHARACTER(LEN=11) :: HSNOWRES + CHARACTER(LEN=3) :: HIMPLICIT_WIND + LOGICAL :: OGLACIER + + REAL, DIMENSION(1) :: ZP_RRSNOW ,ZP_PSN3L, ZP_QA + REAL, DIMENSION(1) :: ZP_PEW_A_COEF, ZP_PEW_B_COEF + REAL, DIMENSION(1) :: ZP_PET_A_COEF, ZP_PEQ_A_COEF + REAL, DIMENSION(1) :: ZP_PET_B_COEF, ZP_PEQ_B_COEF + REAL, PARAMETER :: ZTFRZ = 273.16 !freezing/melting point (k) + REAL :: ZFPICE ! snow fraction of precip + REAL, DIMENSION(1) :: FOO1, FOO2 + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWSWE + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWDZ + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWRHO + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWHEAT + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWTEMP + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWLIQ + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWGRAN1 + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWGRAN2 + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWHIST + REAL, DIMENSION(:,:), allocatable :: ZP_SNOWAGE + + REAL, DIMENSION(1) :: ZP_VMOD,ZP_RHOA, ZP_UREF + REAL, DIMENSION(1) :: ZP_EXNS, ZP_EXNA, ZP_DIRCOSZW + REAL, DIMENSION(1) :: ZP_Z0NAT + REAL, DIMENSION(1) :: ZP_Z0HNAT, ZP_ALB, ZP_SOILCOND + REAL, DIMENSION(1) :: ZP_D_G,ZP_SNOWALB, ZP_VIS_ICEALB + REAL, DIMENSION(1) :: ZFLOW_ICE, ZFLOW_SNOW + REAL, DIMENSION(1) :: ZP_THRUFAL, ZP_GRNDFLUX, ZP_EVAPCOR + REAL, DIMENSION(1) :: ZP_RNSNOW, ZP_GFLUXSNOW, ZP_HPSNOW + REAL, DIMENSION(1) :: ZP_LEL3L, ZP_SNDRIFT, ZP_RI + REAL, DIMENSION(1) :: ZP_SNOWHMASS + REAL, DIMENSION(1) :: ZP_USTARSNOW + REAL, DIMENSION(1) :: ZP_VEGTYPE, ZP_ZENITH + REAL, DIMENSION(1) :: ZP_PS ! PSFC + REAL, DIMENSION(1) :: ZP_SRSNOW ! QSNOW + REAL, DIMENSION(1) :: ZP_TA ! T_ML + REAL, DIMENSION(1) :: ZP_TG ! TG? + REAL, DIMENSION(1) :: ZP_SW_RAD ! SWDN + REAL, DIMENSION(1) :: ZP_LW_RAD ! LWDN + REAL, DIMENSION(1) :: ZP_ZREF ! Z_ML + REAL, DIMENSION(1) :: ZP_HSNOW ! FSH + REAL, DIMENSION(1) :: ZP_LES3L ! FGEV + REAL, DIMENSION(1) :: ZP_EVAP ! ESOIL + REAL, DIMENSION(1) :: ZP_EMISNOW ! EMISSI + REAL, DIMENSION(1) :: ZP_CDSNOW ! CM + REAL, DIMENSION(1) :: ZP_CHSNOW ! CH + REAL, DIMENSION(1) :: ZP_QS ! QSFC1D + REAL, DIMENSION(1) :: ZP_Z0EFF ! effective roughness + + ! Added some temporary fields for using noahmp-glacier to calculate 2m variables + REAL, DIMENSION(-2:NSOIL) :: ZSNSOT ! snow layer depth [m] + REAL, DIMENSION(-2:0) :: SNICET ! snow layer ice [mm] + REAL, DIMENSION(-2:0) :: SNLIQT ! snow layer liquid water [mm] + + REAL, DIMENSION(-2:NSOIL) :: ZSNSOTH ! snow layer depth [m] + REAL, DIMENSION(-2:0) :: SNICEH ! snow layer ice [mm] + REAL, DIMENSION(-2:NSOIL) :: ZSNSOH ! snow layer depth [m] + + ! Added fluxes: + REAL,DIMENSION(1) :: ZP_FSA_CROCUS + REAL,DIMENSION(1) :: ZP_FSR_CROCUS + REAL,DIMENSION(1) :: ZP_FIRA_CROCUS + + LOGICAL :: OSNOWDRIFT, OSNOWDRIFT_SUBLIM ! activate snowdrift, sublimation during drift + LOGICAL :: OSNOW_ABS_ZENITH ! activate parametrization of solar absorption for polar regions + REAL :: SWEH + REAL :: SNDPTHH + REAL :: SNEQVOH + CHARACTER(3) :: HSNOWMETAMO, HSNOWRAD + + ! crocus, assign mock local values, and initialize. These values should be in namelist. + if (crocus_opt /= 0) then + allocate(ZP_SNOWSWE (1,1:act_level)) + allocate(ZP_SNOWDZ (1,1:act_level)) + allocate(ZP_SNOWRHO (1,1:act_level)) + allocate(ZP_SNOWHEAT (1,1:act_level)) + allocate(ZP_SNOWTEMP (1,1:act_level)) + allocate(ZP_SNOWLIQ (1,1:act_level)) + allocate(ZP_SNOWGRAN1(1,1:act_level)) + allocate(ZP_SNOWGRAN2(1,1:act_level)) + allocate(ZP_SNOWHIST (1,1:act_level)) + allocate(ZP_SNOWAGE (1,1:act_level)) + + HSNOWRES = 'ISBA-SNOW3L' ! 'DEF' + OGLACIER = .false. + ! OGLACIER = .true. + HIMPLICIT_WIND = 'NEW' + ! HIMPLICIT_WIND = 'OLD' + + ZP_VEGTYPE = 1.0 + OSNOWDRIFT = .true. + OSNOWDRIFT_SUBLIM = .true. + OSNOW_ABS_ZENITH = .false. + HSNOWMETAMO = 'B92' + ! HSNOWMETAMO = 'C13' + HSNOWRAD = 'B92' + ! HSNOWRAD = 'TAR2' + end if ! crocus_opt /= 0 + ! ---------------------------------------------------------------------- CALL NOAHMP_OPTIONS(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & @@ -512,7 +649,6 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN END DO JLOOP : DO J=jts,jte - IF(ITIMESTEP == 1)THEN DO I=its,ite IF((XLAND(I,J)-1.5) >= 0.) THEN ! Open water case @@ -538,6 +674,9 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN !----------------------------------------------------------------------- ILOOP : DO I = its, ite + ! Reset GLACR and ICE at the start of every iteration + GLACR = 0 + ICE = 0 IF (XICE(I,J) >= XICE_THRES) THEN ICE = 1 ! Sea-ice point @@ -551,7 +690,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN IF((XLAND(I,J)-1.5) >= 0.) CYCLE ILOOP ! Open water case -! 2D to 1D +! 2D to 1D ! IN only @@ -575,6 +714,10 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN PRCP = PRECIP_IN (I,J) / DT ! timestep total precip rate (glacier) [mm/s]! MB: v3.7 CROPTYPE = 0 + if (crocus_opt /= 0) then + ZFLOW_ICE = 0 + ZFLOW_SNOW = 0 + end if IF (PRESENT(MP_RAINC) .AND. PRESENT(MP_RAINNC) .AND. PRESENT(MP_SHCV) .AND. & PRESENT(MP_SNOW) .AND. PRESENT(MP_GRAUP) .AND. PRESENT(MP_HAIL) ) THEN @@ -589,7 +732,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN PRCPOTHR = PRCP - PRCPCONV - PRCPNONC - PRCPSHCV ! take care of other (fog) contained in rainbl PRCPOTHR = MAX(0.0,PRCPOTHR) PRCPNONC = PRCPNONC + PRCPOTHR - PRCPSNOW = PRCPSNOW + SR(I,J) * PRCPOTHR + PRCPSNOW = PRCPSNOW + SR(I,J) * PRCPOTHR ELSE PRCPCONV = 0. PRCPNONC = PRCP @@ -696,7 +839,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN else parameters%hvb = 0.0 endif - + !ADCHANGE: Add some sanity checks in case calibration knocks the order of these out of sequence. !The min diffs were pulled from the existing SOILPARM.TBL defaults. !Currently water is 0, so enforcing 0 as the absolute min. @@ -708,7 +851,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ! Initialized local FICEOLD = 0.0 - FICEOLD(ISNOW+1:0) = SNICEXY(I,ISNOW+1:0,J) & ! snow ice fraction + FICEOLD(ISNOW+1:0) = SNICEXY(I,ISNOW+1:0,J) & ! snow ice fraction /(SNICEXY(I,ISNOW+1:0,J)+SNLIQXY(I,ISNOW+1:0,J)) CO2PP = CO2_TABLE * P_ML ! partial pressure co2 [Pa] O2PP = O2_TABLE * P_ML ! partial pressure o2 [Pa] @@ -717,142 +860,458 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN PBLH = undefined_value ! test dummy value ! PBL height DZ8W1D = DZ8W (I,1,J) ! thickness of atmospheric layers +! Initialize crocus, ! Do this before NOAHMP, so that outputs (such as TG) from Noah-mp glacier affect Crocus this step + if (crocus_opt /= 0) then + GLACINFOH = GLACINFO(I,J) ! vegetation type + + ZP_SNOWSWE(1,1:act_level) = PSNOWSWEXY(I,1:act_level,J) + ZP_SNOWRHO(1,1:act_level) = PSNOWRHOXY(I,1:act_level,J) + ZP_SNOWHEAT(1,1:act_level) = PSNOWHEATXY(I,1:act_level,J) + ZP_SNOWGRAN1(1,1:act_level) = PSNOWGRAN1XY(I,1:act_level,J) + ZP_SNOWGRAN2(1,1:act_level) = PSNOWGRAN2XY(I,1:act_level,J) + ZP_SNOWHIST(1,1:act_level) = PSNOWHISTXY(I,1:act_level,J) + ZP_SNOWAGE(1,1:act_level)= PSNOWAGEXY(I,1:act_level,J) + ZP_SNOWLIQ(1,1:act_level) = PSNOWLIQXY(I,1:act_level,J) + ZP_SNOWTEMP(1,1:act_level) = PSNOWTEMPXY(I,1:act_level,J) + ZP_SNOWDZ(1,1:act_level) = PSNOWDZXY(I,1:act_level,J) + ZP_SNOWALB(1) = PSNOWALBXY(I,J) + ZP_EVAP(1) = 0 !PSNOWEVAPXY(I,J) + ZP_vis_icealb(1) = VIS_ICEALB(I,J) + + ZP_ZENITH = ACOS(COSZIN(I,J)) + + ! Currently the surfex naming convention is being used + ZP_PS(1) = PSFC + ZP_SRSNOW(1) = QSNOW + ZP_TA(1) = T_ML + ZP_TG(1) = TSLB(i,1,j) + IF (ZP_SNOWTEMP(1,3) .ne. 0 ) then + ZP_TG(1) = (TSLB(i,1,j)+ZP_SNOWTEMP(1,3))/2. + end if + ZP_RHOA(1) = P_ML/(T_ML*287.058) + ZP_SW_RAD(1) = SWDN + ZP_LW_RAD(1) = LWDN + ZP_ZREF(1) = Z_ML + ZP_HSNOW(1) = FSH + ZP_LES3L(1) = FGEV + ZP_EVAP(1) = ESOIL + ZP_EMISNOW(1) = EMISSI + ZP_CDSNOW(1) = CM + ZP_CHSNOW(1) = CH + ZP_QS(1) = QSFC1D + ZP_QA(1) =Q_ML + ZP_ALB(1) = ALBEDO(I,J) !soil/vegetation albedo. Is SALB combined snow/soil albedo? + ZP_EXNA(1) = (P_ML/1.e5)** (287.04/1004.6) !(P/XP00)**(XRD/XCPD) + ZP_EXNS(1) = (PSFC/1.e5)** (287.04/1004.6) !(P/XP00)**(XRD/XCPD) + ZP_DIRCOSZW(1) = 1.0 !(for now we use a flat surface) + ZP_UREF(1) = Z_ML + + ZP_Z0EFF(1) = XZ0SN + ZP_Z0NAT(1) = XZ0SN + ZP_Z0HNAT(1) = XZ0HSN + + ! in offline mode, A_COEF = 0, and B_COEF = variable of interest at atmospheric level (Boone et al, 2017; The interaction between soil-biasphere-------) + ZP_PSN3L(1) = 1.0 + ZP_VMOD(1) = 1.0 !(assume terrain is flat) + ZP_D_G(1) = 0.1 ! should read from namelits (soil_thick_input) + + ! Fluxes + ZP_FSA_CROCUS(1) = 0 + ZP_FSR_CROCUS(1) = 0 + ZP_FIRA_CROCUS(1) = 0 + + ZP_SOILCOND(1) = 0.32333+(0.10073*(-ZSNSO(1))) + + ZP_PEW_A_COEF(1) = 0.0 + ZP_PEW_B_COEF(1) = sqrt(U_ML**2+V_ML**2) + ZP_PET_A_COEF(1) =0.0 + ZP_PEQ_A_COEF(1) = 0.0 + ZP_PET_B_COEF(1) = T_ML*(1.e5/P_ML)** (287.04/1004.6) + ZP_PEQ_B_COEF(1) = Q_ML + + ZP_VMOD(1) = ZP_PEW_B_COEF(1) + + + ! Added from module_sf_noahmp_glacier: + ! partition precipitation into rain and snow (from CANWATER) + ! Jordan (1991) + IF(IOPT_SNF == 1 .OR. IOPT_SNF == 4) THEN + IF(T_ML > ZTFRZ+2.5)THEN + ZFPICE = 0. + ELSE + IF(T_ML <= ZTFRZ+0.5)THEN + ZFPICE = 1.0 + ELSE IF(T_ML <= ZTFRZ+2.)THEN + ZFPICE = 1.-(-54.632 + 0.2*T_ML) + ELSE + ZFPICE = 0.6 + ENDIF + ENDIF + ENDIF + + IF(IOPT_SNF == 2) THEN + IF(T_ML >= ZTFRZ+2.2) THEN + ZFPICE = 0. + ELSE + ZFPICE = 1.0 + ENDIF + ENDIF + + IF(IOPT_SNF == 3) THEN + IF(T_ML >= ZTFRZ) THEN + ZFPICE = 0. + ELSE + ZFPICE = 1.0 + ENDIF + ENDIF + + ! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 + ! fresh snow density + + ZP_RRSNOW(1) = PRCP* (1.-ZFPICE) + ZP_SRSNOW(1) = PRCP*ZFPICE + + ZP_THRUFAL(:) = 0.0 + end if ! crocus_opt /= 0 + IF(VEGTYP == 25) FVEG = 0.0 ! Set playa, lava, sand to bare - IF(VEGTYP == 25) PLAI = 0.0 + IF(VEGTYP == 25) PLAI = 0.0 IF(VEGTYP == 26) FVEG = 0.0 ! hard coded for USGS IF(VEGTYP == 26) PLAI = 0.0 IF(VEGTYP == 27) FVEG = 0.0 IF(VEGTYP == 27) PLAI = 0.0 - IF ( VEGTYP == ISICE_TABLE ) THEN - ICE = -1 ! Land-ice point - CALL NOAHMP_OPTIONS_GLACIER(IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC, IOPT_GLA ) - - TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C - CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related - T_ML, P_ML, U_ML, V_ML, Q_ML, SWDN, & ! IN : Forcing - PRCP, LWDN, TBOT, Z_ML, FICEOLD, ZSOIL, & ! IN : Forcing - parameters%swe_limit, & ! IN : Forcing - QSNOW, QRAIN, SNEQVO, ALBOLD, CM, CH, ISNOW, & ! IN/OUT : - SWE, SMC, ZSNSO, SNDPTH, SNICE, SNLIQ, & ! IN/OUT : - TG, STC, SMH2O, TAUSS, QSFC1D, & ! IN/OUT : - FSA, FSR, FIRA, FSH, FGEV, SSOIL, & ! OUT : - TRAD, ESOIL, RUNSF, RUNSB, SAG, SALB, & ! OUT : - QSNBOT,PONDING,PONDING1,PONDING2, T2MB, Q2MB, & ! OUT : - EMISSI, FPICE, CHB2 & ! OUT : + ! If running crocus, test if glaicer has has comletely melted, then RUN NoahMP + IF ( (crocus_opt == 0) .or. (GLACINFOH == 1 .and. ZP_SNOWDZ(1,1) .eq. 0.0)) THEN + IF ( VEGTYP == ISICE_TABLE ) THEN + ICE = -1 ! Land-ice point + if (crocus_opt /= 0) & + GLACR = 1 + CALL NOAHMP_OPTIONS_GLACIER(IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC, IOPT_GLA ) + + TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C + CALL NOAHMP_GLACIER(I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related + T_ML, P_ML, U_ML, V_ML, Q_ML, SWDN, & ! IN : Forcing + PRCP, LWDN, TBOT, Z_ML, FICEOLD, ZSOIL, & ! IN : Forcing + parameters%swe_limit, & ! IN : Forcing + QSNOW, QRAIN, SNEQVO, ALBOLD, CM, CH, ISNOW, & ! IN/OUT : + SWE, SMC, ZSNSO, SNDPTH, SNICE, SNLIQ, & ! IN/OUT : + TG, STC, SMH2O, TAUSS, QSFC1D, & ! IN/OUT : + FSA, FSR, FIRA, FSH, FGEV, SSOIL, & ! OUT : + TRAD, ESOIL, RUNSF, RUNSB, SAG, SALB, & ! OUT : + QSNBOT,PONDING,PONDING1,PONDING2, T2MB, Q2MB, & ! OUT : + EMISSI, FPICE, CHB2 & ! OUT : +#ifdef WRF_HYDRO + , sfcheadrt(i,j) & +#endif + ) + ENDIF ! VEGTYP == ISICE_TABLE + ELSE IF (crocus_opt /= 0 .and. GLACINFOH == 1 .and. ZP_SNOWDZ(1,1) .gt. 0.0) THEN + ICE = -1 ! Land-ice point + GLACR= 1 + CALL NOAHMP_OPTIONS_GLACIER(IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC, IOPT_GLA ) + TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C + ! send snow info from crocus to Noahmp_glacier to calc 2m temps etc + ! move NOAHMP_GLACIER to after CROCUS + ! for temperatre glacier, set top soil temp to 272 + ZP_TG(1) = 272.0 + + IF (ZP_SNOWDZ(1,1) .eq. 0.0 .and. ZP_SRSNOW(1) .eq. 0.0) THEN + ELSE + CALL SNOWCRO(HSNOWRES, OGLACIER, HIMPLICIT_WIND, & !(IN) + ZP_PEW_A_COEF, ZP_PEW_B_COEF, & !(IN) + ZP_PET_A_COEF, ZP_PEQ_A_COEF, ZP_PET_B_COEF, ZP_PEQ_B_COEF, & !(IN) + ZP_SNOWSWE,ZP_SNOWRHO, ZP_SNOWHEAT, ZP_SNOWALB, & ! (INOUT) !several layers + ZP_SNOWGRAN1, ZP_SNOWGRAN2, ZP_SNOWHIST, ZP_SNOWAGE, DT, & !(INOUT) PTSTEP: (IN) + ZP_PS, ZP_SRSNOW, ZP_RRSNOW ,ZP_PSN3L, ZP_TA, ZP_TG, & !(IN) + ZP_SW_RAD, ZP_QA, ZP_VMOD, ZP_LW_RAD, ZP_RHOA, ZP_UREF, & !(IN) + ZP_EXNS, ZP_EXNA, ZP_DIRCOSZW, ZP_ZREF, ZP_Z0NAT, ZP_Z0EFF, & !(IN) + ZP_Z0HNAT, ZP_ALB, ZP_SOILCOND, ZP_D_G, & !(IN) + ZP_SNOWLIQ, & !(OUT) + ZP_SNOWTEMP, ZP_SNOWDZ, ZP_THRUFAL, ZP_GRNDFLUX, ZP_EVAPCOR, & !(OUT) + ZP_RNSNOW, ZP_HSNOW, ZP_GFLUXSNOW, ZP_HPSNOW, ZP_LES3L, & !(OUT) + ZP_LEL3L, ZP_EVAP, ZP_SNDRIFT, ZP_RI, & !(OUT) + ZP_EMISNOW, ZP_CDSNOW, ZP_USTARSNOW, & !(OUT) + ZP_CHSNOW, ZP_SNOWHMASS, ZP_QS, & !(OUT) + ZP_VEGTYPE, ZP_ZENITH, & !(IN) + OSNOWDRIFT,OSNOWDRIFT_SUBLIM, & !(IN) + OSNOW_ABS_ZENITH, HSNOWMETAMO,HSNOWRAD, & + act_level, ZP_VIS_ICEALB, & + ZP_FSA_CROCUS, ZP_FSR_CROCUS, ZP_FIRA_CROCUS, & + ZFLOW_ICE, ZFLOW_SNOW, & + I,J) !(OUT) + + ! Call to NOAHM_GLACIER to after CROCUS to calculte 2m temp and other 2m variables. + ! But use snow info from CROCUS. + + ZSNSO(-NSNOW:0) = 0.0 + ALBOLD= ZP_SNOWALB(1) + SNDPTHH = sum(ZP_SNOWDZ) + SNEQVOH= sum(PSNOWSWEXY(I,:,J)) + SWEH = sum(ZP_SNOWDZ) + ZSNSOTH(-1)=-SNDPTHH/2 + zsnsoTH(0)=-SNDPTHH + ZSNSOTH(1)=-SNDPTHH-0.1 + zSNSOTH(2)=ZSNSO(1)-0.3 + zSNSOTH(3)=ZSNSO(2)-0.6 + zSNSOTH(4)=ZSNSO(3)-1.0 + STC(-NSNOW+3)=273.15 + STC(-NSNOW+2)=(ZP_SNOWTEMP(1,1)) + ISNOW=-NSNOW+1 ! (for glacier, always assume a snow layer) + SNICEH=sum(PSNOWDZXY(I,:,J))*1000./(NSNOW) + if (SNDPTHH .eq. 0) then + if(VEGTYP .eq. 24) then + ISNOW=1 + else + ISNOW=0 + endif + endif + + CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related + T_ML, P_ML, U_ML, V_ML, Q_ML, SWDN, & ! IN : Forcing + PRCP, LWDN, TBOT, Z_ML, FICEOLD, ZSOIL, & ! IN : Forcing + parameters%swe_limit , & ! IN : Forcing + QSNOW, QRAIN, SNEQVOH, ALBOLD, CM, CH, ISNOW, & ! IN/OUT : +! SWE, SMC, ZSNSO, SNDPTH, SNICE, SNLIQ, & ! IN/OUT : + SWEH, SMC, ZSNSOTH, SNDPTHH, SNICEH, SNLIQ, & ! IN/OUT : + TG, STC, SMH2O, TAUSS, QSFC1D, & ! IN/OUT : + FSA, FSR, FIRA, FSH, FGEV, SSOIL, & ! OUT : + TRAD, ESOIL, RUNSF, RUNSB, SAG, SALB, & ! OUT : + QSNBOT,PONDING,PONDING1,PONDING2, T2MB, Q2MB, & ! OUT : + EMISSI, FPICE, CHB2 & ! OUT : #ifdef WRF_HYDRO - , sfcheadrt(i,j) & + , sfcheadrt(i,j) & #endif - ) + ) + + + RUNSF=ZP_THRUFAL(1) + RUNSB=0. ! assume that there are no subsurface runoff under the glacier. +#ifdef WRF_HYDRO + RUNSF=ZP_THRUFAL(1)+sfcheadrt(i,j)/DT +#endif + + SNLIQ = 0 + FOO1 = MAX((ZP_LEL3L+ZP_LES3L)/2.8440E06,0.) + FOO2 = ABS(MIN((ZP_LEL3L+ZP_LES3L)/2.8440E06,0.)) + + FSA = ZP_FSA_CROCUS(1) + FSR = ZP_FSR_CROCUS(1) + FIRA = ZP_FIRA_CROCUS(1) + FSH = ZP_HSNOW(1) + FGEV = ZP_LEL3L(1)+ZP_LES3L(1) + SSOIL=ZP_GRNDFLUX(1) + ESOIL = FOO1(1)-FOO2(1) + + TG=ZP_SNOWTEMP(1,1) + STC ( 1:NSOIL)=273.16 + + !---------------- + ENDIF ! If not (ZP_SNOWDZ(1,1) .eq. 0.0 .and. ZP_SRSNOW(1) .eq. 0.0) + ! If crocus is not running, use the original NOAH-MP glacier + ELSE IF (crocus_opt /= 0 .and. & + GLACINFOH .ne. 1 .and. & + VEGTYP == ISICE_TABLE) THEN ! all other glacier grid points + ICE = -1 + GLACR= 1 + CALL NOAHMP_OPTIONS_GLACIER(IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC, IOPT_GLA ) + TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C + + CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related + T_ML, P_ML, U_ML, V_ML, Q_ML, SWDN, & ! IN : Forcing + PRCP, LWDN, TBOT, Z_ML, FICEOLD, ZSOIL, & ! IN : Forcing + parameters%swe_limit, & + QSNOW, QRAIN, SNEQVO, ALBOLD, CM, CH, ISNOW, & ! IN/OUT : + SWE, SMC, ZSNSO, SNDPTH, SNICE, SNLIQ, & ! IN/OUT : + TG, STC, SMH2O, TAUSS, QSFC1D, & ! IN/OUT : + FSA, FSR, FIRA, FSH, FGEV, SSOIL, & ! OUT : + TRAD, ESOIL, RUNSF, RUNSB, SAG, SALB, & ! OUT : + QSNBOT,PONDING,PONDING1,PONDING2, T2MB, Q2MB, & ! OUT : + EMISSI, FPICE, CHB2 & ! OUT : +#ifdef WRF_HYDRO + , sfcheadrt(i,j) & +#endif + ) + - FSNO = 1.0 + ENDIF + + IF ((crocus_opt == 0 .and. VEGTYP == ISICE_TABLE) .or. GLACR == 1) THEN + FSNO = 1.0 TV = undefined_value ! Output from standard Noah-MP undefined for glacier points - TGB = TG - CANICE = undefined_value - CANLIQ = undefined_value - EAH = undefined_value + TGB = TG + CANICE = undefined_value + CANLIQ = undefined_value + EAH = undefined_value TAH = undefined_value - FWET = undefined_value - WSLAKE = undefined_value - ZWT = undefined_value - WA = undefined_value - WT = undefined_value - LFMASS = undefined_value - RTMASS = undefined_value - STMASS = undefined_value - WOOD = undefined_value - STBLCP = undefined_value - FASTCP = undefined_value - PLAI = undefined_value - PSAI = undefined_value - T2MV = undefined_value - Q2MV = undefined_value - NEE = undefined_value - GPP = undefined_value - NPP = undefined_value - FVEGMP = 0.0 - ECAN = undefined_value - ETRAN = undefined_value - APAR = undefined_value - PSN = undefined_value - SAV = undefined_value - RSSUN = undefined_value - RSSHA = undefined_value - BGAP = undefined_value - WGAP = undefined_value + FWET = undefined_value + WSLAKE = undefined_value + ZWT = undefined_value + WA = undefined_value + WT = undefined_value + LFMASS = undefined_value + RTMASS = undefined_value + STMASS = undefined_value + WOOD = undefined_value + STBLCP = undefined_value + FASTCP = undefined_value + PLAI = undefined_value + PSAI = undefined_value + T2MV = undefined_value + Q2MV = undefined_value + NEE = undefined_value + GPP = undefined_value + NPP = undefined_value + FVEGMP = 0.0 + ECAN = undefined_value + ETRAN = undefined_value + APAR = undefined_value + PSN = undefined_value + SAV = undefined_value + RSSUN = undefined_value + RSSHA = undefined_value + BGAP = undefined_value + WGAP = undefined_value TGV = undefined_value - CHV = undefined_value - CHB = CH - IRC = undefined_value - IRG = undefined_value - SHC = undefined_value - SHG = undefined_value - EVG = undefined_value - GHV = undefined_value + CHV = undefined_value + CHB = CH + IRC = undefined_value + IRG = undefined_value + SHC = undefined_value + SHG = undefined_value + EVG = undefined_value + GHV = undefined_value IRB = FIRA SHB = FSH EVB = FGEV GHB = SSOIL - TR = undefined_value - EVC = undefined_value - CHLEAF = undefined_value - CHUC = undefined_value - CHV2 = undefined_value - FCEV = undefined_value - FCTR = undefined_value + TR = undefined_value + EVC = undefined_value + CHLEAF = undefined_value + CHUC = undefined_value + CHV2 = undefined_value + FCEV = undefined_value + FCTR = undefined_value Z0WRF = 0.002 QFX(I,J) = ESOIL LH (I,J) = FGEV + ALBSND = undefined_value + ALBSNI = undefined_value + + ELSE + ICE=0 ! Neither sea ice or land ice. + + if (crocus_opt /= 0) then + IF (PLAI .lt. -1000) THEN + PLAI = 0.5 ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (TAH .lt. -1000) THEN + TAH = 273.2 ! trude test. Glacier points does not have a TAH value (-1e+36). Give TAH a value after glaicer has melted. + endif + IF (EAH .lt. -1000) THEN + EAH = 750 ! trude test. Glacier points does not have a EAH value (-1e+36). Give EAH a value after glaicer has melted. + endif + IF (FWET .lt. -1000) THEN + FWET = 0.05 ! trude test. Glacier points does not have a FWET value (-1e+36). Give FWET a value after glaicer has melted. + endif + IF (CANLIQ .lt. -1000) THEN + CANLIQ = 0.05 ! trude test. Glacier points does not have a CANLIQ value (-1e+36). Give CANLIQ a value after glaicer has melted. + endif + IF (CANICE .lt. -1000) THEN + CANICE = 0.00 ! trude test. Glacier points does not have a CANICE value (-1e+36). Give CANICE a value after glaicer has melted. + endif + IF (TV .lt. -1000) THEN + TV = T_ML +0.5 ! trude test. Glacier points does not have a TV value (-1e+36). Give TV a value after glaicer has melted. + endif + IF (TG .le. -1000) THEN + TG = T_ML +1. ! trude test. Glacier points does not have a TG value (-1e+36). Give TG a value after glaicer has melted. + endif + ! IF (ZSNSO(1) .le. -1000) THEN + ! ZSNSO(:) = 0. ! trude test. Glacier points does not have a ZSNSO(1) value (-1e+36). Give ZSNSO(1) a value after glaicer has melted. + ! endif + ! next varables could probably be defined from input somewhere + IF (ZWT .lt. -1000) THEN + ZWT = 2.5 ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (WA .lt. -1000) THEN + WA = 4900. ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (WT .lt. -1000) THEN + WT = 4900. ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (WSLAKE .lt. -1000) THEN + WSLAKE = 0. ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (LFMASS .lt. -1000) THEN + LFMASS = 6.68219 ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (RTMASS .lt. -1000) THEN + RTMASS = 500. ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (STMASS .lt. -1000) THEN + STMASS = 17.82 ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (WOOD .lt. -1000) THEN + WOOD = 500. ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (STBLCP .lt. -1000) THEN + STBLCP = 1000. ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (FASTCP .lt. -1000) THEN + FASTCP = 1000. ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + IF (PSAI .lt. -1000) THEN + PSAI = 0.49 ! trude test. Glacier points does not have a LAI value (-1e+36). Give LAI a value. + endif + end if ! crocus_opt /= 0 - ELSE - ICE=0 ! Neither sea ice or land ice. CALL NOAHMP_SFLX (parameters, & I , J , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related - DT , DX , DZ8W1D , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration + DT , DX , DZ8W1D , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration FVEG , FVGMAX , VEGTYP , ICE , IST , CROPTYPE, & ! IN : Vegetation/Soil characteristics SMCEQ , & ! IN : Vegetation/Soil characteristics T_ML , P_ML , PSFC , U_ML , V_ML , Q_ML , & ! IN : Forcing QC , SWDN , LWDN , & ! IN : Forcing PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, & ! IN : Forcing TBOT , CO2PP , O2PP , FOLN , FICEOLD , Z_ML , & ! IN : Forcing - ALBOLD , SNEQVO , & ! IN/OUT : - STC , SMH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : - CANLIQ , CANICE , TV , TG , QSFC1D, QSNOW, QRAIN, & ! IN/OUT : - ISNOW , ZSNSO , SNDPTH , SWE , SNICE , SNLIQ , & ! IN/OUT : - ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , & ! IN/OUT : - STMASS , WOOD , STBLCP , FASTCP , PLAI , PSAI , & ! IN/OUT : - CM , CH , TAUSS , & ! IN/OUT : - GRAIN , GDD , PGS , & ! IN/OUT + ALBOLD , SNEQVO , & ! IN/OUT : + STC , SMH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : + CANLIQ , CANICE , TV , TG , QSFC1D, QSNOW, QRAIN, & ! IN/OUT : + ISNOW , ZSNSO , SNDPTH , SWE , SNICE , SNLIQ , & ! IN/OUT : + ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , & ! IN/OUT : + STMASS , WOOD , STBLCP , FASTCP , PLAI , PSAI , & ! IN/OUT : + CM , CH , TAUSS , & ! IN/OUT : + GRAIN , GDD , PGS , & ! IN/OUT SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : Z0WRF , & - FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : - FGEV , FCTR , ECAN , ETRAN , ESOIL , TRAD , & ! OUT : - TGB , TGV , T2MV , T2MB , Q2MV , Q2MB , & ! OUT : - RUNSF , RUNSB , APAR , PSN , SAV , SAG , & ! OUT : - FSNO , NEE , GPP , NPP , FVEGMP , SALB , & ! OUT : - QSNBOT , PONDING , PONDING1, PONDING2, RSSUN , RSSHA , & ! OUT : + FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : + FGEV , FCTR , ECAN , ETRAN , ESOIL , TRAD , & ! OUT : + TGB , TGV , T2MV , T2MB , Q2MV , Q2MB , & ! OUT : + RUNSF , RUNSB , APAR , PSN , SAV , SAG , & ! OUT : + FSNO , NEE , GPP , NPP , FVEGMP , SALB , & ! OUT : + QSNBOT , PONDING , PONDING1, PONDING2, RSSUN , RSSHA , & ! OUT : ALBSND , ALBSNI , & ! OUT : - BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : + BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : SHG , SHC , SHB , EVG , EVB , GHV , & ! OUT : GHB , IRG , IRC , IRB , TR , EVC , & ! OUT : - CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & + CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & PAHG , PAHB , PAH , LAISUN , LAISHA , RB & #ifdef WRF_HYDRO , sfcheadrt(i,j) & #endif ) ! OUT : - + QFX(I,J) = ECAN + ESOIL + ETRAN LH (I,J) = FCEV + FGEV + FCTR - ENDIF ! glacial split ends + ENDIF ! glacial split ends #ifdef WRF_HYDRO !---LPR Attention: lpr added this part 2013-09-04 below to avoid restart NaN values---- !----------------- which may cause the RAPID crash-------------------------- -!yw if(isnan(RUNSF)) then +!yw if(isnan(RUNSF)) then if((RUNSF+1.0) .eq. RUNSF) then RUNSF = 0 RUNSB = 0 @@ -1013,8 +1472,41 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN DEEPRECHXY(I,J) = DEEPRECHXY(I,J) + DEEPRECH SMCWTDXY(I,J) = SMCWTD - ENDIF ! endif of land-sea test + if (crocus_opt /= 0) then + PSNOWSWEXY(I,1:act_level,J) = ZP_SNOWSWE(1,1:act_level) + PSNOWRHOXY(I,1:act_level,J) = ZP_SNOWRHO(1,1:act_level) + PSNOWHEATXY(I,1:act_level,J) = ZP_SNOWHEAT(1,1:act_level) + PSNOWGRAN1XY(I,1:act_level,J) = ZP_SNOWGRAN1(1,1:act_level) + PSNOWGRAN2XY(I,1:act_level,J) = ZP_SNOWGRAN2(1,1:act_level) + PSNOWHISTXY(I,1:act_level,J) = ZP_SNOWHIST(1,1:act_level) + PSNOWAGEXY(I,1:act_level,J) = ZP_SNOWAGE(1,1:act_level) + PSNOWLIQXY(I,1:act_level,J) = ZP_SNOWLIQ(1,1:act_level) + PSNOWTEMPXY(I,1:act_level,J) = ZP_SNOWTEMP(1,1:act_level) + PSNOWDZXY(I,1:act_level,J) = ZP_SNOWDZ(1,1:act_level) + + PSNOWALBXY(I,J) = ZP_SNOWALB(1) + PSNOWTHRUFALXY(I,J) = ZP_THRUFAL(1)*DT + FLOW_ICE(I,J) = FLOW_ICE(I,J)+ZFLOW_ICE(1)*DT + FLOW_SNOW(I,J) = FLOW_SNOW(I,J)+ZFLOW_SNOW(1)*DT + PSNOWHEIGHTXY(I,J) = sum(PSNOWDZXY(I,:,J)) + PSNOWTOTSWEXY(I,J) = sum(PSNOWSWEXY(I,:,J)) + + if (GLACINFO(I,J).eq.1 .and. PSNOWHEIGHTXY(I,J).gt.0) then + ALBEDO (I,J) = ZP_SNOWALB(1) + SNOW (I,J) = PSNOWTOTSWEXY(I,J) + SNOWH (I,J) = PSNOWHEIGHTXY(I,J) + ACSNOM (I,J) = FLOW_ICE(I,J)+FLOW_SNOW(I,J) +#ifdef WRF_HYDRO + if(present(ACCETRAN)) ACCETRAN(I,J) = 0. + if(present(ACCECAN)) ACCECAN(I,J) = 0. + if(present(ACCEDIR)) ACCEDIR(I,J) = ACCEDIR(I,J) + (zp_evap(1)*DT) - (ESOIL*DT) + if(present(SOILSAT_TOP)) SOILSAT_TOP (I,J) = undefined_value + if(present(SOILSAT)) SOILSAT(I,J) = undefined_value +#endif + endif + end if ! crocus_opt /= 0 + ENDIF ! endif of land-sea test ENDDO ILOOP ! of I loop ENDDO JLOOP ! of J loop @@ -1037,7 +1529,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, INTEGER, INTENT(IN) :: iopt_imperv type (noahmp_parameters), intent(inout) :: parameters - + REAL :: REFDK REAL :: REFKDT REAL :: FRZK @@ -1072,7 +1564,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%SLA = SLA_TABLE(VEGTYPE) !single-side leaf area per Kg [m2/kg] parameters%DILEFC = DILEFC_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] parameters%DILEFW = DILEFW_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] - parameters%FRAGR = FRAGR_TABLE(VEGTYPE) !fraction of growth respiration !original was 0.3 + parameters%FRAGR = FRAGR_TABLE(VEGTYPE) !fraction of growth respiration !original was 0.3 parameters%LTOVRC = LTOVRC_TABLE(VEGTYPE) !leaf turnover [1/s] parameters%C3PSN = C3PSN_TABLE(VEGTYPE) !photosynthetic pathway: 0. = c4, 1. = c3 @@ -1120,7 +1612,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%ALBSAT = ALBSAT_TABLE(SOILCOLOR,:) parameters%ALBDRY = ALBDRY_TABLE(SOILCOLOR,:) parameters%ALBICE = ALBICE_TABLE - parameters%ALBLAK = ALBLAK_TABLE + parameters%ALBLAK = ALBLAK_TABLE parameters%OMEGAS = OMEGAS_TABLE parameters%BETADS = BETADS_TABLE parameters%BETAIS = BETAIS_TABLE @@ -1138,12 +1630,12 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%GDDTBASE = GDDTBASE_TABLE(CROPTYPE) ! Base temperature for GDD accumulation [C] parameters%GDDTCUT = GDDTCUT_TABLE(CROPTYPE) ! Upper temperature for GDD accumulation [C] parameters%GDDS1 = GDDS1_TABLE(CROPTYPE) ! GDD from seeding to emergence - parameters%GDDS2 = GDDS2_TABLE(CROPTYPE) ! GDD from seeding to initial vegetative - parameters%GDDS3 = GDDS3_TABLE(CROPTYPE) ! GDD from seeding to post vegetative + parameters%GDDS2 = GDDS2_TABLE(CROPTYPE) ! GDD from seeding to initial vegetative + parameters%GDDS3 = GDDS3_TABLE(CROPTYPE) ! GDD from seeding to post vegetative parameters%GDDS4 = GDDS4_TABLE(CROPTYPE) ! GDD from seeding to intial reproductive - parameters%GDDS5 = GDDS5_TABLE(CROPTYPE) ! GDD from seeding to pysical maturity + parameters%GDDS5 = GDDS5_TABLE(CROPTYPE) ! GDD from seeding to pysical maturity parameters%C3C4 = C3C4_TABLE(CROPTYPE) ! photosynthetic pathway: 1. = c3 2. = c4 - parameters%AREF = AREF_TABLE(CROPTYPE) ! reference maximum CO2 assimulation rate + parameters%AREF = AREF_TABLE(CROPTYPE) ! reference maximum CO2 assimulation rate parameters%PSNRF = PSNRF_TABLE(CROPTYPE) ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) parameters%I2PAR = I2PAR_TABLE(CROPTYPE) ! Fraction of incoming solar radiation to photosynthetically active radiation parameters%TASSIM0 = TASSIM0_TABLE(CROPTYPE) ! Minimum temperature for CO2 assimulation [C] @@ -1180,6 +1672,8 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%TIMEAN = TIMEAN_TABLE parameters%FSATMX = FSATMX_TABLE parameters%Z0SNO = Z0SNO_TABLE + parameters%SSI = SSI_TABLE + parameters%SNOW_RET_FAC = SNOW_RET_FAC_TABLE parameters%SWEMX = SWEMX_TABLE parameters%GRAIN_GROWTH = GRAIN_GROWTH_TABLE parameters%EXTRA_GROWTH = EXTRA_GROWTH_TABLE @@ -1265,14 +1759,14 @@ SUBROUTINE PEDOTRANSFER_SR2006(nsoil,sand,clay,orgm,parameters) use module_sf_noahmplsm use noahmp_tables - + implicit none - + integer, intent(in ) :: nsoil ! number of soil layers real, dimension( 1:nsoil ), intent(inout) :: sand real, dimension( 1:nsoil ), intent(inout) :: clay real, dimension( 1:nsoil ), intent(inout) :: orgm - + real, dimension( 1:nsoil ) :: theta_1500t real, dimension( 1:nsoil ) :: theta_1500 real, dimension( 1:nsoil ) :: theta_33t @@ -1281,7 +1775,7 @@ SUBROUTINE PEDOTRANSFER_SR2006(nsoil,sand,clay,orgm,parameters) real, dimension( 1:nsoil ) :: theta_s33 real, dimension( 1:nsoil ) :: psi_et real, dimension( 1:nsoil ) :: psi_e - + type(noahmp_parameters), intent(inout) :: parameters integer :: k @@ -1292,7 +1786,7 @@ SUBROUTINE PEDOTRANSFER_SR2006(nsoil,sand,clay,orgm,parameters) end if if(orgm(k) <= 0 ) orgm(k) = 0.0 end do - + theta_1500t = sr2006_theta_1500t_a*sand & + sr2006_theta_1500t_b*clay & + sr2006_theta_1500t_c*orgm & @@ -1337,12 +1831,12 @@ SUBROUTINE PEDOTRANSFER_SR2006(nsoil,sand,clay,orgm,parameters) + sr2006_psi_et_e*clay*theta_s33 & + sr2006_psi_et_f*sand*clay & + sr2006_psi_et_g - + psi_e = psi_et & + sr2006_psi_e_a*psi_et*psi_et & + sr2006_psi_e_b*psi_et & + sr2006_psi_e_c - + parameters%smcwlt = theta_1500 parameters%smcref = theta_33 parameters%smcmax = theta_33 & @@ -1354,17 +1848,17 @@ SUBROUTINE PEDOTRANSFER_SR2006(nsoil,sand,clay,orgm,parameters) parameters%psisat = psi_e parameters%dksat = 1930.0 * (parameters%smcmax - theta_33) ** (3.0 - 1.0/parameters%bexp) parameters%quartz = sand - + ! Units conversion - + parameters%psisat = max(0.1,parameters%psisat) ! arbitrarily impose a limit of 0.1kpa parameters%psisat = 0.101997 * parameters%psisat ! convert kpa to m parameters%dksat = parameters%dksat / 3600000.0 ! convert mm/h to m/s parameters%dwsat = parameters%dksat * parameters%psisat *parameters%bexp / parameters%smcmax ! units should be m*m/s parameters%smcdry = parameters%smcwlt - + ! Introducing somewhat arbitrary limits (based on SOILPARM) to prevent bad things - + parameters%smcmax = max(0.32 ,min(parameters%smcmax, 0.50 )) parameters%smcref = max(0.17 ,min(parameters%smcref,parameters%smcmax )) parameters%smcwlt = max(0.01 ,min(parameters%smcwlt,parameters%smcref )) @@ -1374,7 +1868,7 @@ SUBROUTINE PEDOTRANSFER_SR2006(nsoil,sand,clay,orgm,parameters) parameters%dksat = max(5.e-7,min(parameters%dksat, 1.e-5)) parameters%dwsat = max(1.e-6,min(parameters%dwsat, 3.e-5)) parameters%quartz = max(0.05 ,min(parameters%quartz, 0.95 )) - + END SUBROUTINE PEDOTRANSFER_SR2006 SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & @@ -1386,7 +1880,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy ,lai , & !jref:start t2mvxy ,t2mbxy ,chstarxy, & -!jref:end +!jref:end NSOIL, restart, & allowed_to_read , iopt_run, iopt_crop, iopt_pedo, & ids,ide, jds,jde, kds,kde, & @@ -1492,7 +1986,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & !jref:end - REAL, DIMENSION(1:NSOIL) :: ZSOIL ! Depth of the soil layer bottom (m) from + REAL, DIMENSION(1:NSOIL) :: ZSOIL ! Depth of the soil layer bottom (m) from ! the surface (negative) REAL :: BEXP, SMCMAX, PSISAT @@ -1575,7 +2069,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & SNOW(I,J) = MAX(SNOW(I,J), 10.0) ! set SWE to at least 10mm SNOWH(I,J)=SNOW(I,J)*0.01 ! SNOW in mm and SNOWH in m ELSE - + BEXP = BEXP_TABLE(ISLTYP(I,J)) SMCMAX = SMCMAX_TABLE(ISLTYP(I,J)) PSISAT = PSISAT_TABLE(ISLTYP(I,J)) @@ -1614,7 +2108,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & CANWAT (I,J) = 0.0 canliqxy (I,J) = CANWAT(I,J) canicexy (I,J) = 0. - eahxy (I,J) = 2000. + eahxy (I,J) = 2000. tahxy (I,J) = TSK(I,J) if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) tahxy(I,J) = 273.15 ! tahxy (I,J) = 287. @@ -1634,7 +2128,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & qsnowxy (I,J) = 0.0 wslakexy (I,J) = 0.0 - if(iopt_run.ne.5) then + if(iopt_run.ne.5) then waxy (I,J) = 4900. !??? wtxy (I,J) = waxy(i,j) !??? zwtxy (I,J) = (25. + 2.0) - waxy(i,j)/1000/0.2 !??? @@ -1646,7 +2140,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & IF(IVGTYP(I,J) == ISBARREN_TABLE .OR. IVGTYP(I,J) == ISICE_TABLE .OR. & IVGTYP(I,J) == ISURBAN_TABLE .OR. IVGTYP(I,J) == ISWATER_TABLE ) THEN - + lai (I,J) = 0.0 xsaixy (I,J) = 0.0 lfmassxy (I,J) = 0.0 @@ -1657,7 +2151,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & fastcpxy (I,J) = 0.0 ELSE - + lai (I,J) = max(lai(i,j),0.05) ! at least start with 0.05 for arbitrary initialization (v3.7) xsaixy (I,J) = max(0.1*lai(I,J),0.05) ! MB: arbitrarily initialize SAI using input LAI (v3.7) masslai = 1000. / max(SLA_TABLE(IVGTYP(I,J)),1.0) ! conversion from lai to mass (v3.7) @@ -1681,7 +2175,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & ZSOIL(NS) = ZSOIL(NS-1) - DZS(NS) END DO - ! Initialize snow/soil layer arrays ZSNSOXY, TSNOXY, SNICEXY, SNLIQXY, + ! Initialize snow/soil layer arrays ZSNSOXY, TSNOXY, SNICEXY, SNLIQXY, ! and ISNOWXY CALL snow_init ( ims , ime , jms , jme , its , itf , jts , jtf , 3 , & & NSOIL , zsoil , snow , tgxy , snowh , & @@ -1715,7 +2209,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & STEPWTD = nint(WTDDT*60./DT) STEPWTD = max(STEPWTD,1) - CALL groundwater_init ( & + CALL groundwater_init ( & & nsoil, zsoil , dzs ,isltyp, ivgtyp,wtddt , & & fdepthxy, ht, riverbedxy, eqzwt, rivercondxy, pexpxy , areaxy, zwtxy, & & smois,sh2o, smoiseq, smcwtdxy, deeprechxy, rechxy, qslatxy, qrfsxy, qspringsxy, & @@ -1741,11 +2235,11 @@ SUBROUTINE SNOW_INIT ( ims , ime , jms , jme , its , itf , jts , jtf , ! Initialize snow arrays for Noah-MP LSM, based in input SNOWDEP, NSNOW ! ISNOWXY is an index array, indicating the index of the top snow layer. Valid indices ! for snow layers range from 0 (no snow) and -1 (shallow snow) to (-NSNOW)+1 (deep snow). -! TSNOXY holds the temperature of the snow layer. Snow layers are initialized with +! TSNOXY holds the temperature of the snow layer. Snow layers are initialized with ! temperature = ground temperature [?]. Snow-free levels in the array have value 0.0 ! SNICEXY is the frozen content of a snow layer. Initial estimate based on SNODEP and SWE ! SNLIQXY is the liquid content of a snow layer. Initialized to 0.0 -! ZNSNOXY is the layer depth from the surface. +! ZNSNOXY is the layer depth from the surface. !------------------------------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------------------------------ @@ -1753,7 +2247,7 @@ SUBROUTINE SNOW_INIT ( ims , ime , jms , jme , its , itf , jts , jtf , INTEGER, INTENT(IN) :: its, itf, jts, jtf INTEGER, INTENT(IN) :: NSNOW INTEGER, INTENT(IN) :: NSOIL - REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: SWE + REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: SWE REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: SNODEP REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: TGXY REAL, INTENT(IN), DIMENSION(1:NSOIL) :: ZSOIL @@ -1874,7 +2368,7 @@ SUBROUTINE GROUNDWATER_INIT ( & RECHXY, & QSLATXY, & QRFSXY, & - QSPRINGSXY + QSPRINGSXY ! local INTEGER :: I,J,K,ITER,itf,jtf REAL :: BEXP,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT @@ -1898,15 +2392,15 @@ SUBROUTINE GROUNDWATER_INIT ( & ELSEWHERE LANDMASK=-1 ENDWHERE - + !Calculate lateral flow QLAT = 0. CALL LATERALFLOW(ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & - ,ids,ide,jds,jde,kds,kde & + ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,its,ite,jts,jte,kts,kte ) - + !compute flux from grounwater to rivers in the cell @@ -1915,12 +2409,12 @@ SUBROUTINE GROUNDWATER_INIT ( & IF(LANDMASK(I,J).GT.0)THEN IF(WTD(I,J) .GT. RIVERBED(I,J) .AND. EQWTD(I,J) .GT. RIVERBED(I,J)) THEN RCOND = RIVERCOND(I,J) * EXP(PEXP(I,J)*(WTD(I,J)-EQWTD(I,J))) - ELSE + ELSE RCOND = RIVERCOND(I,J) ENDIF QRF(I,J) = RCOND * (WTD(I,J)-RIVERBED(I,J)) * DELTAT/AREA(I,J) !for now, dont allow it to go from river to groundwater - QRF(I,J) = MAX(QRF(I,J),0.) + QRF(I,J) = MAX(QRF(I,J),0.) ELSE QRF(I,J) = 0. ENDIF @@ -1935,9 +2429,9 @@ SUBROUTINE GROUNDWATER_INIT ( & SMCMAX = SMCMAX_TABLE(ISLTYP(I,J)) SMCWLT = SMCWLT_TABLE(ISLTYP(I,J)) IF(IVGTYP(I,J)==ISURBAN_TABLE)THEN - SMCMAX = 0.45 - SMCWLT = 0.40 - ENDIF + SMCMAX = 0.45 + SMCWLT = 0.40 + ENDIF DWSAT = DWSAT_TABLE(ISLTYP(I,J)) DKSAT = DKSAT_TABLE(ISLTYP(I,J)) PSISAT = -PSISAT_TABLE(ISLTYP(I,J)) @@ -1965,7 +2459,7 @@ SUBROUTINE GROUNDWATER_INIT ( & DO ITER = 1, 100 DD = (SMC+SMCMAX)/(2.*SMCMAX) AA = -DKSAT * DD ** EXPON - BBB = CC * ( (SMCMAX/SMC)**BEXP - 1. ) + 1. + BBB = CC * ( (SMCMAX/SMC)**BEXP - 1. ) + 1. FUNC = AA * BBB - FLUX DFUNC = -DKSAT * (EXPON/(2.*SMCMAX)) * DD ** (EXPON - 1.) * BBB & + AA * CC * (-BEXP) * SMCMAX ** BEXP * SMC ** (-BEXP-1.) @@ -1996,7 +2490,7 @@ SUBROUTINE GROUNDWATER_INIT ( & WTD(I,J) = ZSOIL(K) ELSE WTD(I,J) = ( SMOIS(I,K,J)*DZS(K) - SMCEQ(K)*ZSOIL(K-1) + SMCMAX*ZSOIL(K) ) / & - (SMCMAX - SMCEQ(K)) + (SMCMAX - SMCEQ(K)) ENDIF EXIT ENDIF @@ -2063,7 +2557,7 @@ SUBROUTINE EQSMOISTURE(NSOIL , ZSOIL , SMCMAX , SMCWLT, DWSAT , DKSAT ,BEXP , DO ITER = 1, 100 FUNC = (SMC - SMCMAX) * AA + BB * SMC ** EXPON - DFUNC = AA + BB * EXPON * SMC ** BEXP + DFUNC = AA + BB * EXPON * SMC ** BEXP DX = FUNC/DFUNC SMC = SMC - DX diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_snowcro.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_snowcro.F new file mode 100644 index 000000000..a096a07e1 --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_snowcro.F @@ -0,0 +1,5661 @@ +MODULE MODULE_SNOWCRO + +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. + + +! ######## +! TRUDE: replace abort1 with exitroutines used in WRF +! TRUDE: comment out all the debug statements. To run crodebug, we need to initalize this somewhere else and requires added links +! in the initalizeion etc. I do not think we want to adde this in WRF-hydro. +! + +CONTAINS + +! ########################################################################## +! SUBROUTINE SNOWCRO(HSNOWRES, TPTIME, OGLACIER, HIMPLICIT_WIND, & + SUBROUTINE SNOWCRO(HSNOWRES, OGLACIER, HIMPLICIT_WIND, & + PPEW_A_COEF, PPEW_B_COEF, & + PPET_A_COEF, PPEQ_A_COEF, PPET_B_COEF, PPEQ_B_COEF, & + PSNOWSWE,PSNOWRHO,PSNOWHEAT,PSNOWALB, & + PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST,PSNOWAGE, & + PTSTEP,PPS,PSR,PRR,PPSN3L, & + PTA,PTG,PSW_RAD,PQA,PVMOD,PLW_RAD, PRHOA, & + PUREF,PEXNS,PEXNA,PDIRCOSZW, & + PZREF,PZ0,PZ0EFF,PZ0H,PALB, & + PSOILCOND,PD_G, & + PSNOWLIQ,PSNOWTEMP,PSNOWDZ, & + PTHRUFAL,PGRNDFLUX,PEVAPCOR,PRNSNOW,PHSNOW,PGFLUXSNOW, & + PHPSNOW,PLES3L,PLEL3L,PEVAP,PSNDRIFT,PRI, & + PEMISNOW,PCDSNOW,PUSTAR,PCHSNOW,PSNOWHMASS,PQS, & + PPERMSNOWFRAC,PZENITH, & + OSNOWDRIFT,OSNOWDRIFT_SUBLIM,OSNOW_ABS_ZENITH, & + HSNOWMETAMO,HSNOWRAD, & + act_level, VIS_ICEALB, & + PFSA_CROCUS, PFSR_CROCUS, PFIRA_CROCUS, & + FLOW_ICE, FLOW_SNOW, & + I,J) !(OUT)) +! ########################################################################## +! +!!**** *SNOWCRO* +!! +!! PURPOSE +!! ------- +! +! Detailed snowpack scheme Crocus, computationnally based on the +! 3-Layer snow scheme option (Boone and Etchevers 1999) +! For shallow snow cover, Default method of Douville et al. (1995) +! used with this option: Model "turns on" when snow sufficiently +! deep/above some preset critical snow depth. +! +! +! +! +!!** METHOD +!! ------ +! +! Direct calculation +! +!! EXTERNAL +!! -------- +! +! None +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! +!! +!! REFERENCE +!! --------- +!! +!! ISBA: Belair (1995) +!! ISBA: Noilhan and Planton (1989) +!! ISBA: Noilhan and Mahfouf (1996) +!! ISBA-ES: Boone and Etchevers (2001) +!! Crocus : Brun et al., 1989 (J. Glaciol.) +!! Crocus : Brun et al., 1992 (J. Glaciol.) +!! Crocus : Vionnet et al., in prep (Geosci. Mod. Devel. Discuss.) +!! +!! +!! AUTHOR +!! ------ +!! A. Boone * Meteo-France * +!! V. Vionnet * Meteo-France * +!! E. Brun * Meteo-France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 7/99 +!! Modified by A.Boone 05/02 (code, not physics) +!! Modified by A.Boone 11/04 i) maximum density limit imposed (although +!! rarely if ever reached), ii) check to +!! see if upermost layer completely sublimates +!! during a timestep (as snowpack becomes vanishly +!! thin), iii) impose maximum grain size limit +!! in radiation transmission computation. +!! +!! Modified by B. Decharme (03/2009): Consistency with Arpege permanent +!! snow/ice treatment (LGLACIER for alb) +!! Modified by A. Boone (04/2010): Implicit coupling and replace Qsat and DQsat +!! by Qsati and DQsati, respectively. +!! Modified by E. Brun, V. Vionnet, S. Morin (05/2011): +!! Addition of Crocus processes and +!! parametrizations to +!! the SNOW-3L code. This includes the dynamic handling +!! of snow layers and the inclusion of snow metamorphism +!! rules similar to the original Crocus implementation. +!! Modified by B. Decharme (09/2012): New wind implicitation +!! +!! Modified by M. Lafaysse (07/2012) : +!! * Albedo and roughness parametrizations +!! for surface ice over glaciers +!! MODIF 2012-10-03 : don't modify roughness if implicit coupling +!! (test PPEW_A_COEF == 0. ) +!! * SNOWCROALB is now called by SNOWCRORAD to remove duplicated code +!! * Parameters for albedo are moved to modd_snow_par +!! * PSNOWAGE is stored as an age +!! (days since snowfall) and not as a date +!! to allow spinup simulations +!! * New rules for optimal discretization of very thick snowpacks +!! * Optional outputs for debugging +!! +!! Modified by E. Brun and M. Lafaysse (07/2012) : +!! * Implement sublimation in SNOWDRIFT +!! * Flag in namelist to activate SNOWDRIFT and SNOWDRIFT_SUBLIM +!! Modified by E. Brun and M. Lafaysse (08/2012) : +!! * XUEPSI replaced by 0 in the if statement of case 1.3.3.2 (SNOWCROMETAMO) +!! * If SNOWDRIFT is activated the wind do not modify grain types during snowfall +!! (redundant with snowdrift) +!! Modified by E. Brun (24/09/2012) : +!! * Correction coupling coefficient for specific humidity in SNOWCROEBUD +!! * PSFCFRZ(:) = 1.0 for systematic solid/vapor latent fluxes in SNOWCROEBUD +!! Modified by C. Carmagnola (3/2013): +!! * Dendricity and size replaced by the optical diameter +!! * Test of different evolution laws for the optical diameter +!! +!! Modified by B. Decharme (08/2013): Qsat as argument (needed for coupling with atm) +!! add PSNDRIFT +!! +!! +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +!USE MODD_TYPE_DATE_SURF, ONLY: DATE_TIME +! +USE MODD_CSTS, ONLY : XTT, XRHOLW, XLMTT,XLSTT,XLVTT, XCL, XCI, XPI, XRHOLI,XZ0ICEZ0SNOW, XRHOTHRESHOLD_ICE +!USE MODD_SNOW_PAR, ONLY : XZ0ICEZ0SNOW, XRHOTHRESHOLD_ICE +USE MODD_SNOW_METAMO ! trude, declare these paramters at the beginning +!USE MODD_CONST_TARTES, ONLY: NPNIMP, XPSNOWG0, XPSNOWY0, XPSNOWW0, XPSNOWB0 +! +USE MODE_SNOW3L +!USE MODE_TARTES, ONLY : SNOWCRO_TARTES +! +!USE MODE_CRODEBUG +! +!USE MODI_ABOR1_SFX +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +! this module is not used anymore +! USE MODI_GREGODSTRATI + + +! +IMPLICIT NONE +! +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PTSTEP +! PTSTEP = time step of the integration +!TYPE(DATE_TIME), INTENT(IN) :: TPTIME ! current date and time +! + CHARACTER(LEN=*), INTENT(IN) :: HSNOWRES +! HSNOWRES = ISBA-SNOW3L turbulant exchange option +! 'DEF' = Default: Louis (ISBA: Noilhan and Mahfouf 1996) +! 'RIL' = Limit Richarson number under very stable +! conditions (currently testing) +LOGICAL, INTENT(IN) :: OGLACIER ! True = Over permanent snow and ice, +! initialise WGI=WSAT, +! Hsnow>=10m and allow 0.80. ) THEN + PSNOWDZ(JJ,JST) = PSNOWSWE(JJ,JST) / PSNOWRHO(JJ,JST) + INLVLS_USE(JJ) = JST + ELSE + PSNOWDZ(JJ,JST) = 0. + ENDIF + ENDDO ! end loop snow layers +ENDDO ! end loop grid points + + +! Incrementation of snow layers age +ZTSTEPDAYS = PTSTEP/86400. ! time step in days +WHERE ( PSNOWSWE>0 ) PSNOWAGE = PSNOWAGE + ZTSTEPDAYS +! +!***************************************PRINT IN********************************************** +! +!Compute total SWE and heat for energy control +!IF ( GCRODEBUGPRINTBALANCE ) THEN +! DO JJ = 1,SIZE(ZSNOW) +! ZSUMMASS_INI(JJ) = SUM(PSNOWSWE (JJ,1:INLVLS_USE(JJ))) +! ZSUMHEAT_INI(JJ) = SUM(PSNOWHEAT(JJ,1:INLVLS_USE(JJ))) +! ENDDO ! end loop grid points! +!ENDIF +! +! Print of some simulation characteristics +!IF(GCROINFOPRINT) THEN +! CALL SNOWCROPRINTDATE() +! WRITE(*,FMT="(A12,I3,A12,I4)") 'nlayer:',INLVLS_USE(IDEBUG), ' nbpoints:', SIZE(ZSNOW) +! WRITE(*,*) 'PZ0H: ', PZ0H(IDEBUG) +! WRITE(*,*) 'Snow fraction =',PPSN3L(IDEBUG) +!ENDIF +! +!***************************************PRINT OUT********************************************* +!***************************************DEBUG IN********************************************** + +!IF (GCRODEBUGPRINT) THEN +! CALL SNOWCROPRINTDATE() +! CALL SNOWCROPRINTPROFILE("crocus initialization",INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),& +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:),& +! HSNOWMETAMO) +!END IF +! +!IF (GCRODEBUGPRINTATM) THEN +! CALL SNOWCROPRINTATM("forcing data :",PTA(IDEBUG),PQA(IDEBUG),PVMOD(IDEBUG), & +! PRR(IDEBUG),PSR(IDEBUG),PSW_RAD(IDEBUG),PLW_RAD(IDEBUG), & +! PTG(IDEBUG),PSOILCOND(IDEBUG),PD_G(IDEBUG),PPSN3L(IDEBUG) ) +!END IF +!***************************************DEBUG OUT******************************************** +! +!* 1. Snow total depth +! ---------------- +! +ZSNOW(:) = 0. +DO JJ = 1,SIZE(ZSNOW) + ZSNOW(JJ) = SUM(PSNOWDZ(JJ,1:INLVLS_USE(JJ))) +ENDDO +! +ZSNOWBIS(:) = ZSNOW(:) +! +!* 2. Snowfall +! -------- +! Calculate uppermost density and thickness changes due to snowfall, +! and add heat content of falling snow +! + + CALL SNOWNLFALL_UPGRID(OGLACIER, & + PTSTEP,PSR,PTA,PVMOD,ZSNOWBIS,PSNOWRHO,PSNOWDZ, & + PSNOWHEAT,PSNOWHMASS,PSNOWALB,PPERMSNOWFRAC, & + PSNOWGRAN1,PSNOWGRAN2,GSNOWFALL,ZSNOWDZN, & + ZSNOWRHOF,ZSNOWDZF,ZSNOWGRAN1F,ZSNOWGRAN2F, ZSNOWHISTF, & + ZSNOWAGEF,GMODIF_MAILLAGE,INLVLS_USE,OSNOWDRIFT,PZ0EFF,PUREF,& + HSNOWMETAMO) + + +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWFALL_UPGRID",INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),& +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:),& +! HSNOWMETAMO ) +!ENDIF +!***************************************DEBUG OUT********************************************** +! +ZSNOW(:) = ZSNOWBIS(:) +! +!* 3. Update grid/discretization +! -------------------------- +! Reset grid to conform to model specifications: +! +DO JJ=1,SIZE(ZSNOW) +! + IF ( GMODIF_MAILLAGE(JJ) ) THEN + + + CALL SNOWNLGRIDFRESH_1D(JJ,ZSNOW(JJ),PSNOWDZ(JJ,:),ZSNOWDZN(JJ,:),PSNOWRHO(JJ,:), & + PSNOWHEAT(JJ,:),PSNOWGRAN1(JJ,:),PSNOWGRAN2(JJ,:), & + PSNOWHIST(JJ,:),PSNOWAGE(JJ,:),GSNOWFALL(JJ),ZSNOWRHOF(JJ), & + ZSNOWDZF(JJ),PSNOWHMASS(JJ),ZSNOWGRAN1F(JJ),ZSNOWGRAN2F(JJ), & + ZSNOWHISTF(JJ),ZSNOWAGEF(JJ),INLVLS_USE(JJ),HSNOWMETAMO, I, J ) + + ENDIF + ! + + +ENDDO + +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWNLGRIDFRESH_1D",INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),& +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:),& +! HSNOWMETAMO ) +!ENDIF +!***************************************DEBUG OUT********************************************** +! +!* 4. Liquid water content and snow temperature +! ----------------------------------------- +! +! First diagnose snow temperatures and liquid +! water portion of the snow from snow heat content: +! update some snow layers parameters after new discretization +! +DO JJ = 1,SIZE(ZSNOW) + ! + ! active layers + DO JST=1,INLVLS_USE(JJ) + PSNOWSWE (JJ,JST) = PSNOWDZ(JJ,JST) * PSNOWRHO(JJ,JST) + ZSCAP (JJ,JST) = PSNOWRHO(JJ,JST) * XCI + ZSNOWTEMP(JJ,JST) = XTT + & + ( ( PSNOWHEAT(JJ,JST)/PSNOWDZ(JJ,JST) + XLMTT*PSNOWRHO(JJ,JST) )/ZSCAP(JJ,JST) ) +! + PSNOWLIQ (JJ,JST) = MAX( 0.0, ZSNOWTEMP(JJ,JST)-XTT ) * ZSCAP(JJ,JST) * & + PSNOWDZ(JJ,JST) / (XLMTT*XRHOLW) +! + ZSNOWTEMP(JJ,JST) = MIN( XTT, ZSNOWTEMP(JJ,JST) ) + ENDDO ! end loop active snow layers + + ! + ! unactive layers + DO JST = INLVLS_USE(JJ)+1,SIZE(PSNOWSWE,2) + PSNOWSWE (JJ,JST) = 0.0 + PSNOWRHO (JJ,JST) = 999. + PSNOWDZ (JJ,JST) = 0. + PSNOWGRAN1(JJ,JST) = 0. + PSNOWGRAN2(JJ,JST) = 0. + PSNOWHIST (JJ,JST) = 0. + PSNOWAGE (JJ,JST) = 0. + PSNOWHEAT (JJ,JST) = 0. + ZSNOWTEMP (JJ,JST) = XTT + PSNOWLIQ (JJ,JST) = 0. + ENDDO ! end loop unactive snow layers + ! +ENDDO ! end loop grid points +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after liquid water/temperature diagnostic", & +! INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),& +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:),& +! HSNOWMETAMO ) +!ENDIF +!***************************************DEBUG OUT********************************************** +! +! 4.BIS Snow metamorphism +! ----------------- +! + CALL SNOWCROMETAMO(PSNOWDZ,PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST,ZSNOWTEMP, & + PSNOWLIQ,PTSTEP,PSNOWSWE,INLVLS_USE,PSNOWAGE,HSNOWMETAMO ) + +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROMETAMO", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),& +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:),& +! HSNOWMETAMO ) +!ENDIF +!***************************************DEBUG OUT********************************************** +! +!* 5. Snow Compaction +! --------------- +! Calculate snow density: compaction/aging: density increases +! + + CALL SNOWCROCOMPACTN(PTSTEP,PSNOWRHO,PSNOWDZ,ZSNOWTEMP,ZSNOW, & + PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST,PSNOWLIQ,INLVLS_USE,PDIRCOSZW,& + HSNOWMETAMO) +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROCOMPACTN", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),& +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:),& +! HSNOWMETAMO ) +!ENDIF +!***************************************DEBUG OUT********************************************** +! +!* 5.1 Snow Compaction and Metamorphism due to snow drift +! --------------- +PSNDRIFT(:) = 0.0 +IF (OSNOWDRIFT) THEN + + CALL SNOWDRIFT(PTSTEP, PVMOD, PSNOWRHO,PSNOWDZ, ZSNOW, & + PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST,INLVLS_USE,PTA,PQA,PPS,PRHOA,& + PZ0EFF,PUREF,OSNOWDRIFT_SUBLIM,HSNOWMETAMO,PSNDRIFT) + +ENDIF + +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWDRIFT", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),& +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:),& +! HSNOWMETAMO ) +!ENDIF +!***************************************DEBUG OUT********************************************** +! +! Update snow heat content (J/m2) using dry density instead of total density: +! +DO JJ = 1,SIZE(ZSNOW) + DO JST = 1,INLVLS_USE(JJ) + ZSCAP(JJ,JST) = ( PSNOWRHO(JJ,JST) - & + PSNOWLIQ(JJ,JST) * XRHOLW / MAX( PSNOWDZ(JJ,JST),XSNOWDZMIN) ) * XCI + PSNOWHEAT(JJ,JST) = PSNOWDZ(JJ,JST) * & + ( ZSCAP(JJ,JST)*(ZSNOWTEMP(JJ,JST)-XTT) - XLMTT*PSNOWRHO(JJ,JST) ) + & + XLMTT * XRHOLW * PSNOWLIQ(JJ,JST) + ENDDO ! end loop snow layers +ENDDO ! end loop grid points +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after update snow heat content", INLVLS_USE(IDEBUG),LPRINTGRAN,& +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO ) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +!* 6. Solar radiation transmission +! ----------------------------- +! +! Heat source (-sink) term due to shortwave +! radiation transmission within the snowpack: +! +SELECT CASE (HSNOWRAD) +! CASE ("TA1") +! ZSNOWIMP_CONTENT(:,:,1) = 0.0 +! CASE ("TA2") +! ZSNOWIMP_CONTENT(:,:,1) = 100.0E-9 +! CASE ("TAR") +! ZSNOWIMP_CONTENT(:,:,1) = 2. * PSNOWAGE(:,:) * 1E-9 + CASE DEFAULT +END SELECT +! +SELECT CASE (HSNOWRAD) + CASE ("B92") + + CALL SNOWCRORAD(OGLACIER, & + PSW_RAD,PSNOWALB,PSNOWDZ,PSNOWRHO, & + PALB,ZRADSINK,ZRADXS, & + PSNOWGRAN1, PSNOWGRAN2, PSNOWAGE,PPS, & + PZENITH, PPERMSNOWFRAC,INLVLS_USE, & + OSNOW_ABS_ZENITH,HSNOWMETAMO,VIS_ICEALB) + + CASE ("TAR","TA1","TA2") +! CALL SNOWCRO_TARTES(PSNOWGRAN1,PSNOWGRAN2,PSNOWRHO,PSNOWDZ,ZSNOWG0,ZSNOWY0,ZSNOWW0, & +! ZSNOWB0,ZSNOWIMP_DENSITY,ZSNOWIMP_CONTENT,PALB,PSW_RAD,PZENITH, & +! INLVLS_USE,PSNOWALB,ZRADSINK,ZRADXS,GCRODEBUGDETAILSPRINT,HSNOWMETAMO) + ! + CASE DEFAULT +! CALL ABOR1_SFX("UNKNOWN CSNOWRAD OPTION") + ! +END SELECT + +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCRORAD", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +!* 7. Heat transfer and surface energy budget +! --------------------------------------- +! Snow thermal conductivity: +! + CALL SNOWCROTHRM(PSNOWRHO,ZSCOND,ZSNOWTEMP,PPS,PSNOWLIQ,GCOND_GRAIN,GCOND_YEN) +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROTHRM", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +! Precipitation heating term: +! Rainfall renders it's heat to the snow when it enters +! the snowpack: +! +PHPSNOW(:) = PRR(:) * XCL * ( MAX( XTT,PTA(:) ) - XTT ) ! (W/m2) +! +! Surface Energy Budget calculations using ISBA linearized form +! and standard ISBA turbulent transfer formulation +! + +IF ( ALL(PPEW_A_COEF==0.) ) THEN + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Modif Matthieu Lafaysse for glaciers + ! For surface ice, modify roughness lengths + ! Only if not implicit coupling + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + WHERE( PSNOWRHO(:,1)>XRHOTHRESHOLD_ICE ) + ZZ0_SNOWICE = PZ0 * XZ0ICEZ0SNOW + ZZ0H_SNOWICE = PZ0H * XZ0ICEZ0SNOW + ZZ0EFF_SNOWICE = PZ0EFF * XZ0ICEZ0SNOW + ELSEWHERE + ZZ0_SNOWICE = PZ0 + ZZ0H_SNOWICE = PZ0H + ZZ0EFF_SNOWICE = PZ0EFF + ENDWHERE +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +ELSE +! trude test increased roughnesslenght on ice, even with implicit coupling +!++TE + WHERE( PSNOWRHO(:,1)>XRHOTHRESHOLD_ICE ) + ZZ0_SNOWICE = PZ0 * XZ0ICEZ0SNOW + ZZ0H_SNOWICE = PZ0H * XZ0ICEZ0SNOW + ZZ0EFF_SNOWICE = PZ0EFF * XZ0ICEZ0SNOW + ELSEWHERE +!-- TE + ZZ0_SNOWICE = PZ0 + ZZ0H_SNOWICE = PZ0H + ZZ0EFF_SNOWICE = PZ0EFF + ENDWHERE ! trude added +END IF + + + CALL SNOWCROEBUD(HSNOWRES, HIMPLICIT_WIND, & + PPEW_A_COEF, PPEW_B_COEF, & + PPET_A_COEF, PPEQ_A_COEF, PPET_B_COEF, PPEQ_B_COEF, & + XSNOWDZMIN, & + PZREF,ZSNOWTEMP(:,1),PSNOWRHO(:,1),PSNOWLIQ(:,1),ZSCAP(:,1), & + ZSCOND(:,1),ZSCOND(:,2), & + PUREF,PEXNS,PEXNA,PDIRCOSZW,PVMOD, & + PLW_RAD,PSW_RAD,PTA,PQA,PPS,PTSTEP, & + PSNOWDZ(:,1),PSNOWDZ(:,2),PSNOWALB,ZZ0_SNOWICE, & + ZZ0EFF_SNOWICE,ZZ0H_SNOWICE, & + ZSFCFRZ,ZRADSINK(:,1),PHPSNOW, & + ZCT,PEMISNOW,PRHOA,ZTSTERM1,ZTSTERM2,ZRA,PCDSNOW,PCHSNOW, & + ZQSAT, ZDQSAT, ZRSRA, ZUSTAR2_IC, PRI, & + ZPET_A_COEF_T,ZPEQ_A_COEF_T,ZPET_B_COEF_T,ZPEQ_B_COEF_T ) + + +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROEBUD", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +! Heat transfer: simple diffusion along the thermal gradient +! +ZSNOWTEMPO1(:) = ZSNOWTEMP(:,1) ! save surface snow temperature before update +! + CALL SNOWCROSOLVT(PTSTEP,XSNOWDZMIN,PSNOWDZ,ZSCOND,ZSCAP,PTG, & + PSOILCOND,PD_G,ZRADSINK,ZCT,ZTSTERM1,ZTSTERM2, & + ZPET_A_COEF_T,ZPEQ_A_COEF_T,ZPET_B_COEF_T,ZPEQ_B_COEF_T, & + ZTA_IC,ZQA_IC,PGRNDFLUX, ZSNOWTEMP ,ZSNOWFLUX, & + INLVLS_USE ) + +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROSOLVT", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF + +!***************************************DEBUG OUT******************************************** +! +!* 8. Surface fluxes +! -------------- +! + + CALL SNOWCROFLUX(ZSNOWTEMP(:,1),PSNOWDZ(:,1),PEXNS,PEXNA, & + ZUSTAR2_IC, & + PTSTEP,PSNOWALB,PSW_RAD,PEMISNOW,ZLWUPSNOW,PLW_RAD, & + ZTA_IC,ZSFCFRZ,ZQA_IC,PHPSNOW, & + ZSNOWTEMPO1,ZSNOWFLUX,ZCT,ZRADSINK(:,1), & + ZQSAT,ZDQSAT,ZRSRA, & + PRNSNOW,PHSNOW,PGFLUXSNOW,PLES3L,PLEL3L,PEVAP, & + PUSTAR, & + PFSA_CROCUS, PFSR_CROCUS, PFIRA_CROCUS) ! trude added + +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROFLUX", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +!* 9. Snow melt +! --------- +! +! First Test to see if snow pack vanishes during this time step: +! + + CALL SNOWCROGONE(PTSTEP,PLEL3L,PLES3L,PSNOWRHO, & + PSNOWHEAT,ZRADSINK,PEVAPCOR,PTHRUFAL,PGRNDFLUX, & + PGFLUXSNOW,PSNOWDZ,PSNOWLIQ,ZSNOWTEMP,ZRADXS, & + PRR,INLVLS_USE ) + +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROGONE", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +! Add radiation not absorbed by snow to soil/vegetation interface flux +! (for thin snowpacks): +! +PGRNDFLUX(:) = PGRNDFLUX(:) + ZRADXS(:) +! +! Second Test to see if one or several snow layers vanishe during this time +! step. In such a case, the concerned snow layers are agregated to neighbours + + CALL SNOWCROLAYER_GONE(PTSTEP,ZSCAP,ZSNOWTEMP,PSNOWDZ, & + PSNOWRHO,PSNOWLIQ,PSNOWGRAN1,PSNOWGRAN2, & + PSNOWHIST,PSNOWAGE,PLES3L, INLVLS_USE ) +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROLAYER_GONE", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +! For partial melt: transform excess heat content into snow liquid: +! + + CALL SNOWCROMELT(ZSCAP,ZSNOWTEMP,PSNOWDZ,PSNOWRHO,PSNOWLIQ,INLVLS_USE) + +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROMELT", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +!* 10. Snow water flow and refreezing +! ------------------------------ +! Liquid water vertical transfer and possible snowpack runoff +! And refreezing/freezing of meltwater/rainfall (ripening of the snow) +! + + CALL SNOWCROREFRZ(PTSTEP,PRR,PSNOWRHO,ZSNOWTEMP,PSNOWDZ,PSNOWLIQ,PTHRUFAL, & + ZSCAP,PLEL3L,INLVLS_USE ) + +! ++ trude +!Assign streamflow from ice versus snow for output (diagnostics) +IF (PSNOWRHO(1,1) .ge. XRHOTHRESHOLD_ICE) THEN + FLOW_ICE = PTHRUFAL +ELSE + FLOW_SNOW= PTHRUFAL +ENDIF + +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROREFRZ", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +!* 11. Snow Evaporation/Sublimation mass updates: +! ------------------------------------------ +! + + CALL SNOWCROEVAPN(PLES3L,PTSTEP,ZSNOWTEMP(:,1),PSNOWRHO(:,1), & + PSNOWDZ(:,1),PEVAPCOR,PSNOWHMASS ) +! +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROEVAPN", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +! If all snow in uppermost layer evaporates/sublimates, re-distribute +! grid (below could be evoked for vanishingly thin snowpacks): +! + + CALL SNOWCROEVAPGONE(PSNOWHEAT,PSNOWDZ,PSNOWRHO,ZSNOWTEMP,PSNOWLIQ,PSNOWGRAN1, & + PSNOWGRAN2,PSNOWHIST,PSNOWAGE,INLVLS_USE,HSNOWMETAMO ) + + +!***************************************DEBUG IN********************************************** +!IF (GCRODEBUGDETAILSPRINT) THEN +! CALL SNOWCROPRINTPROFILE("after SNOWCROEVAPGONE", INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:), & +! PSNOWLIQ(IDEBUG,:),PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:), & +! PSNOWGRAN2(IDEBUG,:),PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), & +! HSNOWMETAMO) +!ENDIF +!***************************************DEBUG OUT******************************************** +! +!* 12. Update surface albedo: +! ---------------------- +! Snow clear sky albedo: +! +IF ( HSNOWRAD=='B92' ) THEN + + + CALL SNOWCROALB(OGLACIER, & + PSNOWALB,ZSPECTRALALBEDO,PSNOWDZ(:,1),PSNOWRHO(:,1:2), & + PPERMSNOWFRAC,PSNOWGRAN1(:,1),PSNOWGRAN2(:,1), & + PSNOWAGE(:,1),PSNOWGRAN1(:,2),PSNOWGRAN2(:,2),PSNOWAGE(:,2), & + PPS, PZENITH, INLVLS_USE, HSNOWMETAMO,VIS_ICEALB) + +ENDIF + +! +!* 13. Update snow heat content: +! ------------------------- +! Update the heat content (variable stored each time step) +! using current snow temperature and liquid water content: +! +! First, make check to make sure heat content not too large +! (this can result due to signifigant heating of thin snowpacks): +! add any excess heat to ground flux: +! +DO JJ = 1,SIZE(ZSNOW) +! active layers + DO JST = 1,INLVLS_USE(JJ) + ZWHOLDMAX (JJ,JST) = SNOWCROHOLD( PSNOWRHO(JJ,JST),PSNOWLIQ(JJ,JST),PSNOWDZ(JJ,JST) ) +! trude test with not allowing liquid if psnowrho > XRHOTHRESHOLD_ICE (i.e. no liquid in ice) +! IF (PSNOWRHO(JJ,JST).GT.XRHOTHRESHOLD_ICE) ZWHOLDMAX (JJ,JST)=0 +! end trude test + + ZLIQHEATXS(JJ) = MAX( 0.0, (PSNOWLIQ(JJ,JST) - ZWHOLDMAX(JJ,JST)) * XRHOLW ) * XLMTT/PTSTEP + PSNOWLIQ (JJ,JST) = PSNOWLIQ(JJ,JST) - ZLIQHEATXS(JJ)*PTSTEP/(XRHOLW*XLMTT) + PSNOWLIQ (JJ,JST) = MAX( 0.0, PSNOWLIQ(JJ,JST) ) + PGRNDFLUX (JJ) = PGRNDFLUX(JJ) + ZLIQHEATXS(JJ) + PSNOWTEMP (JJ,JST) = ZSNOWTEMP(JJ,JST) +! Heat content using total density + ZSCAP (JJ,JST) = PSNOWRHO(JJ,JST) * XCI + PSNOWHEAT (JJ,JST) = PSNOWDZ(JJ,JST) * & + ( ZSCAP(JJ,JST)*(PSNOWTEMP(JJ,JST)-XTT) - XLMTT*PSNOWRHO(JJ,JST) ) + & + XLMTT * XRHOLW * PSNOWLIQ(JJ,JST) +! + PSNOWSWE(JJ,JST) = PSNOWDZ(JJ,JST) * PSNOWRHO(JJ,JST) + ENDDO ! end loop active snow layers +! +! unactive layers + DO JST = INLVLS_USE(JJ)+1,SIZE(PSNOWSWE,2) + PSNOWSWE(JJ,JST) = 0. + PSNOWHEAT(JJ,JST) = 0. + PSNOWRHO(JJ,JST) = 999. + PSNOWTEMP(JJ,JST) = 0. + PSNOWDZ(JJ,JST) = 0. + ENDDO ! end loop unactive snow layers +! +ENDDO ! end loop grid points +! +! print some final diagnostics +! ! ! IF (INLVLS_USE(I)>0) THEN +! ! ! WRITE(*,FMT="(I4,2I4,F4.0,A7,F5.2,A10,F7.1,A11,F6.2,A13,F6.2)") & +! ! ! TPTIME%TDATE%YEAR,TPTIME%TDATE%MONTH,TPTIME%TDATE%DAY,TPTIME%TIME/3600.,& +! ! ! 'HTN= ',SUM(PSNOWDZ(I,1:INLVLS_USE(I))), 'FLUX Sol=', PGRNDFLUX(I),& +! ! ! 'Tsurf_sol=',PTG(I)-273.16, 'Tbase_neige=',PSNOWTEMP(I,INLVLS_USE(I))-273.16 +! ! ! ENDIF +! +!***************************************DEBUG IN********************************************* +!IF (GCRODEBUGPRINT) THEN +! CALL SNOWCROPRINTDATE() +! CALL SNOWCROPRINTPROFILE("CROCUS : end of time step",INLVLS_USE(IDEBUG),LPRINTGRAN, & +! PSNOWDZ(IDEBUG,:),PSNOWRHO(IDEBUG,:),PSNOWTEMP(IDEBUG,:),PSNOWLIQ(IDEBUG,:), & +! PSNOWHEAT(IDEBUG,:),PSNOWGRAN1(IDEBUG,:),PSNOWGRAN2(IDEBUG,:), & +! PSNOWHIST(IDEBUG,:),PSNOWAGE(IDEBUG,:), HSNOWMETAMO) +!END IF +!***************************************DEBUG OUT******************************************** +!***************************************PRINT IN********************************************* +! check suspect low temperature +DO JJ = 1,SIZE(ZSNOW) +!IF(INLVLS_USE(JJ)>0) WRITE(*,*) 'SOL:',JJ,INLVLS_USE(JJ),PGRNDFLUX(JJ),PTG(JJ),& +! PSNOWTEMP(jj,INLVLS_USE(JJ)),PSNOWTEMP(jj,1),PZENITH(JJ) + DO JST = 1,INLVLS_USE(JJ) + IF ( PSNOWTEMP(JJ,JST) < 100. ) THEN + WRITE(6,*) 'pb tempe snow :',PSNOWTEMP(JJ,JST) +! WRITE(6,FMT='("DATE:",2(I2.2,"/"),I4.4,F3.0)') & +! TPTIME%TDATE%DAY,TPTIME%TDATE%MONTH,TPTIME%TDATE%YEAR,TPTIME%TIME/3600. + WRITE(6,*) 'point',JJ,"/",SIZE(ZSNOW) + WRITE(6,*) 'layer',JST + WRITE(6,*) 'pressure',PPS(JJ) + WRITE(6,*) 'slope',ACOS(PDIRCOSZW(JJ))*(180./XPI),"deg" + WRITE(6,*) 'solar radiation=',PSW_RAD(JJ) + WRITE(6,*) 'INLVLS_USE(JJ):',INLVLS_USE(JJ) + WRITE(6,*) PSNOWDZ(JJ,1:INLVLS_USE(JJ)) + WRITE(6,*) PSNOWRHO(JJ,1:INLVLS_USE(JJ)) + WRITE(6,*) PSNOWTEMP(JJ,1:INLVLS_USE(JJ)) +! CALL ABOR1_SFX('SNOWCRO: erreur tempe snow') + ENDIF + ENDDO +ENDDO +!***************************************PRINT OUT********************************************* +!***************************************DEBUG IN********************************************* +!Control and print energy balance +!IF (GCRODEBUGPRINTBALANCE) THEN + ! +! ZSUMMASS_FIN(IDEBUG) = SUM( PSNOWSWE (IDEBUG,1:INLVLS_USE(IDEBUG)) ) +! ZSUMHEAT_FIN(IDEBUG) = SUM( PSNOWHEAT(IDEBUG,1:INLVLS_USE(IDEBUG)) ) + ! +! CALL GET_BALANCE(ZSUMMASS_INI(IDEBUG),ZSUMHEAT_INI(IDEBUG),ZSUMMASS_FIN(IDEBUG), & +! ZSUMHEAT_FIN(IDEBUG),PSR(IDEBUG),PRR(IDEBUG),PTHRUFAL(IDEBUG), & +! PEVAP(IDEBUG),PEVAPCOR(IDEBUG),PGRNDFLUX(IDEBUG),PHSNOW(IDEBUG),& +! PRNSNOW(IDEBUG),PLEL3L(IDEBUG),PLES3L(IDEBUG),PHPSNOW(IDEBUG), & +! PSNOWHMASS(IDEBUG),PSNOWDZ(IDEBUG,1),PTSTEP, & +! ZMASSBALANCE(IDEBUG),ZENERGYBALANCE(IDEBUG),ZEVAPCOR2(IDEBUG) ) + ! +! CALL SNOWCROPRINTBALANCE(ZSUMMASS_INI(IDEBUG),ZSUMHEAT_INI(IDEBUG),ZSUMMASS_FIN(IDEBUG), & +! ZSUMHEAT_FIN(IDEBUG),PSR(IDEBUG),PRR(IDEBUG),PTHRUFAL(IDEBUG), & +! PEVAP(IDEBUG),PEVAPCOR(IDEBUG),PGRNDFLUX(IDEBUG),PHSNOW(IDEBUG),& +! PRNSNOW(IDEBUG),PLEL3L(IDEBUG),PLES3L(IDEBUG),PHPSNOW(IDEBUG), & +! PSNOWHMASS(IDEBUG),PSNOWDZ(IDEBUG,1),PTSTEP, & +! ZMASSBALANCE(IDEBUG),ZENERGYBALANCE(IDEBUG),ZEVAPCOR2(IDEBUG)) + ! +!ENDIF +! +!IF (LPSTOPBALANCE) THEN + ! + ! bilan pour tous points pour test eventuel sur depassement seuil des residus +! DO JJ=1, SIZE(ZSNOW) + ! +! ZSUMMASS_FIN(JJ) = SUM( PSNOWSWE (JJ,1:INLVLS_USE(JJ)) ) +! ZSUMHEAT_FIN(JJ) = SUM( PSNOWHEAT(JJ,1:INLVLS_USE(JJ)) ) + ! +! CALL GET_BALANCE(ZSUMMASS_INI(JJ),ZSUMHEAT_INI(JJ),ZSUMMASS_FIN(JJ), & +! ZSUMHEAT_FIN(JJ),PSR(JJ),PRR(JJ),PTHRUFAL(JJ), & +! PEVAP(JJ),PEVAPCOR(JJ),PGRNDFLUX(JJ),PHSNOW(JJ), & +! PRNSNOW(JJ),PLEL3L(JJ),PLES3L(JJ),PHPSNOW(JJ), & +! PSNOWHMASS(JJ),PSNOWDZ(JJ,1),PTSTEP, & +! ZMASSBALANCE(JJ),ZENERGYBALANCE(JJ),ZEVAPCOR2(JJ) ) +! ! +! ENDDO ! end loop grid points + ! +! CALL SNOWCROSTOPBALANCE(ZMASSBALANCE(:),ZENERGYBALANCE(:)) + ! +!END IF +!***************************************DEBUG OUT******************************************** +! +PQS(:) = ZQSAT(:) +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO',1,ZHOOK_HANDLE) +! + +!END SUBROUTINE SNOWCRO +CONTAINS +! +!#################################################################### +!#################################################################### +!#################################################################### + SUBROUTINE SNOWCROCOMPACTN(PTSTEP,PSNOWRHO,PSNOWDZ, & + PSNOWTEMP,PSNOW,PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST, & + PSNOWLIQ,INLVLS_USE,PDIRCOSZW,HSNOWMETAMO ) +! +!! PURPOSE +!! ------- +! Snow compaction due to overburden and settling. +! Mass is unchanged: layer thickness is reduced +! in proportion to density increases. Method +! directly inherited from Crocus v2.4 and +! coarsely described in Brun et al., J. Glac 1989 and 1992 +! +! de/e = -sigma/eta * dt +! +! where e is layer thickness, sigma is the vertical stress, dt is the +! time step and eta is the snow viscosity +! * sigma is currently calculated taking into account only the overburden +! (a term representing "metamorphism stress" in fresh snow may be added +! in the future) +! * eta is computed as a function of snowtype, density and temperature +! +! The local slope is taken into account, through the variable PDIRCOSZW +! which is directly the cosine of the local slope +! +! +! HISTORY: +! Basic structure from ISBA-ES model (Boone and Etchevers, 2001) +! Implementation of Crocus laws : E. Brun, S. Morin, J.-M. Willemet July 2010. +! Implementation of slope effect on settling : V. Vionnet, S. Morin May 2011 +! +! +USE MODD_CSTS, ONLY : XTT, XG +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES +USE MODD_SNOW_METAMO +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PTSTEP ! Time step UNIT : s +REAL, DIMENSION(:), INTENT(IN) :: PDIRCOSZW ! cosine of local slope +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWTEMP ! Snow temperature UNIT : K +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWRHO, PSNOWDZ ! Density UNIT : kg m-3, Layer thickness UNIT : m +! +REAL, DIMENSION(:), INTENT(OUT) :: PSNOW ! Snowheight UNIT : m +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWGRAN1, PSNOWGRAN2, PSNOWHIST, &!Snowtype variables + PSNOWLIQ ! Snow liquid water content UNIT ??? +INTEGER, DIMENSION(:), INTENT(IN) :: INLVLS_USE ! Number of snow layers used + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO ! metamorphism scheme +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZSNOWRHO2, &! work snow density UNIT : kg m-3 + ZVISCOSITY, &! Snow viscosity UNIT : N m-2 s (= Pa s) + ZSMASS !, & ! overburden mass for a given layer UNIT : kg m-2 +! ZWSNOWDZ ! mass of each snow layer UNIT : kg m-2 +! +INTEGER :: JJ,JST ! looping indexes +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!------------------------------------------------------------------------------- +! +! 1. Cumulative snow mass (kg/m2): +! -------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROCOMPACTN',0,ZHOOK_HANDLE) +! +DO JJ = 1,SIZE(PSNOW) + ZSMASS(JJ,1) = 0.0 + DO JST = 2,INLVLS_USE(JJ) + ZSMASS(JJ,JST) = ZSMASS(JJ,JST-1) + PSNOWDZ(JJ,JST-1) * PSNOWRHO(JJ,JST-1) + ENDDO + ZSMASS(JJ,1) = 0.5 * PSNOWDZ(JJ,1) * PSNOWRHO(JJ,1) ! overburden of half the mass of the uppermost layer applied to itself +ENDDO + +! +! 2. Compaction/Settling +! ---------------------- +! +DO JJ = 1,SIZE(PSNOW) + ! + DO JST = 1,INLVLS_USE(JJ) + ! + ! Snow viscosity basic equation (depend on temperature and density only): +! write(*,*) '-----' +! write(*,*) xvvisc1, xvvisc3, psnowrho(jj,jst), xvvisc4, xtt, psnowtemp(jj,jst), xvro11 +! write(*,*), XVVISC3*PSNOWRHO(JJ,JST) , XVVISC4*ABS(XTT-PSNOWTEMP(JJ,JST)) + ZVISCOSITY(JJ,JST) = XVVISC1 * & + EXP( XVVISC3*PSNOWRHO(JJ,JST) + XVVISC4*ABS(XTT-PSNOWTEMP(JJ,JST)) ) * & + PSNOWRHO(JJ,JST) / XVRO11 + + ! + ! Equations below apply changes to the basic viscosity value, based on snow microstructure properties + IF ( PSNOWLIQ(JJ,JST)>0.0 ) THEN + ZVISCOSITY(JJ,JST) = ZVISCOSITY(JJ,JST) / & + ( XVVISC5 + XVVISC6*PSNOWLIQ(JJ,JST)/PSNOWDZ(JJ,JST) ) + ENDIF + ! + IF( PSNOWLIQ(JJ,JST)/PSNOWDZ(JJ,JST)<=0.01 .AND. PSNOWHIST(JJ,JST)>=NVHIS2 ) THEN + ZVISCOSITY(JJ,JST) = ZVISCOSITY(JJ,JST) * XVVISC7 + ENDIF + ! + IF ( PSNOWHIST(JJ,JST)==NVHIS1 ) THEN + ! + IF ( HSNOWMETAMO=="B92" ) THEN + ! + IF ( PSNOWGRAN1(JJ,JST)>=0. .AND. PSNOWGRAN1(JJ,JST)=XVDIAM6*(4.-PSNOWGRAN2(JJ,JST)) .AND. PSNOWGRAN2(JJ,JST)D OU LA DIVISION PAR -XVGRAN1 POUR OBTENIR DES VALEURS +! ENTRE 1 ET 0 +! VARIES FROM -XVGRAN1 (DEFAULT -99) (FRESH SNOW) TO 0 +! DIVISION BY -XVGRAN1 TO OBTAIN VALUES BETWEEN 0 AND 1 + +! SGRAN2(JST) VARIE DE 0 (CAS COMPLETEMENT ANGULEUX) A XVGRAN1 +! (SPHERICITY) (99 PAR DEFAUT) +! >D OU LA DIVISION PAR XVGRAN1 POUR OBTENIR DES VALEURS +! ENTRE 0 ET 1 +! VARIES FROM 0 (SPHERICITY=0) TO XVGRAN1 + + +! CAS NON DENDRITIQUE / NON DENDRITIC CASE +! --------------------------------------- + +! SGRAN1(JST) VARIE DE 0 (CAS COMPLETEMENT ANGULEUX) A XVGRAN1 +! (SPHERICITY) (99 PAR DEFAUT) (CAS SPHERIQUE) +! >D OU LA DIVISION PAR XVGRAN1 POUR OBTENIR DES VALEURS +! ENTRE 0 ET 1 +! VARIES FROM 0 TO 99 + +! SGRAN2(JST) EST SUPERIEUR A XVDIAM1-SPHERICITE (3.E-4 M) ET NE FAIT QUE CROITRE +! (SIZE) IS GREATER THAN XVDIAM1-SPHERICITE (3.E-4 M) ALWAYS INCREASE + + +! EXEMPLES : POINTS CARACTERISTIQUES DE LA FIGURE +! -------- + +! SGRAN1 SGRAN2 DENDRICITE SPHERICITE TAILLE +! DENDRICITY SPHERICITY SIZE +! -------------------------------------------------------------- +! (M) +! 1 -XVGRAN1 VNSPH3 1 0.5 +! 2 0 0 0 0 +! 3 0 XVGRAN1 0 1 +! 4 0 XVDIAM1 0 4.E-4 +! 5 XVGRAN1 XVDIAM1-XVSPHE1 1 3.E-4 +! 6 0 -- 0 -- +! 7 XVGRAN1 -- 1 -- + +! PAR DEFAUT : XVGRAN1 =99 VNSPH3=50 XVSPHE1=1. XVDIAM1=4.E-4 + + +! METHODE. +! -------- +! EVOLUTION DES TYPES DE GRAINS : SELON LES LOIS DECRITES +! DANS BRUN ET AL (1992) +! PLUSIEURS CAS SONT A DISTINGUER +! 1.2 NEIGE HUMIDE +! 1.3 METAMORPHOSE NEIGE SECHE +! 1.3.1 FAIBLE GRADIENT +! 1.3.2 GRADIENT MOYEN +! 1.3.3 FORT GRADIENT +! DANS CHAQUE CAS ON SEPARE NEIGE DENDRITIQUE ET NON DENDRITIQUE +! LE PASSAGE DENDRITIQUE => NON DENDRITIQUE SE FAIT LORSQUE +! SGRAN1 DEVIENT > 0 + +! TASSEMENT : LOIS DE VISCOSITE ADAPTEE SELON LE TYPE DE GRAINS + +! VARIABLES HISTORIQUES (CAS NON DENDRITIQUE SEULEMENT) + +! MSHIST DEFAUT +! 0 CAS NORMAL +! NVHIS1 1 GRAINS ANGULEUX +! NVHIS2 2 GRAINS AYANT ETE EN PRESENCE D EAU LIQUIDE +! MAIS N'AYANT PAS EU DE CARATERE ANGULEUX +! NVHIS3 3 GRAINS AYANT ETE EN PRESENCE D EAU LIQUIDE +! AYANT EU AUPARAVANT UN CARACTERE ANGULEUX + +! GRAIN METAMORPHISM ACCORDING TO BRUN ET AL (1992) +! THE DIFFERENT CASES ARE : +! 1.2 WET SNOW +! 1.3 DRY SNOW +! 1.3.1. LOW TEMPERATURE GRADIENT +! 1.3.2. MODERATE TEMPERATURE GRADIENT +! 1.3.3. HIGH TEMPERATURE GRADIENTi +! THE CASE OF DENTRITIC OR NON DENDRITIC SNOW IS TREATED SEPARATELY +! THE LIMIT DENTRITIC ==> NON DENDRITIC IS REACHED WHEN SGRAN1>0 + +! SNOW SETTLING : VISCOSITY DEPENDS ON THE GRAIN TYPES + +! HISTORICAL VARIABLES (NON DENDRITIC CASE) +! MSHIST DEFAUT +! 0 CAS NORMAL +! NVHIS1 1 FACETED CRISTAL +! NVHIS2 2 LIQUID WATER AND NO FACETED CRISTALS BEFORE +! NVHIS3 3 LIQUID WATER AND FACETED CRISTALS BEFORE + +! EXTERNES. +! --------- + +! REFERENCES. +! ----------- + +! AUTEURS. +! -------- +! ERIC BRUN ET AL. - JOURNAL OF GLACIOLOGY 1989/1992. + +! MODIFICATIONS. +! -------------- +! 08/95: YANNICK DANIELOU - CODAGE A LA NORME DOCTOR. +! 09/96: ERIC MARTIN - CORRECTION COMMENTAIRES +! 03/06: JM Willemet - F90 and SI units +! 08/06: JM Willemet - new formulation for TEL (Mwat/(Mice+Mwat) instead of Mwat/Mice. +! Threshold on the diameter increasing of the wet grains. +! 01/07 : JM Willemet - CORRECTION DES COUCHES SATUREES SUBISSANT DU TASSEMENT +! CORRECTION ON THE SATURATED LAYERS WHICH ARE SETTLED +! 12/12: CM Carmagnola - Dendricity and size replaced by the optical diameter +! - Test of different evolution laws for the optical diameter +! 08/13: M Lafaysse - Simplification of historical parameter computation (logicals GNONDENDRITIC, GFACETED, GSPHE_LW) + ! +USE MODD_SNOW_METAMO +USE MODD_CSTS, ONLY : XTT, XPI, XRHOLW, XRHOLI +USE MODD_SNOW_PAR, ONLY : XUNDEF +! +USE MODE_SNOW3L +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +! 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWDZ, PSNOWTEMP, PSNOWLIQ, PSNOWSWE +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWGRAN1, PSNOWGRAN2, PSNOWHIST +! +REAL, INTENT(IN) :: PTSTEP +! +INTEGER, DIMENSION(:), INTENT(IN) :: INLVLS_USE +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWAGE +! + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO ! metamorphism scheme +! +! 0.2 declaration of local variables +! +REAL :: ZGRADT, ZTELM, ZVDENT, ZDENT, ZSPHE, ZVAP, ZDANGL, & + ZSIZE, ZSSA, ZSSA0, ZSSA_T, ZSSA_T_DT, ZA, ZB, ZC, & + ZA2, ZB2, ZC2, ZOPTD, ZOPTR, ZOPTR0, ZDRDT +REAL :: ZVDENT1, ZVDENT2, ZVSPHE, ZCOEF_SPH +REAL :: ZDENOM1, ZDENOM2, ZFACT1, ZFACT2 +INTEGER :: INLVLS +INTEGER :: JST,JJ !Loop controls +INTEGER :: IDRHO, IDGRAD, IDTEMP !Indices for values from Flanner 2006 +LOGICAL :: GNONDENDRITIC ,GFACETED, GSPHE_LW +LOGICAL :: GCOND_B92, GCOND_C13, GCOND_SPH +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +! INITIALISATION +! -------------- +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROMETAMO',0,ZHOOK_HANDLE) +! + +INLVLS = SIZE(PSNOWGRAN1(:,:),2) ! total snow layers +! +!* 1. METAMORPHOSES DANS LES STRATES. / METAMORPHISM +! ----------------------------------------------- +DO JJ = 1,SIZE(PSNOWRHO,1) + ! + DO JST = 1,INLVLS_USE(JJ) + ! + ! 1.1 INITIALISATION: GRADIENT DE TEMPERATURE / TEMPERATURE GRADIENT + IF ( JST==INLVLS_USE(JJ) ) THEN + ZGRADT = ABS(PSNOWTEMP(JJ,JST) - PSNOWTEMP(JJ,JST-1))*2. / (PSNOWDZ(JJ,JST-1) + PSNOWDZ(JJ,JST)) + ELSEIF ( JST==1 ) THEN + ZGRADT = ABS(PSNOWTEMP(JJ,JST+1) - PSNOWTEMP(JJ,JST) )*2. / (PSNOWDZ(JJ,JST) + PSNOWDZ(JJ,JST+1)) + ELSE + ZGRADT = ABS(PSNOWTEMP(JJ,JST+1) - PSNOWTEMP(JJ,JST-1))*2. / & + (PSNOWDZ(JJ,JST-1) + PSNOWDZ(JJ,JST)*2. + PSNOWDZ(JJ,JST+1)) + ENDIF + ! + IF ( PSNOWLIQ(JJ,JST)>XUEPSI ) THEN + ! 1.2 METAMORPHOSE HUMIDE. / WET SNOW METAMORPHISM + ! + ! TENEUR EN EAU LIQUIDE / LIQUID WATER CONTENT + ZTELM = XUPOURC * PSNOWLIQ(JJ,JST) * XRHOLW / PSNOWSWE(JJ,JST) + ! + ! VITESSES DE DIMINUTION DE LA DENDRICITE / RATE OF THE DENDRICITY DECREASE + ZVDENT1 = MAX( XVDENT2 * ZTELM**NVDENT1, XVDENT1 * EXP(XVVAP1/XTT) ) + ZVDENT2 = ZVDENT1 + ! CONDITION POUR LE CAS NON DENDRITIQUE NON SPHERIQUE + GCOND_B92 = ( PSNOWGRAN1(JJ,JST)0. ) + GCOND_C13 = ( HSNOWMETAMO=='C13' ) ! CONDITION POUR LE CALCUL DE SNOWGRAN1 + ! X COEF + ZVSPHE = XUNDEF + ! FOR C13 + ZCOEF_SPH = 3. + ! + ENDIF + ! + IF ( HSNOWMETAMO=="B92" ) THEN + ! + !------------------------------------------------ + ! BRUN et al. 1992 (B92) + ! + ! -> Wet snow and dry snow + ! -> Evolution of dendricity, sphericity and size + !------------------------------------------------ + ! + IF ( PSNOWGRAN1(JJ,JST)<-XUEPSI ) THEN + ! 1.2.1 CAS DENDRITIQUE/DENDRITIC CASE. + ! + ! / CALCUL NOUVELLE DENDRICITE ET SPHERICITE. + ZDENT = - PSNOWGRAN1(JJ,JST)/XVGRAN1 - ZVDENT1 * PTSTEP + ZSPHE = PSNOWGRAN2(JJ,JST)/XVGRAN1 + ZVDENT2 * PTSTEP + CALL SET_THRESH(ZGRADT,PSNOWLIQ(JJ,JST),ZSPHE) + IF( ZDENT<=XUEPSI ) THEN + ! EVOLUTION DE SGRAN1 ET SGRAN2 ET TEST PASSAGE DENDRITIQUE > NON DENDRITIQUE. + PSNOWGRAN1(JJ,JST) = ZSPHE * XVGRAN1 + PSNOWGRAN2(JJ,JST) = XVDIAM1 - XVDIAM5 * MIN( ZSPHE, ZVSPHE ) + ELSE + PSNOWGRAN1(JJ,JST) = -ZDENT * XVGRAN1 + PSNOWGRAN2(JJ,JST) = ZSPHE * XVGRAN1 + ENDIF + ! + ELSEIF ( GCOND_B92 ) THEN + ! 1.2.2 CAS NON DENDRITIQUE ET + ! NON COMPLETEMENT SPHERIQUE / NON DENDRITIC AND NOT COMPLETELY SPHERIC CASE + ! OU SPHERICITE NON LIMITEE + ! OU NON COMPLETEMENT ANGULEUX + ! + ! . EVOLUTION DE LA SPHERICITE SEULEMENT / EVOLUTION OF SPHERICITY ONLY (NOT SIZE) + ZSPHE = PSNOWGRAN1(JJ,JST)/XVGRAN1 + ZVDENT2 * PTSTEP + CALL SET_THRESH(ZGRADT,PSNOWLIQ(JJ,JST),ZSPHE) + PSNOWGRAN1(JJ,JST) = ZSPHE * XVGRAN1 + ! + ELSEIF ( PSNOWLIQ(JJ,JST)>XUEPSI ) THEN + ! 1.2.3 CAS NON DENDRITIQUE ET SPHERIQUE/NON DENDRITIC AND SPHERIC EN METAMORPHOSE HUMIDE + ! + ! EVOLUTION DE LA TAILLE SEULEMENT/EVOLUTION OF SIZE ONLY + CALL GET_GRAN(PTSTEP,ZTELM,PSNOWGRAN2(JJ,JST)) + ! + ELSEIF ( ZGRADT Wet snow + ! -> Evolution of optical diameter and sphericity + !------------------------------------------------ + ! + ! SPHERICITY + ZSPHE = PSNOWGRAN2(JJ,JST) + ZVDENT2 * PTSTEP + CALL SET_THRESH(ZGRADT,PSNOWLIQ(JJ,JST),ZSPHE) + IF ( PSNOWLIQ(JJ,JST)>XUEPSI .OR. ZGRADT XUEPSI ) + ENDIF + ! + IF ( GCOND_C13 .AND. PSNOWGRAN1(JJ,JST)XUEPSI ) THEN + ! 1.2.3 CAS NON DENDRITIQUE ET SPHERIQUE/NON DENDRITIC AND SPHERIC EN METAMORPHOSE HUMIDE + ! + ! NON DENDRITIC AND SPHERIC: EVOLUTION OF SIZE ONLY + CALL GET_GRAN(PTSTEP,ZTELM,PSNOWGRAN1(JJ,JST)) + ! + ELSEIF ( GCOND_C13 .AND. ZGRADT>=XVGRAT2 ) THEN + ! + ZDANGL = SNOW3L_MARBOUTY(PSNOWRHO(JJ,JST),PSNOWTEMP(JJ,JST),ZGRADT) + PSNOWGRAN1(JJ,JST) = PSNOWGRAN1(JJ,JST) + 0.5 * ZDANGL * XVFI * PTSTEP + ! + ENDIF + ! + PSNOWGRAN2(JJ,JST) = ZSPHE + ! + !--------------------------------- + ! TAILLANDIER et al. 2007 (T07) + ! + ! -> Dry snow + ! -> Evolution of optical diameter + !--------------------------------- + ! + IF ( PSNOWLIQ(JJ,JST)<=XUEPSI .AND. HSNOWMETAMO=='T07' ) THEN + ! + ! WRITE(*,*) CSNOWMETAMO,': you are using T07 formulation!!' + ! + ! Coefficients from Taillander et al. 2007 + ZSSA0 = 6./( XRHOLI*XVDIAM6 ) * 10. + ! + ZA = 0.659*ZSSA0 - 27.2 * ( PSNOWTEMP(JJ,JST)-273.15-2.03 ) ! TG conditions + ZB = 0.0961*ZSSA0 - 3.44 * ( PSNOWTEMP(JJ,JST)-273.15+1.90 ) + ZC = -0.341*ZSSA0 - 27.2 * ( PSNOWTEMP(JJ,JST)-273.15-2.03 ) + ZA2 = 0.629*ZSSA0 - 15.0 * ( PSNOWTEMP(JJ,JST)-273.15-11.2 ) ! ET conditions + ZB2 = 0.0760*ZSSA0 - 1.76 * ( PSNOWTEMP(JJ,JST)-273.15-2.96 ) + ZC2 = -0.371*ZSSA0 - 15.0 * ( PSNOWTEMP(JJ,JST)-273.15-11.2 ) + ! + ! Compute SSA (method from Jacobi, 2010) +! ZSSA = 6./(XRHOLI*PSNOWGRAN1(JJ,JST))*10. +! ZSSA_t = (0.5+0.5*TANH(0.5*(ZGRADT-10.)))*(ZA-ZB*LOG(PSNOWAGE(JJ,JST)*24+EXP(ZC/ZB))) + & +! (0.5-0.5*TANH(0.5*(ZGRADT-10.)))*(ZA2-ZB2*LOG(PSNOWAGE(JJ,JST)*24+EXP(ZC2/ZB2))) +! +! ZSSA_t_dt = (0.5+0.5*TANH(0.5*(ZGRADT-10.)))*(ZA-ZB*LOG(PSNOWAGE(JJ,JST)*24+PTSTEP/3600.+EXP(ZC/ZB))) + & +! (0.5-0.5*TANH(0.5*(ZGRADT-10.)))*(ZA2-ZB2*LOG(PSNOWAGE(JJ,JST)*24+PTSTEP/3600.+EXP(ZC2/ZB2))) +! +! ZSSA = ZSSA + (ZSSA_t_dt-ZSSA_t) +! +! ZSSA = MAX(ZSSA,8.*10.) +! +! PSNOWGRAN1(JJ,JST) = 6./(XRHOLI*ZSSA)*10. + ! + ! Compute SSA (rate equation with Taylor series) + ZSSA = 6./( XRHOLI*PSNOWGRAN1(JJ,JST) ) * 10. + ! + ZDENOM1 = (PSNOWAGE(JJ,JST)*24.) + EXP(ZC/ZB) + ZDENOM2 = (PSNOWAGE(JJ,JST)*24.) + EXP(ZC2/ZB2) + ZFACT1 = 0.5 + 0.5*TANH( 0.5*(ZGRADT-10.) ) + ZFACT2 = 0.5 - 0.5*TANH( 0.5*(ZGRADT-10.) ) + ZSSA = ZSSA + (PTSTEP/3600.) * ( ZFACT1 * (-ZB/ZDENOM1) + ZFACT2 * (-ZB2/ZDENOM2) + & + (PTSTEP/3600.) * ( ZFACT1 * (ZB/ZDENOM1**2.) + ZFACT2 * (ZB2/ZDENOM2**2.) ) * 1./2. ) + !ZSSA = ZSSA + (PTSTEP/3600.) * ( ZFACT1 * ZB /ZDENOM1 * ( 1./ZDENOM1 * (PTSTEP/3600.) * 1./2. - 1. ) + & + ! ZFACT2 * ZB2/ZDENOM2 * ( 1./ZDENOM2 * (PTSTEP/3600.) * 1./2. - 1. ) ) + ! + ZSSA = MAX( ZSSA, 8.*10. ) + ! + PSNOWGRAN1(JJ,JST) = 6./( XRHOLI*ZSSA ) * 10. + ! + !--------------------------------- + ! FLANNER et al. 2006 (F06) + ! + ! -> Dry snow + ! -> Evolution of optical diameter + !--------------------------------- + ELSEIF ( PSNOWLIQ(JJ,JST)<=XUEPSI .AND. HSNOWMETAMO=='F06' )THEN + ! + ! WRITE(*,*) CSNOWMETAMO,': you are using F06 formulation!!' + ! + ! XDRDT0(dens,gradT,T), XTAU(dens,gradT,T), XKAPPA(dens,gradT,T) + ! dens: [1-8 <-> 50.-400. kg/m3] + ! gradT: [1-31 <-> 0.-300. K/m] + ! T: [1-11 <-> 223.15-273.15 K] + ! + ! Select indices of density, temperature gradient and temperature + IDRHO = MIN( ABS( INT( (PSNOWRHO(JJ,JST)-25.)/50. ) + 1 ), 8 ) + IDGRAD = MIN( ABS( INT( (ZGRADT-5.)/10.+2. ) ), 31 ) + IDTEMP = MIN( ABS( INT( (PSNOWTEMP(JJ,JST)-225.65 )/5.+2. ) ), 11 ) + IF ( PSNOWTEMP(JJ,JST)<221. ) IDTEMP = 1 + ! + ! Compute SSA + ZOPTR0 = XVDIAM6/2. * 10.**6. + ZOPTR = PSNOWGRAN1(JJ,JST)/2. * 10.**6. + ZDRDT = XDRDT0(IDRHO,IDGRAD,IDTEMP) * & + ( XTAU(IDRHO,IDGRAD,IDTEMP) / & + ( ZOPTR - ZOPTR0 + XTAU(IDRHO,IDGRAD,IDTEMP) ) )**(1./XKAPPA(IDRHO,IDGRAD,IDTEMP)) + ZOPTR = ZOPTR + ZDRDT * PTSTEP/3600. + ZOPTR = MIN( ZOPTR, 3./(XRHOLI*2.) * 10.**6.) + ! + PSNOWGRAN1(JJ,JST) = ZOPTR * 2./10.**6. + ! + ENDIF + ! + ENDIF + ! + ENDDO + ! +ENDDO + +!* 2. MISE A JOUR VARIABLES HISTORIQUES (CAS NON DENDRITIQUE). +! UPDATE OF THE HISTORICAL VARIABLES +! -------------------------------------------------------- +DO JJ = 1,SIZE(PSNOWRHO,1) + ! + DO JST = 1,INLVLS_USE(JJ) + ! + IF ( HSNOWMETAMO=='B92' ) THEN + ! + !non dendritic + GNONDENDRITIC = ( PSNOWGRAN1(JJ,JST)>=0. ) + IF ( GNONDENDRITIC ) THEN + !faceted crystals + GFACETED = ( PSNOWGRAN1(JJ,JST)XVTELV1 ) + END IF + ! + ELSE + ! + !non dendritic + GNONDENDRITIC = ( PSNOWGRAN1(JJ,JST)>=XVDIAM6*(4.-PSNOWGRAN2(JJ,JST))-XUEPSI ) + IF ( GNONDENDRITIC ) THEN + !faceted crystals + GFACETED = ( PSNOWGRAN2(JJ,JST)XVTELV1 ) + END IF + ! + ENDIF + ! + IF ( GNONDENDRITIC ) THEN + ! + IF ( GFACETED ) THEN + ! + PSNOWHIST(JJ,JST) = NVHIS1 + ! + ELSEIF ( GSPHE_LW ) THEN + ! + IF (PSNOWHIST(JJ,JST)==0.) PSNOWHIST(JJ,JST) = NVHIS2 + IF (PSNOWHIST(JJ,JST)==NVHIS1) PSNOWHIST(JJ,JST) = NVHIS3 + ! + ELSEIF ( PSNOWTEMP(JJ,JST) < XTT ) THEN + ! + IF(PSNOWHIST(JJ,JST)==NVHIS2) PSNOWHIST(JJ,JST) = NVHIS4 + IF(PSNOWHIST(JJ,JST)==NVHIS3) PSNOWHIST(JJ,JST) = NVHIS5 + ! + ENDIF + ! + ENDIF + ! + ENDDO + ! +ENDDO +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROMETAMO',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROMETAMO +! +!#################################################################### +!#################################################################### +SUBROUTINE SET_THRESH(PGRADT,PSNOWLIQ,PSPHE) +! +USE MODD_SNOW_METAMO, ONLY : XUEPSI, XVGRAT1 +! +IMPLICIT NONE +! +REAL, INTENT(IN) :: PGRADT +REAL, INTENT(IN) :: PSNOWLIQ +REAL, INTENT(INOUT) :: PSPHE +! +IF ( PSNOWLIQ>XUEPSI .OR. PGRADT=10m and allow 0.8XTT .AND. PSNOWTEMP(:,1)>=XTT ) + PSNOWFLUX(:) = ZDTERM(:,1) * ( XTT-ZSNOWTEMP_M(:,1) ) + ZSNOWTEMP_DELTA(:) = 1.0 +END WHERE +! +DO JJ = 1,SIZE(PTG) + DO JST = 2,KNLVLS_USE(JJ) + ZSNOWTEMP(JJ,JST) = ZSNOWTEMP_DELTA(JJ) * ZSNOWTEMP_M(JJ,JST-1) + & + (1.0-ZSNOWTEMP_DELTA(JJ)) * ZSNOWTEMP (JJ,JST) + ENDDO +ENDDO +! +! 6. Lower boundary flux: +! ----------------------- +! NOTE: evaluate this term assuming the snow layer +! can't exceed the freezing point as this adjustment +! is made in melting routine. Then must adjust temperature +! to conserve energy: +! +DO JJ=1, SIZE(PTG) + ZGBAS(JJ) = ZDTERM(JJ,KNLVLS_USE(JJ)) * ( ZSNOWTEMP(JJ,KNLVLS_USE(JJ)) - PTG(JJ) ) + PGBAS(JJ) = ZDTERM(JJ,KNLVLS_USE(JJ)) * ( MIN( XTT, ZSNOWTEMP(JJ,KNLVLS_USE(JJ)) ) - PTG(JJ) ) + ZSNOWTEMP(JJ,KNLVLS_USE(JJ)) = ZSNOWTEMP(JJ,KNLVLS_USE(JJ)) + & + ( ZGBAS(JJ)-PGBAS(JJ) ) / ZCTERM(JJ,KNLVLS_USE(JJ)) + +ENDDO +! +! 7. Update temperatute profile in time: +! -------------------------------------- +! +DO JJ=1, SIZE(PTG) + PSNOWTEMP(JJ,1:KNLVLS_USE(JJ)) = ZSNOWTEMP(JJ,1:KNLVLS_USE(JJ)) +ENDDO +! +! +! 8. Compute new (implicit) air T and specific humidity +! ----------------------------------------------------- +! +PTA_IC(:) = PPET_B_COEF_T(:) + PPET_A_COEF_T(:) * PSNOWTEMP(:,1) +PQA_IC(:) = PPEQ_B_COEF_T(:) + PPEQ_A_COEF_T(:) * PSNOWTEMP(:,1) +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROSOLVT',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROSOLVT +!#################################################################### +!#################################################################### +!#################################################################### +SUBROUTINE SNOWCROMELT(PSCAP,PSNOWTEMP,PSNOWDZ, & + PSNOWRHO,PSNOWLIQ,KNLVLS_USE ) +! +!! PURPOSE +!! ------- +! Calculate snow melt (resulting from surface fluxes, ground fluxes, +! or internal shortwave radiation absorbtion). It is used to +! augment liquid water content, maintain temperatures +! at or below freezing, and possibly reduce the mass +! or compact the layer(s). +! +USE MODD_CSTS,ONLY : XTT, XLMTT, XRHOLW, XRHOLI +! +USE MODE_SNOW3L +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSCAP +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWDZ, PSNOWTEMP, PSNOWRHO, & + PSNOWLIQ +! +INTEGER, DIMENSION(:), INTENT(IN) :: KNLVLS_USE +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZPHASE, ZCMPRSFACT, & + ZSNOWLWE, & + ZSNOWMELT, ZSNOWTEMP +! +INTEGER :: JJ, JST ! looping indexes +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWCROMELT',0,ZHOOK_HANDLE) +! +! 0. Initialize: +! --------------------------- +! +DO JJ = 1,SIZE(PSNOWDZ,1) + DO JST = 1,KNLVLS_USE(JJ) + ZPHASE (JJ,JST) = 0.0 + ZCMPRSFACT(JJ,JST) = 0.0 + ZSNOWLWE (JJ,JST) = 0.0 + ZSNOWMELT (JJ,JST) = 0.0 + ZSNOWTEMP (JJ,JST) = 0.0 + ENDDO +ENDDO +! +! 1. Determine amount of melt in each layer: +! ------------------------------------------ +! +DO JJ = 1,SIZE(PSNOWDZ,1) + ! + DO JST = 1,KNLVLS_USE(JJ) + ! + ! Total Liquid equivalent water content of snow (m): + ZSNOWLWE(JJ,JST) = PSNOWRHO(JJ,JST) * PSNOWDZ(JJ,JST) / XRHOLW + ! + ! Melt snow if excess energy and snow available: + ! Phase change (J/m2) + ZPHASE(JJ,JST) = MIN( PSCAP(JJ,JST) * MAX(0.0,PSNOWTEMP(JJ,JST)-XTT) * PSNOWDZ(JJ,JST), & + MAX(0.0,ZSNOWLWE(JJ,JST)-PSNOWLIQ(JJ,JST)) * XLMTT * XRHOLW ) + ! + ! Update snow liq water content and temperature if melting: + ! liquid water available for next layer from melting of snow + ! which is assumed to be leaving the current layer (m): + ZSNOWMELT(JJ,JST) = ZPHASE(JJ,JST) / (XLMTT*XRHOLW) + ! + ! Cool off snow layer temperature due to melt: + ZSNOWTEMP(JJ,JST) = PSNOWTEMP(JJ,JST) - ZPHASE(JJ,JST) / (PSCAP(JJ,JST)*PSNOWDZ(JJ,JST)) + ! + ! Difference with ISBA_ES: ZMELTXS should never be different of 0. + ! because of the introduction of the tests in LLAYERGONE + PSNOWTEMP(JJ,JST) = ZSNOWTEMP(JJ,JST) + ! + ! The control below should be suppressed after further tests +#ifdef HYDRO_D + IF (PSNOWTEMP(JJ,JST)-XTT > XUEPSI) THEN + WRITE(*,*) 'pb dans MELT PSNOWTEMP(JJ,JST) >XTT:', JJ,JST, PSNOWTEMP(JJ,JST), XTT +! CALL ABOR1_SFX('SNOWCRO: pb dans MELT') + ENDIF +#endif + ! + ! Loss of snowpack depth: (m) and liquid equiv (m): + ! Compression factor for melt loss: this decreases + ! layer thickness and increases density thereby leaving + ! total SWE constant. + ! + ! Difference with ISBA_ES: All melt is considered to decrease the depth + ! without consideration to the irreducible content + ! + ZCMPRSFACT(JJ,JST) = ( ZSNOWLWE(JJ,JST) - (PSNOWLIQ(JJ,JST)+ZSNOWMELT(JJ,JST)) ) & + / ( ZSNOWLWE(JJ,JST) - PSNOWLIQ(JJ,JST) ) + PSNOWDZ (JJ,JST) = PSNOWDZ (JJ,JST) * ZCMPRSFACT(JJ,JST) + if ((PSNOWDZ(JJ,JST) .eq. 0) .and. (PSNOWRHO(JJ,JST).gt.0) .and. (PSNOWRHO(JJ,JST).ne.999)) then + PSNOWRHO(JJ,JST) = 0 + else + PSNOWRHO(JJ,JST) = ZSNOWLWE(JJ,JST) * XRHOLW / PSNOWDZ(JJ,JST) + endif + ! + ! 2. Add snow melt to current snow liquid water content: + ! ------------------------------------------------------ + ! + PSNOWLIQ(JJ,JST) = PSNOWLIQ(JJ,JST) + ZSNOWMELT(JJ,JST) + ! + ENDDO ! loop JST active snow layers +ENDDO ! loop JJ grid points +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROMELT',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROMELT +!#################################################################### +!#################################################################### +!#################################################################### +SUBROUTINE SNOWCROREFRZ(PTSTEP,PRR, & + PSNOWRHO,PSNOWTEMP,PSNOWDZ,PSNOWLIQ, & + PTHRUFAL, PSCAP, PLEL3L,KNLVLS_USE ) +! +!! PURPOSE +!! ------- +! Calculate any freezing/refreezing of liquid water in the snowpack. +! Also, calculate liquid water transmission and snow runoff. +! Refreezing causes densification of a layer. +! +USE MODD_CSTS, ONLY : XTT, XLMTT, XRHOLW, XCI,XRHOLI,XRHOTHRESHOLD_ICE +USE MODD_SNOW_PAR, ONLY : XSNOWDMIN + +! +USE MODE_SNOW3L +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! + +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PTSTEP +! +REAL, DIMENSION(:), INTENT(IN) :: PRR +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWDZ, PSNOWTEMP, PSNOWLIQ, PSNOWRHO +! +REAL, DIMENSION(:), INTENT(INOUT) :: PTHRUFAL +! +! modifs_EB layers +INTEGER, DIMENSION(:), INTENT(IN) :: KNLVLS_USE +REAL, DIMENSION(:,:), INTENT(IN) :: PSCAP +REAL, DIMENSION(:), INTENT(IN) :: PLEL3L +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZPHASE, & + ZSNOWLIQ, ZSNOWRHO, & + ZWHOLDMAX, ZSNOWDZ, & + ZSNOWTEMP +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),0:SIZE(PSNOWRHO,2)) :: ZFLOWLIQ +! +REAL :: ZDENOM, ZNUMER +! +INTEGER :: JJ, JST ! looping indexes +INTEGER :: INLVLS ! maximum snow layers number +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWCROREFRZ',0,ZHOOK_HANDLE) +! +! 0. Initialize: +! -------------- +! +INLVLS = SIZE(PSNOWDZ,2) +! +DO JJ=1,SIZE(PSNOWDZ,1) + DO JST=1,KNLVLS_USE(JJ) + ZSNOWRHO (JJ,JST) = PSNOWRHO(JJ,JST) + ZSNOWTEMP(JJ,JST) = PSNOWTEMP(JJ,JST) + ZWHOLDMAX(JJ,JST) = SNOWCROHOLD( PSNOWRHO(JJ,JST),PSNOWLIQ(JJ,JST),PSNOWDZ(JJ,JST) ) +! trude test with not allowing liquid if psnowrho > XRHOTHRESHOLD_ICE (i.e. no liquid in ice) +! IF (PSNOWRHO(JJ,JST).GT.XRHOTHRESHOLD_ICE) ZWHOLDMAX (JJ,JST)=0 +! end trude test + + ENDDO +ENDDO +! +DO JJ = 1,SIZE(PSNOWDZ,1) ! loop JJ grid points + ! + ! 1. Increases Liquid Water of top layer from rain + ! --------------------------------------------- + ! + ! Rainfall (m) initialises the liquid flow whih feeds the top layer + ! and evaporation/condensation are taken into account + ! + IF ( KNLVLS_USE(JJ)>0. ) THEN + ZFLOWLIQ(JJ,0) = PRR(JJ) * PTSTEP / XRHOLW + ZFLOWLIQ(JJ,0) = MAX(0., ZFLOWLIQ(JJ,0) - PLEL3L(JJ)*PTSTEP/(XLVTT*XRHOLW)) + ELSE + ZFLOWLIQ(JJ,0) = 0 + ENDIF + ! + DO JST=1,KNLVLS_USE(JJ) ! loop JST active snow layers + ! + ! 2. Increases Liquid Water from the upper layers flow (or rain for top layer) + ! ----------------------------- + PSNOWLIQ(JJ,JST) = PSNOWLIQ(JJ,JST) + ZFLOWLIQ(JJ,JST-1) + ! + ! 3. Freezes liquid water in any cold layers + ! --------------------------------------- + ! + ! Calculate the maximum possible refreezing + ZPHASE(JJ,JST) = MIN( PSCAP(JJ,JST)* MAX(0.0, XTT - ZSNOWTEMP(JJ,JST)) * PSNOWDZ(JJ,JST), & + PSNOWLIQ(JJ,JST) * XLMTT * XRHOLW ) + ! + ! Reduce liquid content if freezing occurs: + ZSNOWLIQ(JJ,JST) = PSNOWLIQ(JJ,JST) - ZPHASE(JJ,JST)/(XLMTT*XRHOLW) + ! + ! Warm layer and reduce liquid if freezing occurs: + ZSNOWDZ(JJ,JST) = MAX(XSNOWDMIN/INLVLS, PSNOWDZ(JJ,JST)) + ! + ! + ! Difference with ISBA-ES: a possible cooling of current refreezing water + ! is taken into account to calculate temperature change + ZNUMER = ( ZSNOWRHO(JJ,JST) * ZSNOWDZ(JJ,JST) - ( PSNOWLIQ(JJ,JST) - ZFLOWLIQ(JJ,JST-1) ) * XRHOLW ) + ZDENOM = ( ZSNOWRHO(JJ,JST) * ZSNOWDZ(JJ,JST) - ( ZSNOWLIQ(JJ,JST) - ZFLOWLIQ(JJ,JST-1) ) * XRHOLW ) + ! + PSNOWTEMP(JJ,JST) = XTT + ( ZSNOWTEMP(JJ,JST)-XTT )*ZNUMER/ZDENOM + ZPHASE(JJ,JST)/( XCI*ZDENOM ) + ! + ! 4. Calculate flow from the excess of holding capacity + ! -------------------------------------------------------------- + ! + ! Any water in excess of the maximum holding space for liquid water + ! amount is drained into next layer down. + ZFLOWLIQ(JJ,JST) = MAX( 0., ZSNOWLIQ(JJ,JST)-ZWHOLDMAX(JJ,JST) ) + ! + ZSNOWLIQ(JJ,JST) = ZSNOWLIQ(JJ,JST) - ZFLOWLIQ(JJ,JST) + ! + ! 5. Density is adjusted to conserve the mass + ! -------------------------------------------------------------- + ZNUMER = ( ZSNOWRHO(JJ,JST) * PSNOWDZ(JJ,JST) - ( ZFLOWLIQ(JJ,JST) - ZFLOWLIQ(JJ,JST-1) ) * XRHOLW ) + ! + ZSNOWRHO(JJ,JST) = ZNUMER / ZSNOWDZ(JJ,JST) + ! + ! keeps snow denisty below ice density + IF ( ZSNOWRHO(JJ,JST)>XRHOLI ) THEN + PSNOWDZ (JJ,JST) = PSNOWDZ(JJ,JST) * ZSNOWRHO(JJ,JST) / XRHOLI + ZSNOWRHO(JJ,JST) = XRHOLI + ENDIF + ! + ! 6. Update thickness and density and any freezing: + ! ---------------------------------------------- + PSNOWRHO(JJ,JST) = ZSNOWRHO(JJ,JST) + PSNOWLIQ(JJ,JST) = ZSNOWLIQ(JJ,JST) + ! + ENDDO ! loop JST active snow layers + ! + ! Any remaining throughflow after freezing is available to + ! the soil for infiltration or surface runoff (m). + ! I.E. This is the amount of water leaving the snowpack: + ! Rate water leaves the snowpack [kg/(m2 s)]: + ! + PTHRUFAL(JJ) = PTHRUFAL(JJ) + ZFLOWLIQ(JJ,KNLVLS_USE(JJ)) * XRHOLW / PTSTEP + ! +ENDDO ! loop JJ grid points +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROREFRZ',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROREFRZ +!#################################################################### +SUBROUTINE GET_RHO(PRHO_IN,PDZ,PSNOWLIQ,PFLOWLIQ,PRHO_OUT) +! +USE MODD_CSTS, ONLY : XRHOLW +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +REAL, INTENT(IN) :: PRHO_IN, PDZ, PSNOWLIQ,PFLOWLIQ +REAL, INTENT(OUT) :: PRHO_OUT +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_RHO',0,ZHOOK_HANDLE) +! +PRHO_OUT = ( PRHO_IN * PDZ - ( PSNOWLIQ - PFLOWLIQ ) * XRHOLW ) +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_RHO',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_RHO +!#################################################################### +!#################################################################### +SUBROUTINE SNOWCROFLUX(PSNOWTEMP,PSNOWDZ,PEXNS,PEXNA, & + PUSTAR2_IC, & + PTSTEP,PALBT,PSW_RAD,PEMIST,PLWUPSNOW, & + PLW_RAD,PTA,PSFCFRZ,PQA,PHPSNOW, & + PSNOWTEMPO1,PSNOWFLUX,PCT,PRADSINK, & + PQSAT,PDQSAT,PRSRA, & + PRN,PH,PGFLUX,PLES3L,PLEL3L,PEVAP, & + PUSTAR, & + PFSA_CROCUS, PFSR_CROCUS, PFIRA_CROCUS) ! trude added +! +!! PURPOSE +!! ------- +! Calculate the surface fluxes (atmospheric/surface). +! (Noilhan and Planton 1989; Noilhan and Mahfouf 1996) +! +USE MODD_CSTS,ONLY : XTT +! +USE MODE_THERMOS +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PTSTEP +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWDZ, PSNOWTEMPO1, PSNOWFLUX, PCT, & + PRADSINK, PEXNS, PEXNA +! +REAL, DIMENSION(:), INTENT(IN) :: PALBT, PSW_RAD, PEMIST, PLW_RAD, & + PTA, PSFCFRZ, PQA, & + PHPSNOW, PQSAT, PDQSAT, PRSRA, & + PUSTAR2_IC +! +REAL, DIMENSION(:), INTENT(INOUT) :: PSNOWTEMP +! +REAL, DIMENSION(:), INTENT(OUT) :: PRN, PH, PGFLUX, PLES3L, PLEL3L, & + PEVAP, PLWUPSNOW, PUSTAR +! trude added +REAL, DIMENSION(:), INTENT(OUT) :: PFSA_CROCUS, PFSR_CROCUS, PFIRA_CROCUS + +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWDZ)) :: ZEVAPC, ZSNOWTEMP +REAL :: ZSMSNOW, ZGFLUX +! +INTEGER :: JJ +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE + +! ---trude +!compile error : A dummy argument with an explicit INTENT(OUT) declaration is not given an explicit value. +! It seems that PLWUPSNOW does nothing. For now I give this array a value of 0 to be able to compile +PLWUPSNOW(:) = 0.0 +! --- + +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWCROFLUX',0,ZHOOK_HANDLE) +! +! 0. Initialize: +! -------------- +! +! 1. Flux calculations when melt not occuring at surface (W/m2): +! -------------------------------------------------------------- +! +DO JJ = 1,SIZE(PALBT) + ! + CALL GET_FLUX(PALBT(JJ),PEMIST(JJ),PSW_RAD(JJ),PLW_RAD(JJ), & + PEXNS(JJ),PEXNA(JJ),PTA(JJ),PQA(JJ),PRSRA(JJ), & + PQSAT(JJ),PDQSAT(JJ),PSFCFRZ(JJ),PHPSNOW(JJ), & + PSNOWTEMP(JJ),PSNOWTEMPO1(JJ), & + PRN(JJ),PH(JJ),ZEVAPC(JJ), & + PLES3L(JJ),PLEL3L(JJ),ZGFLUX, & + PFSA_CROCUS(JJ), PFSR_CROCUS(JJ), PFIRA_CROCUS(JJ)) ! trude added + ! + IF ( PSNOWTEMP(JJ)>XTT ) THEN + ! + IF ( PSNOWTEMPO1(JJ) 0 and passes freezing point this timestep, + ! then recalculate fluxes at freezing point and excess energy + ! will be used outside of this routine to change snow heat content: + ! + ! WRITE (*,*) 'attention test LFLUX traitement XTT supprime!' + ! + CALL GET_FLUX(PALBT(JJ),PEMIST(JJ),PSW_RAD(JJ),PLW_RAD(JJ), & + PEXNS(JJ),PEXNA(JJ), PTA(JJ),PQA(JJ),PRSRA(JJ), & + PQSAT(JJ),PDQSAT(JJ),PSFCFRZ(JJ),PHPSNOW(JJ), & + XTT,PSNOWTEMPO1(JJ), & + PRN(JJ),PH(JJ),ZEVAPC(JJ), & + PLES3L(JJ),PLEL3L(JJ),PGFLUX(JJ), & + PFSA_CROCUS(JJ), PFSR_CROCUS(JJ), PFIRA_CROCUS(JJ)) ! trude added + ! + ZSMSNOW = ZGFLUX - PGFLUX(JJ) + ! + ! This will be used to change heat content of snow: + ZSNOWTEMP(JJ) = PSNOWTEMP(JJ) - ZSMSNOW * PTSTEP * PCT(JJ) + ! + ELSE + ! + ! 3. Ongoing melt adjustment: explicit solution + ! --------------------------------------------- + ! If temperature change is 0 and at freezing point this timestep, + ! then recalculate fluxes and surface temperature *explicitly* + ! as this is *exact* for snow at freezing point (Brun, Martin) + ! + CALL GET_FLUX(PALBT(JJ),PEMIST(JJ),PSW_RAD(JJ),PLW_RAD(JJ), & + PEXNS(JJ),PEXNA(JJ), PTA(JJ),PQA(JJ),PRSRA(JJ), & + PQSAT(JJ),PDQSAT(JJ),PSFCFRZ(JJ),PHPSNOW(JJ), & + XTT,XTT, & + PRN(JJ),PH(JJ),ZEVAPC(JJ), & + PLES3L(JJ),PLEL3L(JJ),PGFLUX(JJ), & + PFSA_CROCUS(JJ), PFSR_CROCUS(JJ), PFIRA_CROCUS(JJ)) ! trude added + ! + ZSNOWTEMP(JJ) = XTT + PTSTEP * PCT(JJ) * ( PGFLUX(JJ) + PRADSINK(JJ) - PSNOWFLUX(JJ) ) + ! + ENDIF + ! + ELSE + ! + ZSNOWTEMP(JJ) = PSNOWTEMP(JJ) + ! + PGFLUX(JJ) = ZGFLUX + ! + ENDIF + ! +ENDDO +! +! 4. Update surface temperature: +! ------------------------------ +! +PSNOWTEMP(:) = ZSNOWTEMP(:) +! +! 5. Final evaporative flux (kg/m2/s) +! +PEVAP(:) = ZEVAPC(:) +! +! 5. Friction velocity +! -------------------- +! +PUSTAR(:) = SQRT(PUSTAR2_IC(:)) +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROFLUX',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROFLUX +!#################################################################### +SUBROUTINE GET_FLUX(PALBT,PEMIST,PSW_RAD,PLW_RAD,PEXNS,PEXNA, & + PTA,PQA,PRSRA,PQSAT,PDQSAT,PSFCFRZ,PHPSNOW, & + PSNOWTEMP,PSNOWTEMPO1, & + PRN,PH,PEVAPC,PLES3L,PLEL3L,PGFLUX, & + PFSA_CROCUS, PFSR_CROCUS, PFIRA_CROCUS) !trude added +! +USE MODD_CSTS,ONLY : XSTEFAN, XCPD, XLSTT, XLVTT +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +REAL, INTENT(IN) :: PALBT, PEMIST +REAL, INTENT(IN) :: PSW_RAD, PLW_RAD +REAL, INTENT(IN) :: PEXNS, PEXNA +REAL, INTENT(IN) :: PTA, PQA, PRSRA, PQSAT, PDQSAT, PSFCFRZ, PHPSNOW +REAL, INTENT(IN) :: PSNOWTEMP,PSNOWTEMPO1 +REAL, INTENT(OUT):: PRN, PH, PEVAPC, PLES3L, PLEL3L, PGFLUX +! Trude added: +REAL, INTENT(OUT):: PFSA_CROCUS, PFSR_CROCUS, PFIRA_CROCUS !trude added +! +REAL :: ZLE, ZDELTAT, ZLWUPSNOW, ZSNOWTO3 + +!REAL ::PSNOWTEMP,PSNOWTEMPO1 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_FLUX',0,ZHOOK_HANDLE) +! +!trude test +!PSNOWTEMPO1 = PSNOWTEMPO1_orig+5 +!PSNOWTEMP=PSNOWTEMP_orig+5 +! end test + +ZSNOWTO3 = PSNOWTEMPO1**3 ! to save some CPU time, store this +! +ZDELTAT = PSNOWTEMP - PSNOWTEMPO1 ! surface T time change: +! +ZLWUPSNOW = PEMIST * XSTEFAN * ZSNOWTO3 * ( PSNOWTEMPO1 + 4.*ZDELTAT ) +! +PRN = ( 1.-PALBT )*PSW_RAD + PEMIST*PLW_RAD - ZLWUPSNOW +! +PH = PRSRA * XCPD * ( PSNOWTEMP/PEXNS - PTA/PEXNA ) +! +PEVAPC = PRSRA * ( (PQSAT - PQA) + PDQSAT*ZDELTAT ) +! +PLES3L = PSFCFRZ * XLSTT * PEVAPC +! +PLEL3L = (1.-PSFCFRZ) * XLVTT * PEVAPC +! +ZLE = PLES3L + PLEL3L +! +PGFLUX = PRN - PH - ZLE + PHPSNOW + +PFSA_CROCUS= (1-PALBT)*PSW_RAD +PFSR_CROCUS = PALBT*PSW_RAD +PFIRA_CROCUS = ZLWUPSNOW - PEMIST*PLW_RAD + +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_FLUX',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_FLUX +! +!#################################################################### +!#################################################################### +SUBROUTINE SNOWCROEVAPN(PLES3L,PTSTEP,PSNOWTEMP,PSNOWRHO, & + PSNOWDZ,PEVAPCOR,PSNOWHMASS ) +! +!! PURPOSE +!! ------- +! Remove mass from uppermost snow layer in response to +! evaporation (liquid) and sublimation. +! +!! MODIFICATIONS +!! ------------- +!! Original A. Boone +!! 05/2011: E. Brun Takes only into account sublimation and solid +!! condensation. Evaporation and liquid condensation +!! are taken into account in SNOWCROREFRZ +! +USE MODD_CSTS, ONLY : XLSTT, XLMTT, XCI, XTT +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PTSTEP +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWTEMP +! +REAL, DIMENSION(:), INTENT(IN) :: PLES3L ! (W/m2) +! +REAL, DIMENSION(:), INTENT(INOUT) :: PSNOWRHO, PSNOWDZ, PSNOWHMASS, & + PEVAPCOR +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PLES3L)) :: ZSNOWEVAPS, ZSNOWEVAP, ZSNOWEVAPX, & + ZSNOWDZ, ZEVAPCOR +! ZEVAPCOR = for vanishingy thin snow cover, +! allow any excess evaporation +! to be extracted from the soil +! to maintain an accurate water +! balance [kg/(m2 s)] +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWCROEVAPN',0,ZHOOK_HANDLE) +! +! 0. Initialize: +! -------------- +! +ZEVAPCOR (:) = 0.0 +ZSNOWEVAPS(:) = 0.0 +ZSNOWEVAP (:) = 0.0 +ZSNOWEVAPX(:) = 0.0 +ZSNOWDZ (:) = 0.0 +! +!++ trude. Test for rare event where snow is present, but density is zero (thin snow layer ~1e-10m) +WHERE ( PSNOWRHO==0.0 ) + PSNOWDZ(:)=0.0 +END WHERE + +WHERE ( PSNOWDZ>0.0 ) + ! + ! 1. Sublimation/condensation of snow ice + ! ---------------------------------------- + ! Reduce layer thickness and total snow depth + ! if sublimation: add to correction term if potential + ! sublimation exceeds available snow cover. + ! + ZSNOWEVAPS(:) = PLES3L(:) * PTSTEP / ( XLSTT*PSNOWRHO(:) ) + ZSNOWDZ(:) = PSNOWDZ(:) - ZSNOWEVAPS(:) + PSNOWDZ(:) = MAX( 0.0, ZSNOWDZ(:) ) + ZEVAPCOR(:) = ZEVAPCOR(:) + MAX(0.0,-ZSNOWDZ(:)) * PSNOWRHO(:) / PTSTEP + ! + ! Total heat content change due to snowfall and sublimation (added here): + ! (for budget calculations): + ! + PSNOWHMASS(:) = PSNOWHMASS(:) & + - PLES3L(:) * (PTSTEP/XLSTT) * ( XCI * (PSNOWTEMP(:)-XTT) - XLMTT ) + ! +END WHERE +! +! 3. Update evaporation correction term: +! -------------------------------------- +! +PEVAPCOR(:) = PEVAPCOR(:) + ZEVAPCOR(:) +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROEVAPN',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE SNOWCROEVAPN +!#################################################################### +!#################################################################### +!#################################################################### +SUBROUTINE SNOWCROGONE(PTSTEP,PLEL3L,PLES3L,PSNOWRHO, & + PSNOWHEAT,PRADSINK_2D,PEVAPCOR,PTHRUFAL,PGRNDFLUX, & + PGFLUXSNOW,PSNOWDZ,PSNOWLIQ,PSNOWTEMP,PRADXS, & + PRR,KNLVLS_USE ) +! +!! PURPOSE +!! ------- +! Account for the case when the last trace of snow melts +! during a time step: ensure mass and heat balance of +! snow AND underlying surface. +! Original A. Boone +! 05/2011: E. Brun Takes into account sublimation and PGRNDFLUX +! Adds rain and evaporation/liquid condensation +! in PTHRUFAL +! +USE MODD_CSTS,ONLY : XTT, XLSTT, XLVTT +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PTSTEP +! +REAL, DIMENSION(:), INTENT(IN) :: PLEL3L, PLES3L, PGFLUXSNOW,PRR +! +REAL, DIMENSION(:,:), INTENT(IN) :: PRADSINK_2D +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWRHO, PSNOWHEAT +! +REAL, DIMENSION(:), INTENT(INOUT) :: PGRNDFLUX, PRADXS +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWDZ, PSNOWLIQ, PSNOWTEMP +! +REAL, DIMENSION(:), INTENT(OUT) :: PTHRUFAL ! melt water [kg/(m2 s)] +! +REAL, DIMENSION(:), INTENT(OUT) :: PEVAPCOR ! [kg/(m2 s)] +! PEVAPCOR = for vanishingy thin snow cover, +! allow any excess evaporation +! to be extracted from the soil +! to maintain an accurate water +! balance. +! +INTEGER, DIMENSION(:), INTENT(INOUT) :: KNLVLS_USE +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PLES3L)) :: ZRADSINK +REAL, DIMENSION(SIZE(PLES3L)) :: ZSNOWHEATC +INTEGER, DIMENSION(SIZE(PLES3L)) :: ISNOWGONE_DELTA +! +INTEGER :: JJ +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWCROGONE',0,ZHOOK_HANDLE) +! +! 0. Initialize: +! -------------- +! +PEVAPCOR(:) = 0.0 +PTHRUFAL(:) = 0.0 +! +DO JJ = 1,SIZE(ZRADSINK) + ZRADSINK (JJ) = PRADSINK_2D(JJ,INLVLS_USE(JJ)) + ZSNOWHEATC(JJ) = SUM(PSNOWHEAT(JJ,1:INLVLS_USE(JJ))) !total heat content (J m-2) +END DO +! +ISNOWGONE_DELTA(:) = 1 +! +! 1. Simple test to see if snow vanishes: +! --------------------------------------- +! If so, set thicknesses (and therefore mass and heat) and liquid content +! to zero, and adjust fluxes of water, evaporation and heat into underlying +! surface. +! +! takes into account the heat content corresponding to the occasional +! sublimation and then PGRNDFLUX +! +ZSNOWHEATC(:) = ZSNOWHEATC(:) + MAX( 0., PLES3L(:)*PTSTEP/XLSTT ) * XLMTT +! +WHERE ( PGFLUXSNOW(:)+ZRADSINK(:)-PGRNDFLUX(:) >= (-ZSNOWHEATC(:)/PTSTEP) ) + PGRNDFLUX(:) = PGFLUXSNOW(:) + (ZSNOWHEATC(:)/PTSTEP) + PEVAPCOR (:) = PLES3L(:)/XLSTT + PRADXS (:) = 0.0 + ISNOWGONE_DELTA(:) = 0 ! FLAG...if=0 then snow vanishes, else=1 +END WHERE +! +! 2. Final update of snow state and computation of corresponding flow +! Only if snow vanishes +! ----------------------------- +! +PTHRUFAL(:) = 0. +! +DO JJ=1, SIZE(ZRADSINK) + ! + IF(ISNOWGONE_DELTA(JJ) == 0 ) THEN + PTHRUFAL(JJ) = PTHRUFAL(JJ) + & + SUM( PSNOWRHO(JJ,1:INLVLS_USE(JJ))*PSNOWDZ(JJ,1:INLVLS_USE(JJ)) ) / PTSTEP +! takes into account rain and condensation/evaporation + PTHRUFAL(JJ) = PTHRUFAL(JJ) + PRR(JJ) - PLEL3L(JJ)/XLVTT + PSNOWTEMP(JJ,:) = XTT + PSNOWDZ (JJ,:) = 0. + PSNOWLIQ (JJ,:) = 0. + INLVLS_USE(JJ) = 0 + ENDIF + ! +ENDDO +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROGONE',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROGONE +!#################################################################### +!#################################################################### +!#################################################################### +SUBROUTINE SNOWCROEVAPGONE(PSNOWHEAT,PSNOWDZ,PSNOWRHO,PSNOWTEMP,PSNOWLIQ, & + PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST,PSNOWAGE,KNLVLS_USE,& + HSNOWMETAMO) +! +!! PURPOSE +!! ------- +! +! If all snow in uppermost layer evaporates/sublimates, re-distribute +! grid (below assumes very thin snowpacks so layer-thicknesses are +! constant). +! Original A. Boone +! 05/2011: E. Brun Takes into account previous changes in the energy +! content +! +! +USE MODD_CSTS, ONLY : XTT, XRHOLW, XLMTT, XCI +USE MODD_SNOW_PAR, ONLY : XRHOSMIN_ES, XSNOWDMIN, XRHOSMAX_ES +USE MODE_SNOW3L +USE MODD_SNOW_METAMO +!USE MODD_TYPE_DATE_SURF +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWRHO ! snow density profile (kg/m3) +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWDZ ! snow layer thickness profile (m) +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWHEAT ! snow heat content/enthalpy (J/m2) +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWGRAN1 ! snow grain parameter 1 (-) +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWGRAN2 ! snow grain parameter 2 (-) +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWHIST ! snow grain historical variable (-) +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWAGE ! Snow grain age +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWTEMP ! snow temperature profile (K) +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWLIQ ! snow liquid water profile (m) +! +INTEGER, DIMENSION(:), INTENT(IN) :: KNLVLS_USE + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO ! metamorphism scheme +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWDZ,1)) :: ZSNOWHEAT_1D ! total heat content (J/m2) +REAL, DIMENSION(SIZE(PSNOWDZ,1)) :: ZSNOWRHO_1D ! total snowpack average density (kg/m3) +REAL, DIMENSION(SIZE(PSNOWDZ,1)) :: ZSNOW ! total snow depth (m) +REAL, DIMENSION(SIZE(PSNOWDZ,1)) :: ZSCAP ! Snow layer heat capacity (J/K/m3) +REAL, DIMENSION(SIZE(PSNOWDZ,1)) :: ZNDENT ! Number of dendritic layers (-) +REAL, DIMENSION(SIZE(PSNOWDZ,1)) :: ZNVIEU ! Number of non dendritic layers (-) +REAL, DIMENSION(SIZE(PSNOWDZ,1)) :: ZSNOWAGE_1D ! total snowpack average +!age (days) +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZSNOWGRAN1N, & + ZSNOWGRAN2N,ZSNOWHISTN +! +LOGICAL :: GDENDRITIC +! +INTEGER :: JJ, JST ! loop control +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWCROEVAPGONE',0,ZHOOK_HANDLE) +! +! Initialize: +! +ZSNOWHEAT_1D(:) = 0. +ZSNOW(:) = 0. +ZSNOWRHO_1D(:) = 0. +ZNDENT(:) = 0. +ZNVIEU(:) = 0. +ZSNOWAGE_1D(:) = 0. +ZSCAP(:) = 0. +! +! First, determine where uppermost snow layer has completely +! evaporated/sublimated (as it becomes thin): +DO JJ = 1,SIZE(PSNOWRHO,1) + ! + IF ( PSNOWDZ(JJ,1)==0.0 ) THEN + ! + DO JST = 2,KNLVLS_USE(JJ) + ! + ZSNOWHEAT_1D(JJ) = ZSNOWHEAT_1D(JJ) + PSNOWDZ(JJ,JST) * & + ( PSNOWRHO(JJ,JST)*XCI * (ZSNOWTEMP(JJ,JST)-XTT) & + - XLMTT * PSNOWRHO(JJ,JST) ) & + + XLMTT * XRHOLW * PSNOWLIQ(JJ,JST) + ZSNOW (JJ) = ZSNOW (JJ) + PSNOWDZ(JJ,JST) + ZSNOWRHO_1D (JJ) = ZSNOWRHO_1D (JJ) + PSNOWDZ(JJ,JST) * PSNOWRHO(JJ,JST) + ZSNOWAGE_1D (JJ) = ZSNOWAGE_1D (JJ) + PSNOWDZ(JJ,JST) * PSNOWRHO(JJ,JST) * PSNOWAGE(JJ,JST) + ! + ! snow grains + IF ( HSNOWMETAMO=='B92' ) THEN + GDENDRITIC = ( PSNOWGRAN1(JJ,JST)<-XEPSI ) + ELSE + GDENDRITIC = ( PSNOWGRAN1(JJ,JST)=10m and allow 0.8 INB_MIN_LAYERS => +! KNLVLS_USE(JJ) > 2 + INLVLSMAX/3 => +! ( KNLVLS_USE(JJ) + INLVLSMAX ) / 6 > (2 + INLVLSMAX/3 + INLVLSMAX) / 6 => +! INB_DEEP_LAYER > (2 + 4*INLVLSMAX/3 ) / 6 >= 1 +INB_MIN_LAYERS = 2 + INLVLSMAX/3 +! + DO JJ = 1,SIZE(PSNOW(:)) + ! + IF ( PSNOW(JJ)>XDEPTH_THRESHOLD2 .AND. KNLVLS_USE(JJ)>INB_MIN_LAYERS ) THEN + ! for very thick snowpack with enough snow layers + ! special treatment + ! we put the highest thickness in the lowest layers + ! about 1/3 of layers for all snow except XDEPTH_SURFACE=3 first meters + ! + !number of "deep layers" + INB_DEEP_LAYER = ( KNLVLS_USE(JJ) + INLVLSMAX ) / 6 + ! + !number of "upper layers" + INB_UPPER_LAYER = KNLVLS_USE(JJ) - INB_DEEP_LAYER + ! + !thickness of "upper layers" + ZSNOW_UPPER = XDEPTH_SURFACE + ! + !Arithmetic serie : 1+2+3+...+INB_DEEP_LAYER=INB_DEEP_LAYER*(INB_DEEP_LAYER+1)/2 + ZCOEF_DEPTH = ( PSNOW(JJ) - XDEPTH_SURFACE ) * 2. / ( (INB_DEEP_LAYER+1) * INB_DEEP_LAYER ) + ! + ! deep layers optimal thickness : + ! increasing thickness with depth + DO JSTDEEP = 1,INB_DEEP_LAYER + JST = INB_UPPER_LAYER + JSTDEEP + ZDZOPT(JJ,JST) = ZCOEF_DEPTH * JSTDEEP + !This sum is equal to PSNOW(JJ)-XDEPTH_SURFACE + ENDDO + ! + ELSE + ! + INB_UPPER_LAYER = KNLVLS_USE(JJ) + ! + ZSNOW_UPPER = PSNOW(JJ) + ! + END IF + ! + !on force le ZDZOPT des 3 premières couches à ZSNOW_UPPER/3 maximum, chacune. + ! => si on n'a qu'une couche, ZDZOPT(1) = ZSNOW_UPPER/3 + ! quel que soit INB_UPPER_LAYER + ! + ZSNOW_UPPER2 = ZSNOW_UPPER / MAX( INLVLSMIN, INB_UPPER_LAYER ) + ! + ZDZOPT(JJ,1) = MIN( XDZ1, ZSNOW_UPPER2 ) + IF ( KNLVLS_USE(JJ)>=2 ) ZDZOPT(JJ,2) = MIN( XDZ2, ZSNOW_UPPER2 ) + IF ( KNLVLS_USE(JJ)>=3 ) ZDZOPT(JJ,3) = MIN( XDZ3, ZSNOW_UPPER2 ) + ! + IF ( INB_UPPER_LAYER>0 ) THEN + ! + ZSNOW_UPPER2 = ZSNOW_UPPER / INB_UPPER_LAYER + ! + ! dans ce cas, à partir de la 3ème couche, on prend la fraction du nombre de + ! couches supérieures total, pour les couches jusqu'à 5 + ! + !ML : replace > by >= on 12-12-20 because the last layer was not initialised in case of thick snowpacks + IF ( INB_UPPER_LAYER>=3 ) ZDZOPT(JJ,3) = MIN( XDZ3_BIS, ZSNOW_UPPER2 ) + IF ( INB_UPPER_LAYER>=4 ) ZDZOPT(JJ,4) = MIN( XDZ4 , ZSNOW_UPPER2 ) + IF ( INB_UPPER_LAYER>=5 ) ZDZOPT(JJ,5) = MIN( XDZ5 , ZSNOW_UPPER2 ) + ! + IF ( INB_UPPER_LAYER==KNLVLS_USE(JJ) ) THEN + ! si on n'a pas de couches profondes + ! + ! dans ce cas, on reprend ZSNOW_UPPER/3 maximum pour la dernière couche + ! + ! last layer of' upper layers' : normal case : thin layer + ZDZOPT(JJ,INB_UPPER_LAYER) = MIN( XDZ_BASE, ZSNOW_UPPER/MAX(INLVLSMIN,INB_UPPER_LAYER) ) + ! + ! ZTHICKNESS_INTERMEDIATE contient ce qu'il reste d'épaisseur disponible + ! dans les couches supérieures + !remaining snow for remaining layers + ZTHICKNESS_INTERMEDIATE = ZSNOW_UPPER - SUM(ZDZOPT(JJ,1:5)) - ZDZOPT(JJ,INB_UPPER_LAYER) + + IF ( ZSNOW_UPPER<=XDEPTH_THRESHOLD1 .OR. INB_UPPER_LAYER<8 ) THEN + INB_INTERMEDIATE = INB_UPPER_LAYER - 6 + IEND_INTERMEDIATE = INB_UPPER_LAYER - 1 + ELSE + ! si INB_UPPER_LAYER>=8, les avant et avant-dernière couches ne sont pas + ! considérées commes intermédiaires + INB_INTERMEDIATE = INB_UPPER_LAYER - 8 + IEND_INTERMEDIATE = INB_UPPER_LAYER - 3 + ! dans ce cas, on garde un peu d'épaisseur pour les deux couches restantes + IF ( INB_INTERMEDIATE>0 ) THEN + ZTHICKNESS_INTERMEDIATE = ZTHICKNESS_INTERMEDIATE * INB_INTERMEDIATE / FLOAT(INB_INTERMEDIATE+1) + END IF + END IF + ! + ELSE + ! si on a des couches profondes, les couches intermédiaires sont celles + ! qui restent quand on a enlevé les 5 premières des couches supérieures + ! + ! case with very thick snowpacks : + ! the last layer of upper layers is not an exception + ZTHICKNESS_INTERMEDIATE = ZSNOW_UPPER - SUM(ZDZOPT(JJ,1:5)) + INB_INTERMEDIATE = INB_UPPER_LAYER - 5 + IEND_INTERMEDIATE = INB_UPPER_LAYER + ! + END IF + ! + ! For thick snowpack : add maximum value of optimal thickness to avoid too + ! large differencies between layers + IF ( INB_INTERMEDIATE>0 ) THEN + ! + ZTHICKNESS2 = MAX( XDZ_INTERNAL, ZTHICKNESS_INTERMEDIATE/INB_INTERMEDIATE ) + ! + JSTEND = MIN( IEND_INTERMEDIATE,10 ) + DO JST = 6,JSTEND + ZDZOPT(JJ,JST) = MIN( XDZMAX_INTERNAL(JST-5), ZTHICKNESS2 ) + END DO + ! + IF ( IEND_INTERMEDIATE>10 ) THEN + DO JST = 11,IEND_INTERMEDIATE + ZDZOPT(JJ,JST) = ZTHICKNESS2 + END DO + END IF + ! + END IF + ! + IF ( ZSNOW_UPPER>=XDEPTH_THRESHOLD1 .AND. INB_UPPER_LAYER>=8 ) THEN + !Linear interpolation of optimal thickness between layers N-3 and N : + ZDZOPT(JJ,INB_UPPER_LAYER-2) = 0.34*ZDZOPT(JJ,INB_UPPER_LAYER) + & + 0.66*ZDZOPT(JJ,INB_UPPER_LAYER-3) + ZDZOPT(JJ,INB_UPPER_LAYER-1) = 0.66*ZDZOPT(JJ,INB_UPPER_LAYER) + & + 0.34*ZDZOPT(JJ,INB_UPPER_LAYER-3) + ENDIF + ! + END IF + ! +END DO +! +!************************************************************************************ +!This was the initial code for optimal layers until may 2012 +! +! ! ! ! ! +! ! ! ! ! !* 1.1 Calculation of the optimal vertical grid size +! ! ! ! ! ! as a function of maximum number of layers and of current +! ! ! ! ! ! snow depth +! ! ! ! ! ! +! ! ! ! ! DO JJ=1, SIZE(PSNOW(:)) +! ! ! ! ! ZDZOPT(JJ,1) = MIN(XDZ1,PSNOW(JJ)/MAX(INLVLSMIN,KNLVLS_USE(JJ))) +! ! ! ! ! ZDZOPT(JJ,2) = MIN(XDZ2,PSNOW(JJ)/MAX(INLVLSMIN,KNLVLS_USE(JJ))) +! ! ! ! ! ZDZOPT(JJ,3) = MIN(XDZ3,PSNOW(JJ)/MAX(INLVLSMIN,KNLVLS_USE(JJ))) +! ! ! ! ! IF (KNLVLS_USE(JJ)>3) ZDZOPT(JJ,3) = MIN(XDZ3_BIS,PSNOW(JJ)/KNLVLS_USE(JJ)) +! ! ! ! ! IF (KNLVLS_USE(JJ)>4) ZDZOPT(JJ,4) = MIN(XDZ4,PSNOW(JJ)/KNLVLS_USE(JJ)) +! ! ! ! ! IF (KNLVLS_USE(JJ)>5) ZDZOPT(JJ,5) = MIN(XDZ5,PSNOW(JJ)/KNLVLS_USE(JJ)) +! ! ! ! ! IF (KNLVLS_USE(JJ)>0) ZDZOPT(JJ,KNLVLS_USE(JJ))= & +! ! ! ! ! MIN(XDZ_BASE,PSNOW(JJ)/MAX(INLVLSMIN,KNLVLS_USE(JJ))) +! ! ! ! ! DO JST=6,KNLVLS_USE(JJ)-1,1 +! ! ! ! ! ZDZOPT(JJ,JST) = MAX(XDZ_INTERNAL,(PSNOW(JJ) - SUM(ZDZOPT(JJ,1:5))- & +! ! ! ! ! ZDZOPT(JJ,KNLVLS_USE(JJ))) /(KNLVLS_USE(JJ)-6)) +! ! ! ! ! END DO +! ! ! ! ! END DO +! ! ! ! ! ! +! ! ! ! ! +! +!************************************************************************************ +! +!* 2.0 Fresh snow characteristics +! +! +! +! Heat content of newly fallen snow (J/m2): +! NOTE for now we assume the snowfall has +! the temperature of the snow surface upon reaching the snow. +! This is done as opposed to using the air temperature since +! this flux is quite small and has little to no impact +! on the time scales of interest. If we use the above assumption +! then, then the snowfall advective heat flux is zero. +!! +DO JJ = 1,SIZE(PSNOW(:)) + ! + IF ( PSR(JJ)>0.0 ) THEN + ! + ! newly fallen snow characteristics: + IF ( KNLVLS_USE(JJ)>0 ) THEN !Case of new snowfall on a previously snow-free surface + ZSCAP (JJ) = XCI*PSNOWRHO(JJ,1) + ZSNOWTEMP(JJ) = XTT + ( PSNOWHEAT(JJ,1) + XLMTT*PSNOWRHO(JJ,1)*PSNOWDZ(JJ,1) ) / & + ( ZSCAP(JJ) * MAX( XSNOWDMIN/INLVLS, PSNOWDZ(JJ,1) ) ) + ELSE ! case with bare ground + ZSNOWTEMP(JJ) = PTA(JJ) + ENDIF + ZSNOWTEMP(JJ) = MIN( XTT, ZSNOWTEMP(JJ) ) + ! + ! + ! Wind speeds at reference heights for new snow density and charactristics of + ! grains of new snow + ! Computed from PVMOD at PUREF (m) assuming a log profile in the SBL + ! and a roughness length equal to PZ0EFF + ! + ZZ0EFF=MIN(PZ0EFF(JJ),PUREF(JJ)*0.5,PPHREF_WIND_MIN) + + ZWIND_RHO(JJ) = PVMOD(JJ)*LOG(PPHREF_WIND_RHO/ZZ0EFF)/ & + LOG(PUREF(JJ)/ZZ0EFF) + ZWIND_GRAIN(JJ) = PVMOD(JJ)*LOG(PPHREF_WIND_GRAIN/ZZ0EFF)/ & + LOG(PUREF(JJ)/ZZ0EFF) + + PSNOWHMASS(JJ) = PSR(JJ) * ( XCI * ( ZSNOWTEMP(JJ)-XTT ) - XLMTT ) * PTSTEP + ! + PSNOWRHOF (JJ) = MAX( XRHOSMIN_ES, XSNOWFALL_A_SN + & + XSNOWFALL_B_SN * ( PTA(JJ)-XTT ) + & + XSNOWFALL_C_SN * MIN( PVMOD(JJ), SQRT(ZWIND_RHO(JJ) ) ) ) + ZSNOWFALL (JJ) = PSR(JJ) * PTSTEP / PSNOWRHOF(JJ) ! snowfall thickness (m) + PSNOW (JJ) = PSNOW(JJ) + ZSNOWFALL(JJ) + PSNOWDZF (JJ) = ZSNOWFALL(JJ) + ! + IF ( HSNOWMETAMO=='B92' ) THEN + ! + IF ( OSNOWDRIFT ) THEN + PSNOWGRAN1F(JJ) = -XGRAN + PSNOWGRAN2F(JJ) = XNSPH3 + ELSE + PSNOWGRAN1F(JJ) = MAX( MIN( XNDEN1*ZWIND_GRAIN(JJ)-XNDEN2, XNDEN3 ), -XGRAN ) + PSNOWGRAN2F(JJ) = MIN( MAX( XNSPH1*ZWIND_GRAIN(JJ)+XNSPH2, XNSPH3 ), XNSPH4 ) + END IF + ! + ELSE + ! + IF ( OSNOWDRIFT ) THEN + PSNOWGRAN1F(JJ) = XVDIAM6 + PSNOWGRAN2F(JJ) = XNSPH3/XGRAN + ELSE + PSNOWGRAN2F(JJ) = MIN( MAX( XNSPH1*ZWIND_GRAIN(JJ)+XNSPH2, XNSPH3 ), XNSPH4 ) / XGRAN + ZCOEF = MAX( MIN( XNDEN1*ZWIND_GRAIN(JJ)-XNDEN2, XNDEN3 ), -XGRAN ) / ( -XGRAN ) + PSNOWGRAN1F(JJ) = XVDIAM6 * & + ( ZCOEF + ( 1.- ZCOEF ) * & + ( 3.*PSNOWGRAN2F(JJ) + 4.*(1.-PSNOWGRAN2F(JJ)) ) ) + END IF + ! + ENDIF + ! + PSNOWHISTF (JJ) = 0.0 + PSNOWAGEF (JJ) = 0.0 + GSNOWFALL (JJ) = .TRUE. + OMODIF_GRID(JJ) = .TRUE. + ! + ENDIF + ! +ENDDO +! +! intialize the albedo: +! penser a changer 0.000001 par XUEPSI +IF(OGLACIER)THEN + ZANSMAX(:) = XAGLAMAX * PPERMSNOWFRAC(:) + XANSMAX * (1.0-PPERMSNOWFRAC(:)) +ELSE + ZANSMAX(:) = XANSMAX +ENDIF +! +WHERE( GSNOWFALL(:) .AND. ABS(PSNOW(:)-ZSNOWFALL(:))< 0.000001 ) + PSNOWALB(:) = ZANSMAX(:) +END WHERE + +! +! Computation of the new grid size +! It starts with successive exclusive cases +! Each case is described inside the corresponding condition +! +! cases with fresh snow +! + +DO JJ=1,SIZE(PSNOW(:)) ! grid point loop + ! + IF( .NOT.GSNOWFALL(JJ) .AND. PSNOW(JJ)>=XSNOWCRITD .AND. KNLVLS_USE(JJ)>=INLVLSMIN ) THEN + ! + ! no fresh snow + deep enough snowpack + enough snow layers ==> no change + ! + ELSEIF( PSNOW(JJ) uniform grid and identical snow layers / number depends on snow depth + OMODIF_GRID(JJ) = .TRUE. + KNLVLS_USE (JJ) = MAX( INLVLSMIN, MIN( INLVLSMAX, INT(PSNOW(JJ)*XSCALE_CM) ) ) + PSNOWDZN(JJ,1:KNLVLS_USE(JJ)) = PSNOW(JJ) / KNLVLS_USE(JJ) + ! + ELSE + ! + ! fresh snow over snow covered ground + enough snow layers + OMODIF_GRID(JJ) = .TRUE. + ZDIFTYPE_SUP = SNOW3LDIFTYP( PSNOWGRAN1(JJ,1),PSNOWGRAN1F(JJ), & + PSNOWGRAN2(JJ,1),PSNOWGRAN2F(JJ),HSNOWMETAMO ) + ! + IF ( ( ZDIFTYPE_SUP fresh snow is agregated to the surface layer + PSNOWDZN(JJ,1) = PSNOWDZ(JJ,1) + PSNOWDZF(JJ) + DO JST = KNLVLS_USE(JJ),2,-1 + PSNOWDZN(JJ,JST) = PSNOWDZ(JJ,JST) + ENDDO + ! + ELSEIF ( KNLVLS_USE(JJ) we create a new layer + KNLVLS_USE(JJ)=KNLVLS_USE(JJ)+1 + ! + IF ( PSNOWDZF(JJ)>XRATIO_NEWLAYER*PSNOWDZ(JJ,2) ) THEN + ! + ! Snowfall is sufficient to create a new layer not lower than 1/10 of the second layer + PSNOWDZN(JJ,1) = PSNOWDZF(JJ) + DO JST = KNLVLS_USE(JJ),2,-1 + PSNOWDZN(JJ, JST) = PSNOWDZ(JJ,JST-1) + ENDDO + ! + ELSE + ! The ratio would be lower than 1/10 : [NEW : 11/2012] + ! aggregate a part of the old layer with fresh snow to limit the ratio to 1/10. + ZSNOW2L = PSNOWDZF(JJ) + PSNOWDZ(JJ,1) + PSNOWDZN(JJ,1) = XRATIO_NEWLAYER * ZSNOW2L + PSNOWDZN(JJ,2) = (1.-XRATIO_NEWLAYER) * ZSNOW2L + DO JST = KNLVLS_USE(JJ),3,-1 + PSNOWDZN(JJ,JST) = PSNOWDZ(JJ,JST-1) + ENDDO + ! + ENDIF + ! + ELSE + ! + ! fresh snow is too different from the surface or the surface is too deep + ! and there is no room for extra layers + ! ==> we agregate internal most similar snowlayers and create a new surface layer + JJ_A_AGREG_SUP = 1 + JJ_A_AGREG_INF = 2 + ! + DO JST = 1,KNLVLS_USE(JJ) + ! + IF ( JST>1 ) THEN + ! + ZCRITSIZE_SUP = XSCALE_DIFF * ( PSNOWDZ(JJ,JST) /ZDZOPT(JJ,JST) + & + PSNOWDZ(JJ,JST-1)/ZDZOPT(JJ,JST-1) ) + ZDIFTYPE_SUP = SNOW3LDIFTYP( PSNOWGRAN1(JJ,JST-1),PSNOWGRAN1(JJ,JST), & + PSNOWGRAN2(JJ,JST-1),PSNOWGRAN2(JJ,JST), & + HSNOWMETAMO ) + ! + IF ( ZDIFTYPE_SUP+ZCRITSIZE_SUP INLVLSMIN +! +DO JJ=1,SIZE(PSNOW(:)) + ! + ! check if surface layer depth is too small + ! in such a case agregation with layer beneath + ! in case of reaching INLVLSMIN, looks for an other layer to be splitted + IF( .NOT.GSNOWFALL(JJ) .AND. PSNOW(JJ)>XSNOWCRITD .AND. & + .NOT.OMODIF_GRID(JJ) .AND. PSNOWDZ(JJ,1)INLVLSMIN ) THEN ! case minimum not reached + KNLVLS_USE(JJ) = KNLVLS_USE(JJ) - 1 + PSNOWDZN(JJ,1) = PSNOWDZ(JJ,1) + PSNOWDZ(JJ,2) + DO JST = 2,KNLVLS_USE(JJ) + PSNOWDZN(JJ,JST) = PSNOWDZ(JJ,JST+1) + ENDDO + ELSE ! case minimum reached + CALL GET_SNOWDZN_DEB(KNLVLS_USE(JJ),PSNOWDZ(JJ,:),ZDZOPT(JJ,:),PSNOWDZN(JJ,:)) + ENDIF ! end case minimum reached end case shallow surface layer + ! + GAGREG_SURF(JJ) = .TRUE. + ! + ENDIF + ! + ! check if bottom layer depth is too small + ! in such a case agregation with above layer + ! in case of reaching INLVLSMIN, looks for an other layer to be splitted + ! case shallow bottom layer + + IF( .NOT.GSNOWFALL(JJ) .AND. PSNOW(JJ)> XSNOWCRITD .AND. & + .NOT.OMODIF_GRID(JJ) .AND. PSNOWDZ(JJ,KNLVLS_USE(JJ))INLVLSMIN ) THEN ! case minimum not reached + KNLVLS_USE(JJ) = KNLVLS_USE(JJ) - 1 + PSNOWDZN(JJ,KNLVLS_USE(JJ)) = PSNOWDZ(JJ,KNLVLS_USE(JJ)) + PSNOWDZ(JJ,KNLVLS_USE(JJ)+1) + ELSE ! case minimum reached + CALL GET_SNOWDZN_END(KNLVLS_USE(JJ),PSNOWDZ(JJ,:),ZDZOPT(JJ,:),PSNOWDZN(JJ,:)) + ENDIF ! end case minimum reached end case shallow surface layer + ! + ENDIF + ! +ENDDO ! end grid points loop +! +! case whithout new snow fall and without a previous grid resize +! looks for a shallow layer to be splitted according to its depth and to +! the optimal grid size +DO JJ = 1,SIZE(PSNOW(:)) + ! + IF ( .NOT.OMODIF_GRID(JJ) .AND. INLVLS_USE(JJ) & + ( XSPLIT_COEF - FLOAT( INLVLS-KNLVLS_USE(JJ) )/MAX( 1., FLOAT( INLVLS-INLVLSMIN ) ) ) & + * ZDZOPT(JJ,JST) ) THEN + ! + DO JST_1 = KNLVLS_USE(JJ)+1,JST+2,-1 + PSNOWDZN(JJ,JST_1) = PSNOWDZ(JJ,JST_1-1) + ZDZOPT (JJ,JST_1) = ZDZOPT (JJ,JST_1-1) + ENDDO + ! + ! generale case : old layer divided in two equal layers + IF ( JST/=1 .OR. PSNOWDZ(JJ,JST)<3.*ZDZOPT(JJ,1) ) THEN + PSNOWDZN(JJ,JST+1) = 0.5*PSNOWDZ(JJ,JST) + PSNOWDZN(JJ,JST) = PSNOWDZN(JJ,JST+1) + ELSE + ! if thick surface layer : force the surface layer to this value to avoid successive resizing + ! [NEW : 11/2012] + PSNOWDZN(JJ,1) = 1.5 * ZDZOPT(JJ,1) + PSNOWDZN(JJ,2) = PSNOWDZ(JJ,JST) - PSNOWDZN(JJ,1) + ENDIF + ! + KNLVLS_USE (JJ) = KNLVLS_USE(JJ) + 1 + OMODIF_GRID(JJ) = .TRUE. + ! + ENDIF + ! + ENDIF + ! + ENDDO + ! + ENDIF + ! +ENDDO +! +! case whithout new snow fall and without a previous grid resize +! looks for a deep layer to be agregated to the layer beneath if similar +! according to its depth and to the optimal grid size +! +!NB : allow these changes for 5 layers and more [NEW] (before : 6 layers) +! +DO JJ = 1,SIZE(PSNOW(:)) + ! + IF ( .NOT.OMODIF_GRID(JJ) ) THEN + ! + DO JST = 2,INLVLS + ! + IF ( JST<=KNLVLS_USE(JJ)-1 .AND. KNLVLS_USE(JJ)>INLVLSMIN+1 .AND. .NOT.OMODIF_GRID(JJ) ) THEN + ! + ZDIFTYPE_INF = SNOW3LDIFTYP( PSNOWGRAN1(JJ,JST+1),PSNOWGRAN1(JJ, JST), & + PSNOWGRAN2(JJ,JST+1),PSNOWGRAN2(JJ, JST), & + HSNOWMETAMO) + ZDIFTYPE_INF = MAX( XDIFF_1, MIN( XDIFF_MAX, ZDIFTYPE_INF ) ) + ! + IF( PSNOWDZ(JJ,JST) < ZDZOPT(JJ,JST) * XAGREG_COEF_1 / ZDIFTYPE_INF .AND. & + PSNOWDZ(JJ,JST) + PSNOWDZ(JJ,JST+1) < & + XAGREG_COEF_2 * MAX( ZDZOPT(JJ,JST),ZDZOPT(JJ,JST+1) ) ) THEN + ! + PSNOWDZN(JJ,JST) = PSNOWDZ(JJ,JST) + PSNOWDZ(JJ,JST+1) + ZDZOPT (JJ,JST) = ZDZOPT(JJ,JST+1) + DO JST_1 = JST+1,KNLVLS_USE(JJ)-1 + PSNOWDZN(JJ,JST_1) = PSNOWDZ(JJ,JST_1+1) + ZDZOPT (JJ,JST_1) = ZDZOPT (JJ,JST_1+1) + ENDDO + KNLVLS_USE(JJ) = KNLVLS_USE(JJ)-1 + OMODIF_GRID(JJ)=.TRUE. + ! + ENDIF + ! + ENDIF + ! + ENDDO + ! + ENDIF + ! +ENDDO +! +! [NEW : 11/2012] +! In case of very low snow fall checks if a new internal snow layer is too shallow +! even if a the grid has already been resized in this time step +! starts from bottom to INLVS_USE-3 until old and new grid differ +DO JJ = 1,SIZE(PSNOW(:)) + ! + IF ( .NOT.GSNOWFALL(JJ) .OR. KNLVLS_USE(JJ) XUEPSI ) CYCLE ! go to next point + ! + ! bottom layer + IF( PSNOWDZN(JJ,KNLVLS_USE(JJ)) XUEPSI ) EXIT ! old/new grid differ ==> go to next grid point + ! + IF ( PSNOWDZN(JJ,JST)> 0.001 ) CYCLE + ! + ! If an internal layer is too shallow, it is merged with the upper layer + PSNOWDZN(JJ,JST-1) = PSNOWDZN(JJ,JST) + PSNOWDZN(JJ,JST-1) + KNLVLS_USE(JJ) = KNLVLS_USE(JJ) - 1 + ! + ! shifts the lower layers + DO JST_1 = JST,INLVLS_USE(JJ) + PSNOWDZN(JJ,JST_1) = PSNOWDZ(JJ,JST_1+1) + ZDZOPT (JJ,JST_1) = ZDZOPT (JJ,JST_1+1) + ENDDO + PSNOWDZN(JJ,INLVLS_USE(JJ)+1) = 0. + ! + EXIT ! goto to next grid point + ! + ENDDO ! end loop internal layers + ! + ENDIF + ! +ENDDO ! end grid loops for checking shallow layers +! +!final check of the consistensy of the new grid size +! +#ifdef DEBUG +DO JJ = 1,SIZE(PSNOW(:)) + ! +! trude test, increase xuepsi limit + IF ( ABS( SUM( PSNOWDZN(JJ,1:KNLVLS_USE(JJ)) ) - PSNOW(JJ) ) > XUEPSI*10000. ) THEN +! IF ( ABS( SUM( PSNOWDZN(JJ,1:KNLVLS_USE(JJ)) ) - PSNOW(JJ) ) > XUEPSI*1000. ) THEN + ! + WRITE(*,*) 'error in grid resizing', JJ, KNLVLS_USE(JJ), SUM( PSNOWDZN(JJ,1:KNLVLS_USE(JJ)) ), & + PSNOW(JJ), SUM( PSNOWDZN(JJ,1:INLVLS_USE(JJ)) )-PSNOW(JJ), & + ZSNOWFALL(JJ) + +! CALL ABOR1_SFX("SNOWCRO: error in grid resizing") + ! + ENDIF + ! +ENDDO +#endif +! +!IF (LHOOK) CALL DR_HOOK('SNOWNLFALL_UPGRID',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWNLFALL_UPGRID + +!############################################################################### +SUBROUTINE GET_SNOWDZN_DEB(KNLVLS,PSNOWDZ,PDZOPT,PSNOWDZN) +! +USE MODD_SNOW_PAR, ONLY : XDZMIN_TOP, XDZMIN_BOT +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +INTEGER, INTENT(IN) :: KNLVLS +REAL, DIMENSION(:), INTENT(IN) :: PSNOWDZ, PDZOPT +REAL, DIMENSION(:), INTENT(OUT) :: PSNOWDZN +! +REAL :: ZPENALTY, ZCRITSIZE +INTEGER :: JJ_A_DEDOUB, JST +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_SNOWDZN_DEB',0,ZHOOK_HANDLE) +! +ZPENALTY = PSNOWDZ(2) / PDZOPT(2) +IF( PSNOWDZ(2)ZPENALTY ) THEN + ZPENALTY = ZCRITSIZE + JJ_A_DEDOUB = JST + ENDIF +ENDDO +! +IF ( JJ_A_DEDOUB==2 ) THEN ! case splitted layer == 2 + PSNOWDZN(1) = 0.5 * ( PSNOWDZ(1) + PSNOWDZ(2) ) + PSNOWDZN(2) = PSNOWDZN(1) +ELSE ! case splitted layer =/ 2 + PSNOWDZN(1) = PSNOWDZ(1) + PSNOWDZ(2) + DO JST = 2,JJ_A_DEDOUB-2 + PSNOWDZN(JST) = PSNOWDZ(JST+1) + ENDDO + PSNOWDZN(JJ_A_DEDOUB-1) = 0.5 * PSNOWDZ(JJ_A_DEDOUB) + PSNOWDZN(JJ_A_DEDOUB) = PSNOWDZN(JJ_A_DEDOUB-1) +ENDIF ! end case splitted layer =/ 2 +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_SNOWDZN_DEB',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_SNOWDZN_DEB +! +!############################################################################### +SUBROUTINE GET_SNOWDZN_END(KNLVLS,PSNOWDZ,PDZOPT,PSNOWDZN) +! +USE MODD_SNOW_PAR, ONLY : XDZMIN_TOP, XDZMIN_BOT +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +INTEGER, INTENT(IN) :: KNLVLS +REAL, DIMENSION(:), INTENT(IN) :: PSNOWDZ, PDZOPT +REAL, DIMENSION(:), INTENT(OUT) :: PSNOWDZN +! +REAL :: ZPENALTY, ZCRITSIZE +INTEGER :: JJ_A_DEDOUB, JST +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_SNOWDZN_END',0,ZHOOK_HANDLE) +! +ZPENALTY = PSNOWDZ(KNLVLS-2) / PDZOPT(KNLVLS-2) +JJ_A_DEDOUB = KNLVLS - 2 +! +DO JST = MAX(1,KNLVLS-3),1,-1 + ZCRITSIZE = PSNOWDZ(JST) / PDZOPT(JST) + IF ( JST==1 .AND. PSNOWDZ(JST)ZPENALTY ) THEN + ZPENALTY = ZCRITSIZE + JJ_A_DEDOUB = JST + ENDIF +ENDDO +! +IF ( JJ_A_DEDOUB==KNLVLS-1 ) THEN ! case splitted layer == 2 + PSNOWDZN(KNLVLS) = 0.5 * (PSNOWDZ(KNLVLS-1)+PSNOWDZ(KNLVLS)) + PSNOWDZN(KNLVLS-1) = PSNOWDZN(KNLVLS) +ELSE ! case splitted layer =/ 2 + PSNOWDZN(KNLVLS) = PSNOWDZ(KNLVLS-1) + PSNOWDZ(KNLVLS) + DO JST = KNLVLS-1,JJ_A_DEDOUB+2,-1 + PSNOWDZN(JST) = PSNOWDZ(JST-1) + ENDDO + PSNOWDZN(JJ_A_DEDOUB+1) = 0.5 * PSNOWDZ(JJ_A_DEDOUB) + PSNOWDZN(JJ_A_DEDOUB ) = PSNOWDZN(JJ_A_DEDOUB+1) +ENDIF ! end case splitted layer =/ 2 +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_SNOWDZN_END',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_SNOWDZN_END +! +!############################################################################### +!################################################################################ +!################################################################################ +! +SUBROUTINE SNOWNLGRIDFRESH_1D (KJ,PSNOW,PSNOWDZ,PSNOWDZN, & + PSNOWRHO,PSNOWHEAT,PSNOWGRAN1,PSNOWGRAN2, & + PSNOWHIST,PSNOWAGE,GSNOWFALL, & + PSNOWRHOF, PSNOWDZF,PSNOWHEATF,PSNOWGRAN1F, & + PSNOWGRAN2F, PSNOWHISTF,PSNOWAGEF, & + KNLVLS_USE, HSNOWMETAMO , I,J ) +! +!! PURPOSE +!! ------- +! Snow mass,heat and characteristics redistibution in case of +! grid resizing. Total mass and heat content of the overall snowpack +! unchanged/conserved within this routine. +! Grain size and type of mixed layers is deduced from the conservation +! of the average optical size +! +!! AUTHOR +!! ------ +!! E. Brun * Meteo-France * +!! +! +USE MODD_SNOW_PAR, ONLY : XD1,XD2,XD3,XX,XVALB5,XVALB6 +USE MODE_SNOW3L, ONLY : GET_MASS_HEAT +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +! +!* 0.1 declarations of arguments +! +! ++ trude added +INTEGER, INTENT(IN) :: I,J +! --trude +INTEGER, INTENT(IN) :: KJ +REAL, INTENT(IN) :: PSNOW +! +REAL, DIMENSION(:), INTENT(INOUT) :: PSNOWHEAT, PSNOWRHO, PSNOWDZ, & + PSNOWGRAN1, PSNOWGRAN2, PSNOWDZN, & + PSNOWHIST +REAL, DIMENSION(:), INTENT(INOUT) :: PSNOWAGE +REAL, INTENT(IN) :: PSNOWRHOF, PSNOWDZF,PSNOWHEATF, & + PSNOWGRAN1F,PSNOWGRAN2F, PSNOWHISTF +REAL, INTENT(IN) :: PSNOWAGEF +! +INTEGER, INTENT(IN) :: KNLVLS_USE +! +LOGICAL, INTENT(IN) :: GSNOWFALL +! + CHARACTER(3),INTENT(IN) :: HSNOWMETAMO +! +!* 0.2 declarations of local variables +! +REAL*8, DIMENSION(SIZE(PSNOWRHO,1)+1) :: ZSNOWRHOO,ZSNOWGRAN1O,ZSNOWGRAN2O, & + ZSNOWHEATO,ZSNOWHISTO,ZSNOWDZO, & + ZSNOWZTOP_OLD,ZSNOWZBOT_OLD +REAL*8,DIMENSION(SIZE(PSNOWRHO,1)+1) :: ZSNOWAGEO +! +REAL*8, DIMENSION(SIZE(PSNOWRHO,1)) :: ZSNOWRHON,ZSNOWGRAN1N,ZSNOWGRAN2N, & + ZSNOWHEATN,ZSNOWHISTN, & + ZSNOWZTOP_NEW,ZSNOWZBOT_NEW +REAL*8,DIMENSION(SIZE(PSNOWRHO,1)) ::ZSNOWAGEN +! +REAL :: ZMASTOTN, ZMASTOTO, ZSNOWHEAN, ZSNOWHEAO +REAL :: ZPSNOW_OLD, ZPSNOW_NEW +! +INTEGER :: INLVLS_OLD, INLVLS_NEW +INTEGER :: JST +! +LOGICAL :: GDIAM +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWNLGRIDFRESH_1D',0,ZHOOK_HANDLE) +! +! 0. Initialization: +! ------------------ +! +! starts by checking the consistency between both vertical grid sizes +INLVLS_NEW = KNLVLS_USE +INLVLS_OLD = -1 +! +ZPSNOW_NEW = 0. +ZPSNOW_OLD = 0. +! +DO JST = 1,INLVLS_NEW + ZPSNOW_NEW = ZPSNOW_NEW + PSNOWDZN(JST) +ENDDO +! + +IF ( ABS( ZPSNOW_NEW - PSNOWDZF )=XUEPSI ) THEN + ZPSNOW_OLD = ZPSNOW_OLD + PSNOWDZ(JST) +! write(*,*) "ABS( ZPSNOW_NEW - PSNOWDZF - ZPSNOW_OLD )", ABS( ZPSNOW_NEW - PSNOWDZF - ZPSNOW_OLD ), inlvls_old +! trude; Test fail, XUEPS seem to be too small. Increase XUEPSI slightly for test +! XUEPSI test probably need to be less strict for very thick snow layers. Perhaps have a moving target? +! IF ( ABS( ZPSNOW_NEW - PSNOWDZF - ZPSNOW_OLD )1 ) ZSNOWZTOP_OLD(JST) = ZSNOWZBOT_OLD(JST-1) + ZSNOWZBOT_OLD(JST) = ZSNOWZTOP_OLD(JST) - ZSNOWDZO(JST) + ENDDO +! + DO JST = 1,INLVLS_NEW + IF ( JST>1 ) ZSNOWZTOP_NEW(JST) = ZSNOWZBOT_NEW(JST-1) + ZSNOWZBOT_NEW(JST) = ZSNOWZTOP_NEW(JST) - PSNOWDZN(JST) + ENDDO + +! NBNBNBNB trude test. When zsnowzbot=zsnowztop_new there is a problem in get_mass_heat. The entire glacier layer for this +! gridpoint is set to zero because snowrho does not get a value. This is a fast fix that needs to be evaluated. + +! +! Check consistency +! true if test: +!IF ( INLVLS_OLD>0 ) THEN + +ZSNOWZBOT_OLD(INLVLS_OLD) = 0. ! trude comment. This line is included in original snowcro, but has been deleted in new WRF-Hydro code. Not sure why. + ! Now testing with this included. +! +ZSNOWZBOT_NEW(INLVLS_NEW) = 0. +! +! 3. Calculate mass, heat, charcateristics mixing due to vertical grid resizing: +! -------------------------------------------------------------------- +! +! loop over the new snow layers +! Summ or avergage of the constituting quantities of the old snow layers +! which are totally or partially inserted in the new snow layer + + + CALL GET_MASS_HEAT(KJ,INLVLS_NEW,INLVLS_OLD, & + ZSNOWZTOP_OLD,ZSNOWZTOP_NEW,ZSNOWZBOT_OLD,ZSNOWZBOT_NEW, & + ZSNOWRHOO,ZSNOWDZO,ZSNOWGRAN1O,ZSNOWGRAN2O,ZSNOWHISTO, & + ZSNOWAGEO,ZSNOWHEATO, & + ZSNOWRHON,PSNOWDZN,ZSNOWGRAN1N,ZSNOWGRAN2N,ZSNOWHISTN, & + ZSNOWAGEN,ZSNOWHEATN,HSNOWMETAMO ) +! + + + + +! check of consistency between new and old snowpacks +ZSNOWHEAN = 0. +ZMASTOTN = 0. +ZSNOWHEAO = 0. +ZMASTOTO = 0. +ZPSNOW_NEW = 0. +ZPSNOW_OLD = 0. +! + DO JST = 1,INLVLS_NEW + ZSNOWHEAN = ZSNOWHEAN + ZSNOWHEATN(JST) + ZMASTOTN = ZMASTOTN + ZSNOWRHON(JST) * PSNOWDZN(JST) + ZPSNOW_NEW = ZPSNOW_NEW + PSNOWDZN(JST) + ENDDO +! + DO JST = 1,INLVLS_OLD + ZSNOWHEAO = ZSNOWHEAO + ZSNOWHEATO(JST) + ZMASTOTO = ZMASTOTO + ZSNOWRHOO(JST) * ZSNOWDZO(JST) + ZPSNOW_OLD = ZPSNOW_OLD + ZSNOWDZO(JST) + ENDDO +! +IF ( ABS( ZSNOWHEAN-ZSNOWHEAO )>0.0001 .OR. ABS( ZMASTOTN-ZMASTOTO )>0.0001 .OR. & +! ABS( ZPSNOW_NEW-ZPSNOW_OLD )> 0.0001 ) THEN +! trude test with higher limit + ABS( ZPSNOW_NEW-ZPSNOW_OLD )> 0.001 ) THEN +! WRITE(*,*) 'Warning diff', ZSNOWHEAN-ZSNOWHEAO,ZMASTOTN-ZMASTOTO,ZPSNOW_NEW-ZPSNOW_OLD +ENDIF +! +! 5. Update mass (density and thickness) and heat: +! ------------------------------------------------ +! +PSNOWDZ (:) = PSNOWDZN (:) +! +PSNOWRHO (:) = ZSNOWRHON (:) +PSNOWHEAT (:) = ZSNOWHEATN (:) +PSNOWGRAN1(:) = ZSNOWGRAN1N(:) +PSNOWGRAN2(:) = ZSNOWGRAN2N(:) +PSNOWHIST (:) = ZSNOWHISTN(:) +! +PSNOWAGE (:) = ZSNOWAGEN (:) + + +! +!IF (LHOOK) CALL DR_HOOK('SNOWNLGRIDFRESH_1D',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWNLGRIDFRESH_1D +!#################################################################### +!#################################################################### +!################################################################### +SUBROUTINE SNOWDRIFT(PTSTEP,PVMOD,PSNOWRHO,PSNOWDZ,PSNOW, & + PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST,KNLVLS_USE, & + PTA,PQA,PPS,PRHOA,PZ0EFF,PUREF, & + OSNOWDRIFT_SUBLIM,HSNOWMETAMO,PSNDRIFT ) +! +!! PURPOSE +!! ------- +! Snow compaction and metamorphism due to drift +! Mass is unchanged: layer thickness is reduced +! in proportion to density increases. Method inspired from +! Brun et al. (1997) and Guyomarch +! +! - computes a mobility index of each snow layer from its grains, density +! and history +! - computes a drift index of each layer from its mobility and wind speed +! - computes a transport index with an exponential decay taking into +! account its depth and the mobility of upper layers +! - increases density and changes grains in case of transport +! +! HISTORY: +! Basic parameterization from Crocus/ARPEGE Coupling (1997) +! Implementation in V5 +! Insertion in V6 of grains type evolution in case of dendritic snow (V. +! Vionnet) +! 07/2012 (for V7.3): E. Brun, M. Lafaysse : optional sublimation of drifted snow +! 2012-09-20 : bug correction : ZFF was not computed if LSNOWDRIFT_SUBLIM=FALSE. +! +! 2014-02-05 V. Vionnet: systematic use of 5m wind speed to compute drift index +! 2014-06-03 M. Lafaysse: threshold on PZ0EFF + +USE MODD_CSTS,ONLY : XTT +USE MODE_THERMOS + +USE MODD_SNOW_PAR, ONLY : XVTIME, XVROMAX, XVROMIN, XVMOB1, & + XVMOB2, XVMOB3, XVMOB4, XVDRIFT1, XVDRIFT2, XVDRIFT3, & + XVSIZEMIN, XCOEF_FF, XCOEF_EFFECT, XQS_REF +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PTSTEP +! +REAL, DIMENSION(:), INTENT(IN) :: PTA, PQA, PPS, PRHOA +! +REAL, DIMENSION(:), INTENT(IN) :: PVMOD +! +INTEGER, DIMENSION(:), INTENT(IN) :: KNLVLS_USE +! +REAL, DIMENSION(:),INTENT(IN) :: PZ0EFF,PUREF +! +LOGICAL,INTENT(IN) :: OSNOWDRIFT_SUBLIM +! + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO ! metamorphism scheme +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWRHO, PSNOWDZ,PSNOWGRAN1, & + PSNOWGRAN2,PSNOWHIST +REAL, DIMENSION(:), INTENT(OUT) :: PSNOW +REAL, DIMENSION(:), INTENT(OUT) :: PSNDRIFT !blowing snow sublimation (kg/m2/s) +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZSNOWRHO2 +REAL, DIMENSION(SIZE(PSNOWRHO,1) ) :: ZSNOWDZ1 +! +REAL, DIMENSION(SIZE(PSNOWRHO,1)) :: ZQSATI, ZFF ! QS wrt ice, gust speed +! +REAL :: ZZ0EFF +! +REAL :: ZPROFEQU, ZRMOB, ZRDRIFT, ZRT, ZDRO, ZDGR1, ZDGR2 +REAL :: ZVT ! 5m wind speed threshold for surface +!transport +REAL :: ZQS_EFFECT ! effect of QS on snow +REAL :: ZWIND_EFFECT ! effect of wind on snow +REAL :: ZDRIFT_EFFECT ! effect of QS and wind on snow +! transformation +REAL :: ZQS !Blowing snow sublimation (kg/m2/s) +REAL :: ZRHI, ZFACT +! +INTEGER :: JJ,JST ! looping indexes +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +! Reference height for wind speed used to dertermine the occurrence of blowing snow +REAL, PARAMETER :: PPHREF_WIND=5. +REAL, PARAMETER :: PPHREF_MIN=PPHREF_WIND/2. +! +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('SNOWDRIFT',0,ZHOOK_HANDLE) +! +! 0. Initialization: +! ------------------ +! +ZSNOWDZ1(:) = PSNOWDZ(:,1) +! +DO JJ = 1,SIZE(PSNOW) + DO JST = 1,KNLVLS_USE(JJ) + ZSNOWRHO2(JJ,JST) = PSNOWRHO(JJ,JST) + ENDDO +ENDDO +! +IF ( OSNOWDRIFT_SUBLIM ) THEN + ZQSATI(:) = QSATI( PTA(:),PPS(:) ) +END IF +! +! 1. Computation of drift and induced settling and metamorphism +! ------------------ +! +DO JJ=1, SIZE(PSNOW) + ! + ! gust speed at 5m above the snowpack + ! Computed from PVMOD at PUREF (m) assuming a log profile in the SBL + ! and a roughness length equal to PZ0EFF + ZZ0EFF=MIN(PZ0EFF(JJ),PUREF(JJ)*0.5,PPHREF_MIN) + ZFF(JJ) = XCOEF_FF*PVMOD(JJ)*LOG(PPHREF_WIND/ZZ0EFF)/LOG(PUREF(JJ)/ZZ0EFF) + ! + ! initialization decay coeff + ZPROFEQU = 0. + ! + DO JST = 1,KNLVLS_USE(JJ) + ! + ZFACT = 1.25 - 1.25 * ( MAX( PSNOWRHO(JJ,JST), XVROMIN ) - XVROMIN )/1000./XVMOB1 + ! + IF ( HSNOWMETAMO=='B92' ) THEN + ! + ! mobility index computation of a layer as a function of its properties + IF( PSNOWGRAN1(JJ,JST)<0. ) THEN + ! dendritic case + ZRMOB = 0.34 * ( 0.5 - ( 0.75*PSNOWGRAN1(JJ,JST) + 0.5*PSNOWGRAN2(JJ,JST) )/99. ) + & + 0.66 * ZFACT + ELSE + ! non dendritic case + ZRMOB = 0.34 * ( XVMOB2 - XVMOB2*PSNOWGRAN1(JJ,JST)/99. - XVMOB3*PSNOWGRAN2(JJ,JST)*1000. ) + & + 0.66 * ZFACT + ENDIF + ! + ELSE + ! + IF ( PSNOWGRAN1(JJ,JST)= 2. ) ZRMOB = MIN(ZRMOB, XVMOB4) + ! + ! computation of drift index supposing no overburden snow + ZRDRIFT = ZRMOB - ( XVDRIFT1 * EXP( -XVDRIFT2*ZFF(JJ) ) - 1.) + ! modif_EB exit loop if there is no drift + IF ( ZRDRIFT<=0. ) EXIT + ! + ! update the decay coeff by half the current layer + ZPROFEQU = ZPROFEQU + 0.5 * PSNOWDZ(JJ,JST) * 0.1 * ( XVDRIFT3 - ZRDRIFT ) + ! computation of the drift index inclunding the decay by overburden snow + ZRT = MAX( 0., ZRDRIFT * EXP( -ZPROFEQU*100 ) ) + ! + IF ( OSNOWDRIFT_SUBLIM .AND. JST==1 ) THEN + !Specific case for blowing snow sublimation + ! computation of wind speed threshold QSATI and RH withe respect to ice + ZVT = -LOG( (ZRMOB+1.)/XVDRIFT1 ) / XVDRIFT2 + ZRHI = PQA(JJ) / ZQSATI(JJ) + ! computation of sublimation rate according to Gordon's PhD +! trude test +! reduce constatn 0.0018 by a factor of 10 + ZQS = 0.0018 * (XTT/PTA(JJ))**4 * ZVT * PRHOA(JJ) * ZQSATI(JJ) * & ! orig + (1.-ZRHI) * (ZFF(JJ)/ZVT)**3.6 + +! ZQS = 0.00018 * (XTT/PTA(JJ))**4 * ZVT * PRHOA(JJ) * ZQSATI(JJ) * & ! trude test, factor of 0.1 + ! (1.-ZRHI) * (ZFF(JJ)/ZVT)**3.6 + +! ZQS = 0.5* 0.0018 * (XTT/PTA(JJ))**4 * ZVT * PRHOA(JJ) * ZQSATI(JJ) * & ! trude test, factor of 0.5 +! (1.-ZRHI) * (ZFF(JJ)/ZVT)**3.6 + + + ! trude, end test + ! WRITE(*,*) 'surface Vt vent*coef ZRDRIFT ZRMOB :',ZVT,& + ! ZFF(JJ),ZRDRIFT,ZRMOB + ! WRITE(*,*) 'V>Vt ZQS :',ZQS + ! surface depth decrease in case of blowing snow sublimation + ! WRITE(*,*) 'V>Vt DSWE DZ Z:',- MAX(0.,ZQS)*PTSTEP/COEF_FF, + ! - MAX(0.,ZQS)*PTSTEP/COEF_FF/PSNOWRHO(JJ,JST),PSNOWDZ(JJ,JST) + ! 2 lignes ci-dessous a valider pour avoir sublim drift + PSNOWDZ(JJ,JST) = MAX( 0.5*PSNOWDZ(JJ,JST), & + PSNOWDZ(JJ,JST) - MAX(0.,ZQS) * PTSTEP/XCOEF_FF/PSNOWRHO(JJ,JST) ) + PSNDRIFT(JJ) = (ZSNOWDZ1(JJ)-PSNOWDZ(JJ,JST))*PSNOWRHO(JJ,JST)/PTSTEP + ELSE + ZQS = 0. + END IF + ! + ZQS_EFFECT = MIN( 3., MAX( 0.,ZQS )/XQS_REF ) * ZRT + ZWIND_EFFECT = XCOEF_EFFECT * ZRT + ZDRIFT_EFFECT = ( ZQS_EFFECT + ZWIND_EFFECT ) * PTSTEP / XCOEF_FF / XVTIME + ! WRITE(*,*) 'ZQS_EFFECT,ZWIND_EFFECT,ZDRIFT_EFFECT:',ZQS_EFFECT,ZWIND_EFFECT,ZDRIFT_EFFECT + ! + ! settling by wind transport only in case of not too dense snow + IF( PSNOWRHO(JJ,JST) < XVROMAX ) THEN + ZDRO = ZDRIFT_EFFECT * ( XVROMAX - PSNOWRHO(JJ,JST) ) + PSNOWRHO(JJ,JST) = MIN( XVROMAX , PSNOWRHO(JJ,JST) + ZDRO ) + PSNOWDZ (JJ,JST) = PSNOWDZ(JJ,JST) * ZSNOWRHO2(JJ,JST) / PSNOWRHO(JJ,JST) + ENDIF + ! + IF ( HSNOWMETAMO=='B92' ) THEN + ! + ! metamorphism induced by snow drift + IF ( PSNOWGRAN1(JJ,JST)<0. ) THEN + ! dendritic case + ZDGR1 = ZDRIFT_EFFECT * ( -PSNOWGRAN1(JJ,JST) ) * 0.5 + PSNOWGRAN1(JJ,JST) = PSNOWGRAN1(JJ,JST) + MIN( ZDGR1, -0.99 * PSNOWGRAN1(JJ,JST) ) + ! modif_VV_140910 + ZDGR2 = ZDRIFT_EFFECT * ( 99. - PSNOWGRAN2(JJ,JST) ) + PSNOWGRAN2(JJ,JST) = MIN( 99., PSNOWGRAN2(JJ,JST) + ZDGR2 ) + ! fin modif_VV_140910 + ELSE + ! non dendritic case + ZDGR1 = ZDRIFT_EFFECT * ( 99. - PSNOWGRAN1(JJ,JST) ) + ZDGR2 = ZDRIFT_EFFECT * 5. / 10000. + PSNOWGRAN1(JJ,JST) = MIN( 99., PSNOWGRAN1(JJ,JST) + ZDGR1 ) + PSNOWGRAN2(JJ,JST) = MAX( XVSIZEMIN, PSNOWGRAN2(JJ,JST) - ZDGR2 ) + ENDIF + ! + ELSE + ! + ! dendritic case + IF ( PSNOWGRAN1(JJ,JST)=1 .AND. KNLVLS_USE(JJ)>1 ) THEN + ! + ! Total Liquid equivalent water content of snow (m): + ZSNOWLWE = PSNOWRHO(JJ,JST) * PSNOWDZ(JJ,JST) / XRHOLW + ! + ! Consideration of sublimation if any + IF ( JST==1 ) ZSNOWLWE = ZSNOWLWE - MAX( 0., PLES3L(JJ)*PTSTEP/(XLSTT*XRHOLW) ) + ! + ! Test if avalaible energy exceeds total latent heat + IF ( PSCAP(JJ,JST) * MAX( 0.0, PSNOWTEMP(JJ,JST)-XTT ) * PSNOWDZ(JJ,JST) >= & + ( ( ZSNOWLWE-PSNOWLIQ(JJ,JST) ) * XLMTT * XRHOLW ) - XUEPSI ) THEN + ! + IF ( JST==KNLVLS_USE(JJ) ) THEN + ID_1 = JST-1 + ID_2 = JST + ELSE + ID_1 = JST + ID_2 = JST + 1 + ENDIF + ! + ! Case of a total melt of the bottom layer: merge with above layer + ! which keeps its grain, histo and age properties + ZHEAT = 0. + ZMASS = 0. + ZDZ = 0. + ZLIQ = 0. + DO JST_2 = ID_1,ID_2 + ZHEAT = ZHEAT + & + PSNOWDZ(JJ,JST_2) * & + ( PSCAP(JJ,JST_2)*( PSNOWTEMP(JJ,JST_2)-XTT ) - XLMTT*PSNOWRHO(JJ,JST_2) ) + & + XLMTT * XRHOLW * PSNOWLIQ(JJ,JST_2) + ZMASS = ZMASS + PSNOWDZ(JJ,JST_2) * PSNOWRHO(JJ,JST_2) + ZDZ = ZDZ + PSNOWDZ(JJ,JST_2) + ZLIQ = ZLIQ + PSNOWLIQ(JJ,JST_2) + ENDDO + ! + PSNOWDZ (JJ,ID_1) = ZDZ + PSNOWRHO (JJ,ID_1) = ZMASS / ZDZ + PSNOWLIQ (JJ,ID_1) = ZLIQ + ! + ! Temperature of the merged layer is deduced from the heat content + PSCAP (JJ,ID_1) = ( PSNOWRHO(JJ,ID_1) - & + PSNOWLIQ(JJ,ID_1) * XRHOLW / & + MAX( PSNOWDZ(JJ,ID_1),XSNOWDZMIN ) ) * XCI + PSNOWTEMP(JJ,ID_1) = XTT + & + ( ( ( ( ZHEAT - XLMTT*XRHOLW*PSNOWLIQ(JJ,ID_1) ) / PSNOWDZ(JJ,ID_1) ) + & + XLMTT*PSNOWRHO(JJ,ID_1) ) & + / PSCAP(JJ,ID_1) ) + ! + IF( JST/=KNLVLS_USE(JJ) ) THEN + ! + PSNOWGRAN1(JJ,JST) = PSNOWGRAN1(JJ,JST+1) + PSNOWGRAN2(JJ,JST) = PSNOWGRAN2(JJ,JST+1) + PSNOWHIST (JJ,JST) = PSNOWHIST (JJ,JST+1) + PSNOWAGE (JJ,JST) = PSNOWAGE (JJ,JST+1) + ! + ! Shift the above layers + DO JST_2 = JST+1,KNLVLS_USE(JJ)-1 + PSNOWTEMP (JJ,JST_2) = PSNOWTEMP (JJ,JST_2+1) + PSCAP (JJ,JST_2) = PSCAP (JJ,JST_2+1) + PSNOWDZ (JJ,JST_2) = PSNOWDZ (JJ,JST_2+1) + PSNOWRHO (JJ,JST_2) = PSNOWRHO (JJ,JST_2+1) + PSNOWLIQ (JJ,JST_2) = PSNOWLIQ (JJ,JST_2+1) + PSNOWGRAN1(JJ,JST_2) = PSNOWGRAN1(JJ,JST_2+1) + PSNOWGRAN2(JJ,JST_2) = PSNOWGRAN2(JJ,JST_2+1) + PSNOWHIST (JJ,JST_2) = PSNOWHIST (JJ,JST_2+1) + PSNOWAGE (JJ,JST_2) = PSNOWAGE (JJ,JST_2+1) + ENDDO ! loop JST_2 + ! + ! Update the shift counter IDIFF_LAYER + IDIFF_LAYER = IDIFF_LAYER + 1 + ! + ENDIF ! end test of bottom layer + ! + ! Decrease the number of active snow layers + KNLVLS_USE(JJ) = KNLVLS_USE(JJ) - 1 + ! + ENDIF ! end test on availibility of energy + ! + ENDIF ! end test on the number of remaining active layers + ! + ENDDO ! end loop on the snow layers + ! +ENDDO ! end loop gridpoints +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROLAYER_GONE',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROLAYER_GONE +!#################################################################### +!################################################################### +!#################################################################### +!################################################################### +SUBROUTINE SNOWCROPRINTPROFILE(HINFO,KLAYERS,OPRINTGRAN,PSNOWDZ,PSNOWRHO, & + PSNOWTEMP,PSNOWLIQ,PSNOWHEAT,PSNOWGRAN1, & + PSNOWGRAN2,PSNOWHIST,PSNOWAGE,HSNOWMETAMO ) +! +! Matthieu Lafaysse 08/06/2012 +! This routine prints the snow profile of a given point for debugging +! +!to compute SSA +USE MODD_CSTS, ONLY : XRHOLI +USE MODD_SNOW_PAR, ONLY : XD1, XD2, XD3, XX +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! + CHARACTER(*), INTENT(IN) :: HINFO +LOGICAL, INTENT(IN) :: OPRINTGRAN +INTEGER, INTENT(IN) :: KLAYERS +REAL, DIMENSION(:), INTENT(IN) :: PSNOWDZ,PSNOWRHO,PSNOWTEMP,PSNOWLIQ, & + PSNOWHEAT,PSNOWGRAN1,PSNOWGRAN2, & + PSNOWHIST,PSNOWAGE + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO +! +REAL, DIMENSION(KLAYERS) :: ZSNOWSSA +REAL :: ZDIAM +! +INTEGER :: JST +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTPROFILE',0,ZHOOK_HANDLE) +! +WRITE(*,*) +WRITE(*,*)TRIM(HINFO) +! +IF (OPRINTGRAN) THEN + ! + ! Compute SSA from SNOWGRAN1 and SNOWGRAN2 + IF ( HSNOWMETAMO=='B92' ) THEN + ! + DO JST = 1,KLAYERS + ! + IF ( PSNOWGRAN1(JST)<0. ) THEN + ZDIAM = -PSNOWGRAN1(JST)*XD1/XX + (1.+PSNOWGRAN1(JST)/XX) * & + ( PSNOWGRAN2(JST)*XD2/XX + (1.-PSNOWGRAN2(JST)/XX) * XD3 ) + ZDIAM = ZDIAM/10000. + ELSE + ZDIAM = PSNOWGRAN2(JST)*PSNOWGRAN1(JST)/XX + & + MAX( 0.0004, 0.5*PSNOWGRAN2(JST) ) * ( 1.-PSNOWGRAN1(JST)/XX ) + ENDIF + ZSNOWSSA(JST) = 6. / (XRHOLI*ZDIAM) + ! + END DO + ! + ELSE + ! + ZSNOWSSA = 6. / (XRHOLI*PSNOWGRAN1) + ! + ENDIF + ! + WRITE(*,'(9(A12,"|"))')"-------------","-------------","-------------",& + "-------------","-------------","-------------","-------------",& + "-------------","-------------" + WRITE(*,'(9(A12,"|"))')"PSNOWDZ","PSNOWRHO","PSNOWTEMP","PSNOWLIQ","PSNOWHEAT",& + "PSNOWGRAN1","PSNOWGRAN2","PSNOWHIST","PSNOWAGE" + WRITE(*,'(9(A12,"|"))')"-------------","-------------","-------------",& + "-------------","-------------","-------------","-------------",& + "-------------","-------------" + DO JST = 1,KLAYERS + WRITE(*,'(9(ES12.3,"|")," L",I2.2)') PSNOWDZ(JST),PSNOWRHO(JST),PSNOWTEMP(JST), & + PSNOWLIQ(JST),PSNOWHEAT(JST),PSNOWGRAN1(JST), & + PSNOWGRAN2(JST),PSNOWHIST(JST),PSNOWAGE(JST),JST + ENDDO + WRITE(*,'(9(A12,"|"))')"-------------","-------------","-------------",& + "-------------","-------------","-------------","-------------",& + "-------------","-------------" + ! +ELSE + ! + WRITE(*,'(5(A12,"|"))')"------------","------------","------------",& + "------------","------------" + WRITE(*,'(5(A12,"|"))')"PSNOWDZ","PSNOWRHO","PSNOWTEMP","PSNOWLIQ","PSNOWHEAT" + WRITE(*,'(5(A12,"|"))')"------------","------------","------------",& + "------------","------------" + DO JST = 1,KLAYERS + WRITE(*,'(5(ES12.3,"|")," L",I2.2)') PSNOWDZ(JST),PSNOWRHO(JST),PSNOWTEMP(JST),& + PSNOWLIQ(JST),PSNOWHEAT(JST),JST + ENDDO + WRITE(*,'(5(A12,"|"))')"------------","------------","------------",& + "------------","------------" + ! +END IF +! +WRITE(*,*) +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTPROFILE',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROPRINTPROFILE +!#################################################################### +!################################################################### +SUBROUTINE SNOWCROPRINTATM(CINFO,PTA,PQA,PVMOD,PRR,PSR,PSW_RAD,PLW_RAD, & + PTG, PSOILCOND,PD_G,PPSN3L ) + +! Matthieu Lafaysse 08/06/2012 +! This routine prints the atmospheric forcing of a given point for debugging +! and ground data +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE + + CHARACTER(*), INTENT(IN) :: CINFO +REAL, INTENT(IN) :: PTA,PQA,PVMOD,PRR,PSR,PSW_RAD,PLW_RAD +REAL, INTENT(IN) :: PTG, PSOILCOND, PD_G, PPSN3L +! +INTEGER :: JST +! +!!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTATM',0,ZHOOK_HANDLE) +! + CALL SNOWCROPRINTDATE() +! +WRITE(*,*) +WRITE(*,*)TRIM(CINFO) +WRITE(*,'(4(A12,"|"))')"------------","------------","------------",& +"------------" +WRITE(*,'(4(A12,"|"))')"PTA","PQA","PRR","PSR" +WRITE(*,'(4(A12,"|"))')"------------","------------","------------",& +"------------" +WRITE(*,'(4(ES12.3,"|")," meteo1")')PTA,PQA,PRR,PSR +WRITE(*,'(4(A12,"|"))')"------------","------------","------------",& +"------------" +WRITE(*,'(3(A12,"|"))')"------------","------------","------------" +WRITE(*,'(3(A12,"|"))')"PSW_RAD","PLW_RAD","PVMOD" +WRITE(*,'(3(A12,"|"))')"------------","------------","------------" +WRITE(*,'(3(ES12.3,"|")," meteo2")')PSW_RAD,PLW_RAD,PVMOD +WRITE(*,'(3(A12,"|"))')"------------","------------","------------" +WRITE(*,*) +WRITE(*,*)"Ground :" +WRITE(*,'(4(A12,"|"))')"------------","------------","------------",& +"------------" +WRITE(*,'(4(A12,"|"))')"PTG","PSOILCOND","PD_G","PPSN3L" +WRITE(*,'(4(A12,"|"))')"------------","------------","------------",& +"------------" +WRITE(*,'(4(ES12.3,"|")," soil")')PTG,PSOILCOND,PD_G,PPSN3L +WRITE(*,'(4(A12,"|"))')"------------","------------","------------",& +"------------" +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTATM',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROPRINTATM +! +!#################################################################### +!SUBROUTINE SNOWCROSTOPBALANCE(PMASSBALANCE,PENERGYBALANCE) +! +!USE MODE_CRODEBUG, ONLY : XWARNING_MASSBALANCE, XWARNING_ENERGYBALANCE +! +!!USE MODI_ABOR1_SFX +! +!!USE PARKIND1 ,ONLY : JPRB ! trude added +! +! stop if energy and mass balances are not closed +! +!IMPLICIT NONE +!! +!REAL , DIMENSION(:), INTENT(IN) :: PMASSBALANCE, PENERGYBALANCE +! +!REAL,DIMENSION(SIZE(PSR)) :: ZMASSBALANCE,ZENERGYBALANCE +! +!!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!!IF (LHOOK) CALL DR_HOOK('SNOWCROSTOPBALANCE',0,ZHOOK_HANDLE) +! +!IF ( ANY( PMASSBALANCE > XWARNING_MASSBALANCE ) ) & +! CALL ABOR1_SFX("SNOWCRO: WARNING MASS BALANCE !") +!IF ( ANY( PENERGYBALANCE > XWARNING_ENERGYBALANCE ) ) & +! CALL ABOR1_SFX("SNOWCRO: WARNING ENERGY BALANCE !") +! +!!IF (LHOOK) CALL DR_HOOK('SNOWCROSTOPBALANCE',1,ZHOOK_HANDLE) +! +!END SUBROUTINE SNOWCROSTOPBALANCE +! +!################################################################### +SUBROUTINE SNOWCROPRINTBALANCE(PSUMMASS_INI,PSUMHEAT_INI,PSUMMASS_FIN,PSUMHEAT_FIN, & + PSR,PRR,PTHRUFAL,PEVAP,PEVAPCOR,PGRNDFLUX,PHSNOW, & + PRNSNOW,PLEL3L,PLES3L,PHPSNOW,PSNOWHMASS,PSNOWDZ, & + PTSTEP,PMASSBALANCE,PENERGYBALANCE,PEVAPCOR2 ) +! +! Matthieu Lafaysse / Eric Brun 03/10/2012 +! Print energy and mass balances. +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +REAL, INTENT(IN) :: PSUMMASS_INI,PSUMHEAT_INI,PSUMMASS_FIN,PSUMHEAT_FIN +REAL, INTENT(IN) :: PSR,PRR,PTHRUFAL,PEVAP,PEVAPCOR +REAL, INTENT(IN) :: PGRNDFLUX,PHSNOW,PRNSNOW,PLEL3L,PLES3L,PHPSNOW,PSNOWHMASS +REAL, INTENT(IN) :: PSNOWDZ !first layer +REAL, INTENT(IN) :: PTSTEP !time step +REAL, INTENT(IN) :: PMASSBALANCE, PENERGYBALANCE, PEVAPCOR2 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTBALANCE',0,ZHOOK_HANDLE) +! +WRITE(*,*) ' ' +WRITE(*,FMT='(A1,67("+"),A1)') "+","+" +! + CALL SNOWCROPRINTDATE() +! +WRITE(*,*) ' ' +! +! print des residus de bilan et des differents termes pour le point +WRITE (*,FMT="(A25,1x,E17.10)") 'final mass (kg/m2) =' , PSUMMASS_FIN +WRITE (*,FMT="(A25,1x,E17.10)") 'final energy (J/m2) =', ZSUMHEAT_FIN +WRITE(*,*) ' ' +! +WRITE(*,FMT="(A25,1x,E17.10)") 'mass balance (kg/m2) =', PMASSBALANCE +! +WRITE(*,*) ' ' +WRITE(*,FMT="(A35)") 'mass balance contribution (kg/m2) ' +WRITE(*,FMT="(A51,1x,E17.10)") 'delta mass:', (PSUMMASS_FIN-PSUMMASS_INI) +WRITE(*,FMT="(A51,1x,E17.10)") 'hoar or condensation (>0 towards snow):', -PEVAP * PTSTEP +WRITE(*,FMT="(A51,1x,E17.10)") 'rain:', PRR * PTSTEP +WRITE(*,FMT="(A51,1x,E17.10)") 'snow:', PSR * PTSTEP +WRITE(*,FMT="(A51,1x,E17.10)") 'run-off:', PTHRUFAL * PTSTEP +WRITE(*,FMT="(A51,1x,E17.10)") 'evapcor:', PEVAPCOR * PTSTEP +! +WRITE(*,FMT='(A1,55("-"),A1)')"+","+" +WRITE(*,*) ' ' +! +WRITE(*,FMT="(A25,4(1x,E17.10))") 'energy balance (W/m2)=',PENERGYBALANCE +! +WRITE(*,*) ' ' +WRITE(*,FMT="(A55)") 'energy balance contribution (W/m2) >0 towards snow :' +WRITE(*,FMT="(A51,1x,E17.10)") 'delta heat:', (ZSUMHEAT_FIN-ZSUMHEAT_INI)/PTSTEP +WRITE(*,FMT="(A51,1x,E17.10)") 'radiation (LW + SW):', PRNSNOW +WRITE(*,FMT="(A51,1x,E17.10)") 'sensible flux :', -PHSNOW +WRITE(*,FMT="(A51,1x,E17.10)") 'ground heat flux :', -PGRNDFLUX +WRITE(*,FMT="(A51,1x,E17.10)") 'liquid latent flux:', -PLEL3L +WRITE(*,FMT="(A51,1x,E17.10)") 'solid latent flux:', -PLES3L +WRITE(*,FMT="(A51,1x,E17.10)") 'rain sensible heat:', PHPSNOW +WRITE(*,FMT="(A51,1x,E17.10)") 'snowfall/hoar heat (sensible + melt heat):', PSNOWHMASS/PTSTEP +WRITE(*,FMT="(A51,1x,E17.10)") 'evapcor:', PEVAPCOR2 +WRITE(*,FMT='(A1,67("+"),A1)')"+","+" +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTBALANCE',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROPRINTBALANCE +! +!#################################################################### +SUBROUTINE GET_BALANCE(PSUMMASS_INI,PSUMHEAT_INI,PSUMMASS_FIN,PSUMHEAT_FIN, & + PSR,PRR,PTHRUFAL,PEVAP,PEVAPCOR,PGRNDFLUX,PHSNOW, & + PRNSNOW,PLEL3L,PLES3L,PHPSNOW,PSNOWHMASS,PSNOWDZ, & + PTSTEP,PMASSBALANCE,PENERGYBALANCE,PEVAPCOR2 ) +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +REAL, INTENT(IN) :: PSUMMASS_INI,PSUMHEAT_INI,PSUMMASS_FIN,PSUMHEAT_FIN +REAL, INTENT(IN) :: PSR,PRR,PTHRUFAL,PEVAP,PEVAPCOR +REAL, INTENT(IN) :: PGRNDFLUX,PHSNOW,PRNSNOW,PLEL3L,PLES3L,PHPSNOW,PSNOWHMASS +REAL, INTENT(IN) :: PSNOWDZ !first layer +REAL, INTENT(IN) :: PTSTEP !time step +! +REAL, INTENT(OUT) :: PMASSBALANCE, PENERGYBALANCE, PEVAPCOR2 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_BALANCE',0,ZHOOK_HANDLE) +! +PMASSBALANCE = PSUMMASS_FIN - PSUMMASS_INI - & + ( PSR + PRR - PTHRUFAL - PEVAP + PEVAPCOR ) * PTSTEP +! +PEVAPCOR2 = PEVAPCOR * PSNOWDZ / MAX( XUEPSI,PSNOWDZ ) * & + ( ABS(PLEL3L) * XLVTT / MAX( XUEPSI,ABS(PLEL3L) ) + & + ABS(PLES3L) * XLSTT / MAX( XUEPSI,ABS(PLES3L) ) ) +! +PENERGYBALANCE = ( PSUMHEAT_FIN-PSUMHEAT_INI ) / PTSTEP - & + ( -PGRNDFLUX - PHSNOW + PRNSNOW - PLEL3L - PLES3L + PHPSNOW ) - & + PSNOWHMASS / PTSTEP - PEVAPCOR2 +! +!IF (LHOOK) CALL DR_HOOK('SNOWCRO:GET_BALANCE',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_BALANCE +! +!################################################################### +SUBROUTINE SNOWCROPRINTDATE() +! +!USE PARKIND1 ,ONLY : JPRB ! trude added +! +IMPLICIT NONE +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTDATE',0,ZHOOK_HANDLE) +! +!WRITE(*,FMT='(I4.4,2("-",I2.2)," Hour=",F5.2)') & +! TPTIME%TDATE%YEAR, TPTIME%TDATE%MONTH, TPTIME%TDATE%DAY, TPTIME%TIME/3600. +! +!IF (LHOOK) CALL DR_HOOK('SNOWCROPRINTDATE',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOWCROPRINTDATE +!#################################################################### +!################################################################### +! +END SUBROUTINE SNOWCRO + + +END MODULE MODULE_SNOWCRO diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/Makefile b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/Makefile new file mode 100644 index 000000000..1bb82790a --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/Makefile @@ -0,0 +1,31 @@ +# +# Makefile +# + +include ../../user_build_options +SRCS := $(wildcard *.F) +OBJS := $(SRCS:%.F=%.o) +CPPHRLDAS = -D_HRLDAS_OFFLINE_ + +all: $(OBJS) + +%.o:%.F + @echo "" + $(COMPILERF90) $(CPPINVOKE) $(CPPFLAGS) $(CPPHRLDAS) -o $@ -c -I../Utility_routines \ + $(F90FLAGS) $(LDFLAGS) $(FREESOURCE) $< + @echo "" + +# +# Dependencies: +# +mode_snow3l.o: modd_snow_par.o modd_csts.o modd_snow_metamo.o +mode_thermos.o: modd_csts.o modd_snow_par.o +mode_surf_coefs.o: modd_surf_atm.o mode_thermos.o +ini_csts.o: modd_csts.o + + +# +# This command cleans up object (etc) files: +# +clean: + $(RM) *.o *.mod *.stb *~ diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/ini_csts.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/ini_csts.F new file mode 100644 index 000000000..355da2742 --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/ini_csts.F @@ -0,0 +1,329 @@ +MODULE MODI_INI_CSTS + +CONTAINS + +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ######### + SUBROUTINE INI_CSTS +! ################## +! +!!**** *INI_CSTS * - routine to initialize the module MODD_CST +!! +!! PURPOSE +!! ------- +! The purpose of this routine is to initialize the physical constants +! stored in module MODD_CST. +! +! +!!** METHOD +!! ------ +!! The physical constants are set to their numerical values +!! +!! +!! EXTERNAL +!! -------- +!! FMLOOK : to retrieve logical unit number associated to a file +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : contains physical constants +!! +!! REFERENCE +!! --------- +!! Book2 of the documentation (module MODD_CST, routine INI_CSTS) +!! +!! +!! AUTHOR +!! ------ +!! V. Ducrocq * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 18/05/94 +!! J. Stein 02/01/95 add the volumic mass of liquid water +!! J.-P. Pinty 13/12/95 add the water vapor pressure over solid ice +!! J. Stein 29/06/97 add XTH00 +!! V. Masson 05/10/98 add XRHOLI +!! C. Mari 31/10/00 add NDAYSEC +!! V. Masson 01/03/03 add XCONDI +!! A. Voldoire 01/12/09 add XTTSI, XICEC, XTTS for ESM +!! J. Escobar 28/03/2014 for pb with emissivity/aerosol reset XSURF_TINY=1.0e-80 in real8 case +!! +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +! +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +! trude, do not think we need ini_cturbs +!USE MODI_INI_CTURBS +! +! trude, do not think we need ini_ocean +!USE MODI_INI_OCEAN_CSTS +! +!trude, this module read namelist. Need to move namelist options to another place +!USE MODI_INI_SURF_CSTS +! +IMPLICIT NONE +! +!------------------------------------------------------------------------------- +! +!* 1. FUNDAMENTAL CONSTANTS +! --------------------- +! +LOGICAL :: LREPROD_OPER,LMEBREC +REAL :: XEVERG_RSMIN, XEVERG_VEG, XANSFRACMEL,XTEMPANS +REAL :: XANSMIN, XANSMAX, XAGLAMIN, XAGLAMAX, XEMISSN, XUNDEF +REAL :: XVAGING_NOGLACIER, XVAGING_GLACIER + + CHARACTER(LEN=3) :: CDGAVG, CIMPLICIT_WIND,CQSAT,CCHARNOCK + CHARACTER(LEN=4) :: CDGDIF + + + +!REAL(KIND=JPRB) :: ZHOOK_HANDLE + +XUNDEF=1.E+20 + +!IF (LHOOK) CALL DR_HOOK('INI_CSTS',0,ZHOOK_HANDLE) + +#ifdef SFX_MNH +#ifdef MNH_MPI_DOUBLE_PRECISION +!XSURF_TINY = 1.0e-80 +XSURF_TINY = 1.0e-30 +#else +XSURF_TINY = TINY (XSURF_TINY ) +#endif +#else +!XSURF_TINY = 1.0e-80 +XSURF_TINY = 1.0e-30 +#endif +XSURF_TINY_12 = SQRT (XSURF_TINY ) +XSURF_EPSILON = EPSILON (XSURF_EPSILON ) * 10.0 + +XPI = 2.*ASIN(1.) +XKARMAN = 0.4 +XBOLTZ = 1.380658E-23 +XLIGHTSPEED = 299792458. +XPLANCK = 6.6260755E-34 +XAVOGADRO = 6.0221367E+23 +! +!------------------------------------------------------------------------------- +! +!* 2. ASTRONOMICAL CONSTANTS +! ---------------------- +! +XDAY = 86400. +XSIYEA = 365.25*XDAY*2.*XPI/ 6.283076 +XSIDAY = XDAY/(1.+XDAY/XSIYEA) +XOMEGA = 2.*XPI/XSIDAY +NDAYSEC = 24*3600 ! Number of seconds in a day +! +!-------------------------------------------------------------------------------! +! +! +!* 3. TERRESTRIAL GEOIDE CONSTANTS +! ---------------------------- +! +XRADIUS = 6371229. +XG = 9.80665 +! +!------------------------------------------------------------------------------- +! +!* 4. REFERENCE PRESSURE +! ------------------- +! +XP00 = 1.E5 +XTH00 = 300. +!------------------------------------------------------------------------------- +! +!* 5. RADIATION CONSTANTS +! ------------------- +! +!JUAN OVERFLOW XSTEFAN = 2.* XPI**5 * XBOLTZ**4 / (15.* XLIGHTSPEED**2 * XPLANCK**3) +XSTEFAN = ( 2.* XPI**5 / 15. ) * ( (XBOLTZ / XPLANCK)* XBOLTZ ) * (XBOLTZ/(XLIGHTSPEED*XPLANCK))**2 +XI0 = 1370. +! +!------------------------------------------------------------------------------- +! +!* 6. THERMODYNAMIC CONSTANTS +! ----------------------- +! +XMD = 28.9644E-3 +XMV = 18.0153E-3 +XRD = XAVOGADRO * XBOLTZ / XMD +XRV = XAVOGADRO * XBOLTZ / XMV +XCPD = 7.* XRD /2. +XCPV = 4.* XRV +XRHOLW = 1000. +XRHOLI = 917. +XCONDI = 2.22 +XCL = 4.218E+3 +XCI = 2.106E+3 +XTT = 273.16 +XTTSI = XTT - 1.8 +XICEC = 0.5 +XTTS = XTT*(1-XICEC) + XTTSI*XICEC +XLVTT = 2.5008E+6 +XLSTT = 2.8345E+6 +XLMTT = XLSTT - XLVTT +XESTT = 611.14 +XGAMW = (XCL - XCPV) / XRV +XBETAW = (XLVTT/XRV) + (XGAMW * XTT) +XALPW = LOG(XESTT) + (XBETAW /XTT) + (XGAMW *LOG(XTT)) +XGAMI = (XCI - XCPV) / XRV +XBETAI = (XLSTT/XRV) + (XGAMI * XTT) +XALPI = LOG(XESTT) + (XBETAI /XTT) + (XGAMI *LOG(XTT)) +! +!------------------------------------------------------------------------------- +! +!* 7. TURBULENCE CONSTANTS +! -------------------- +! +! trude, do not think we need ini_cturbs. Commenting this out +! CALL INI_CTURBS +! end trude +!------------------------------------------------------------------------------- +! +!* 8. OCEAN CONSTANTS +! --------------- +! +! trude, do not think we need ini_ocean_csts. Commenting this out +! CALL INI_OCEAN_CSTS +! +!* 9. SURFACE CONSTANTS +! ----------------- +! +! trude: these constants can be changed in namelist (read by ini_surf_csts) +! For now, I will declare the default values here, and later put them into +!namelist for hrlds +!------------------------------------------------------------------------------- + +! +! * Reproductibility for SURFEX OPER +! +LREPROD_OPER = .FALSE. ! default +LMEBREC = .FALSE. +! +! +! * Vegetation parameters for tropical forest +! +!XEVERG_RSMIN : old = 250. (Manzi 1993) but observations range +! from 140 to 180. According to Delire et al. (1997) and +! new tests over 6 local sites, 175. is recommended +! Should be the default after check with AROME/ALADIN +! +XEVERG_RSMIN = 175. !Rsmin +! +!XEVERG_VEG : old = 0.99 (Manzi 1993) but according to Delire et al. (1997) and +! new tests over 6 local sites, 1.0 is recommended because 0.99 +! induces unrealistic bare soil evaporation for Tropical forest +! Should be the default after check with AROME/ALADIN +! +XEVERG_VEG = 1.0 !Veg fraction +! +! * Soil depth average +! + CDGAVG = 'INV' +! +! * Soil depth with ISBA-DF +! + CDGDIF = 'ROOT' +! +! * wind implicitation option +! + CIMPLICIT_WIND = 'NEW' +! +! * qsat computation +! + CQSAT = 'NEW' +! CQSAT = 'OLD' +! +! * Charnock parameter +! + CCHARNOCK = 'NEW' + +IF(LMEBREC)THEN +! Fraction of maximum value of the albedo of snow that is reached for melting +! snow +! + XANSFRACMEL = 0.85 ! (-) +! +! Threeshold temperature above which the snow albedo starts to decrease +! + XTEMPANS = 268.15 ! (K) +! +ENDIF + + +XEMISSN = XUNDEF +IF(XEMISSN==XUNDEF)THEN + IF(LREPROD_OPER)THEN + XEMISSN = 1.0 + ELSE + XEMISSN = 0.99 + ENDIF +ENDIF + +! +! Use recommended settings for snow albedo (FALSE = ISBA default) +! +LMEBREC=.FALSE. +! +! Fraction of maximum value of the albedo of snow that is reached for melting +! snow +! +XANSFRACMEL = 1.0 ! (-) +XANSMIN = 0.50 ! (-) +XANSMAX = 0.85 ! (-) +! +! Minimum and maximum values of the albedo of permanet snow/ice: +! +XAGLAMIN = 0.8 ! orig 0.8 ! (-) trude test with 0.7 +XAGLAMAX = 0.85 ! (-) +! +! Use recommended settings for snow albedo (FALSE = ISBA default) +! +LMEBREC=.FALSE. +! +! Fraction of maximum value of the albedo of snow that is reached for melting +! snow +! +XANSFRACMEL = 1.0 ! (-) + +! Roughness length ratio between ice and snow +!XZ0ICEZ0SNOW = 100 ! trude try 100 instead of the original value of 10. +!XZ0ICEZ0SNOW = 20 !7 ! trude; 20 is what I used when shared the code +!XZ0ICEZ0SNOW = 7 ! trude; ice was melting slighly too much. Try the original 10 instead. factor of 7 instead as backed up by obs over Hardangerjøkulen (Anreassen et al 2008) +XZ0ICEZ0SNOW = 10 ! trude; ice was melting slighly too much. Try the original 10 instead. f +!XZ0ICEZ0SNOW = 50 ! trude; ice was melting slighly too much. Try the original 10 instead. + + +!XZ0ICEZ0SNOW = 14 ! trude; ice was melting slighly too much. Try the original 10 instead. f +!XZ0ICEZ0SNOW = 28 ! trude; ice was melting slighly too much. Try the original 10 instead. f +! Density threshold for ice detection kg.m-3 +XRHOTHRESHOLD_ICE = 850. + +! Parameters for ageing effect on albedo +XVAGING_NOGLACIER = 60. +XVAGING_GLACIER = 900. + + +! trude commented this out +! CALL INI_SURF_CSTS +!IF (LHOOK) CALL DR_HOOK('INI_CSTS',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE INI_CSTS + + +END MODULE MODI_INI_CSTS diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_csts.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_csts.F new file mode 100644 index 000000000..32e1f69d6 --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_csts.F @@ -0,0 +1,95 @@ +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ############### + MODULE MODD_CSTS +! ############### +! +!!**** *MODD_CSTS* - declaration of Physic constants +!! +!! PURPOSE +!! ------- +! The purpose of this declarative module is to declare the +! Physics constants. +! +!! +!!** IMPLICIT ARGUMENTS +!! ------------------ +!! None +!! +!! REFERENCE +!! --------- +!! +!! AUTHOR +!! ------ +!! V. Ducrocq *Meteo France* +!! +!! MODIFICATIONS +!! ------------- +!! Original 16/05/94 +!! J. Stein 02/01/95 add xrholw +!! J.-P. Pinty 13/12/95 add XALPI,XBETAI,XGAMI +!! J. Stein 25/07/97 add XTH00 +!! V. Masson 05/10/98 add XRHOLI +!! C. Mari 31/10/00 add NDAYSEC +!! J. Escobar 06/13 add XSURF_TIMY XSURF_TIMY_12 XSURF_EPSILON for REAL*4 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +IMPLICIT NONE +REAL,SAVE :: XPI ! Pi +! +REAL,SAVE :: XDAY,XSIYEA,XSIDAY ! day duration, sideral year duration, + ! sideral day duration +! +REAL,SAVE :: XKARMAN ! von karman constant +REAL,SAVE :: XLIGHTSPEED ! light speed +REAL,SAVE :: XPLANCK ! Planck constant +REAL,SAVE :: XBOLTZ ! Boltzman constant +REAL,SAVE :: XAVOGADRO ! Avogadro number +! +REAL,SAVE :: XRADIUS,XOMEGA ! Earth radius, earth rotation +REAL,SAVE :: XG ! Gravity constant +! +REAL,SAVE :: XP00 ! Reference pressure +! +REAL,SAVE :: XSTEFAN,XI0 ! Stefan-Boltzman constant, solar constant +! +REAL,SAVE :: XMD,XMV ! Molar mass of dry air and molar mass of vapor +REAL,SAVE :: XRD,XRV ! Gaz constant for dry air, gaz constant for vapor +REAL,SAVE :: XCPD,XCPV ! Cpd (dry air), Cpv (vapor) +REAL,SAVE :: XRHOLW ! Volumic mass of liquid water +REAL,SAVE :: XCL,XCI ! Cl (liquid), Ci (ice) +REAL,SAVE :: XTT ! Triple point temperature +REAL,SAVE :: XTTSI ! Temperature of ice fusion over salty sea +REAL,SAVE :: XTTS ! Equivalent temperature of ice fusion over a mixed of sea and sea-ice +REAL,SAVE :: XICEC ! Threshold fraction over which the tile is considered as only covered with ice +REAL,SAVE :: XLVTT ! Vaporization heat constant +REAL,SAVE :: XLSTT ! Sublimation heat constant +REAL,SAVE :: XLMTT ! Melting heat constant +REAL,SAVE :: XESTT ! Saturation vapor pressure at triple point + ! temperature +REAL,SAVE :: XALPW,XBETAW,XGAMW ! Constants for saturation vapor + ! pressure function +REAL,SAVE :: XALPI,XBETAI,XGAMI ! Constants for saturation vapor + ! pressure function over solid ice +REAL, SAVE :: XTH00 ! reference value for the potential + ! temperature +REAL,SAVE :: XRHOLI ! Volumic mass of ice +REAL,SAVE :: XCONDI ! thermal conductivity of ice (W m-1 K-1) +! +INTEGER, SAVE :: NDAYSEC ! Number of seconds in a day +! +REAL,SAVE :: XSURF_TINY ! minimum real on this machine +REAL,SAVE :: XSURF_TINY_12 ! sqrt(minimum real on this machine) +REAL,SAVE :: XSURF_EPSILON ! minimum space with 1.0 + +REAL,SAVE :: XZ0ICEZ0SNOW, XRHOTHRESHOLD_ICE + + +! +END MODULE MODD_CSTS + diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_metamo.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_metamo.F new file mode 100644 index 000000000..e48dd6ccd --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_metamo.F @@ -0,0 +1,151 @@ +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ajoutEB +! correction de l'erreur interversion de XVTANG2 et XVTANG3 +!###################### + MODULE MODD_SNOW_METAMO +! ###################### +! +!!**** *MODD_SNOW_METAMO* - declaration of parameters related +!! to snow metamorphism!! +!! PURPOSE +!! ------- +! The purpose of this declarative module is to specify the +! parameters related to the metamorphism parameterization of snow. +! +!! +!!** IMPLICIT ARGUMENTS +!! ------------------ +!! None +!! +!! REFERENCE +!! --------- +!! +!! +!! AUTHOR +!! ------ +!! V. Vionnet *Meteo France* +!! +!! MODIFICATIONS +!! ------------- +!! Original 02/2008 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +IMPLICIT NONE +! +!------------------------------------------------------------------------------- +! +! minimum snow layer thickness for thermal calculations. +! Used to prevent numerical problems as snow becomes vanishingly thin. +REAL, PARAMETER :: XSNOWDZMIN = 0.0001 +! +! Optical diameter properties +REAL, PARAMETER :: XDIAET = 1.E-4 +REAL, PARAMETER :: XDIAGF = 3.E-4 +REAL, PARAMETER :: XDIAFP = 4.E-4 +! +! Compaction/Settling Coefficients from Crocus v2.4 +! +REAL, PARAMETER :: XVVISC1 = 7.62237E6 ! pre-exponential viscosity factor (UNIT : N m-2 s) +REAL, PARAMETER :: XVVISC3 = 0.023 ! density adjustement in the exponential correction for viscosity (UNIT : m3 kg-1) +REAL, PARAMETER :: XVVISC4 = .1 ! temperature adjustement in the exponential correction for viscosity (UNIT : K-1) +REAL, PARAMETER :: XVVISC5 = 1. ! factor for viscosity adjustement to grain type - to be checked +REAL, PARAMETER :: XVVISC6 = 60. ! factor for viscosity adjustement to grain type - to be checked +! (especially this one ; inconsistency with Crocus v2.4) +REAL, PARAMETER :: XVVISC7 = 10. ! factor for viscosity adjustement to grain type - to be checked +REAL, PARAMETER :: XVRO11 = 250. ! normalization term for density dependence of the viscosity calculation (UNIT : kg m-3) +! +! Maximum value for TPSNOW%GRAN2 +REAL, PARAMETER :: XVGRAN1 = 99. +REAL, PARAMETER :: XGRAN = 99. +! +INTEGER, PARAMETER :: NVHIS1 = 1 +INTEGER, PARAMETER :: NVHIS2 = 2 +INTEGER, PARAMETER :: NVHIS3 = 3 +INTEGER, PARAMETER :: NVHIS4 = 4 +INTEGER, PARAMETER :: NVHIS5 = 5 +! +! Properties of fresh snow +REAL, PARAMETER :: XNDEN1 = 17.12 +REAL, PARAMETER :: XNDEN2 = 128. +REAL, PARAMETER :: XNDEN3 = -20. +REAL, PARAMETER :: XNSPH1 = 7.87 +REAL, PARAMETER :: XNSPH2 = 38. +REAL, PARAMETER :: XNSPH3 = 50. +REAL, PARAMETER :: XNSPH4 = 90. +! +REAL, PARAMETER :: XUEPSI = 1.E-8 +REAL, PARAMETER :: XEPSI = 1.E-8 +REAL, PARAMETER :: XUPOURC = 100. +! +! Parameters for Marbouty's function +! +REAL, PARAMETER :: XVTANG1 = 40. +REAL, PARAMETER :: XVTANG2 = 6. +REAL, PARAMETER :: XVTANG3 = 22. +REAL, PARAMETER :: XVTANG4 = .7 +REAL, PARAMETER :: XVTANG5 = .3 +REAL, PARAMETER :: XVTANG6 = 6. +REAL, PARAMETER :: XVTANG7 = 1. +REAL, PARAMETER :: XVTANG8 = .8 +REAL, PARAMETER :: XVTANG9 = 16. +REAL, PARAMETER :: XVTANGA = .2 +REAL, PARAMETER :: XVTANGB = .2 +REAL, PARAMETER :: XVTANGC = 18. +REAL, PARAMETER :: XVRANG1 = 400. +REAL, PARAMETER :: XVRANG2 = 150. +REAL, PARAMETER :: XVGANG1 = 70. +REAL, PARAMETER :: XVGANG2 = 25. +REAL, PARAMETER :: XVGANG3 = 40. +REAL, PARAMETER :: XVGANG4 = 50. +REAL, PARAMETER :: XVGANG5 = .1 +REAL, PARAMETER :: XVGANG6 = 15. +REAL, PARAMETER :: XVGANG7 = .1 +REAL, PARAMETER :: XVGANG8 = .55 +REAL, PARAMETER :: XVGANG9 = .65 +REAL, PARAMETER :: XVGANGA = .2 +REAL, PARAMETER :: XVGANGB = .85 +REAL, PARAMETER :: XVGANGC = .15 +! +! Parameters for snow metamorphism +! +REAL, PARAMETER :: XVDENT1 = 2314.81481 +REAL, PARAMETER :: XVDENT2 = 7.2338E-7 +REAL, PARAMETER :: XVGRAN6 = 51. +REAL, PARAMETER :: XVVAP1 = -6000. +REAL, PARAMETER :: XVVAP2 = .4 +REAL, PARAMETER :: XVDIAM1 = 4.E-4 +REAL, PARAMETER :: XVDIAM2 = 5.E-4 +REAL, PARAMETER :: XVDIAM3 = 3.E-4 +REAL, PARAMETER :: XVDIAM4 = 2.E-4 +REAL, PARAMETER :: XVDIAM5 = 1.E-4 +REAL, PARAMETER :: XVDIAM6 = 1.E-4 +REAL, PARAMETER :: XVSPHE1 = 1. +REAL, PARAMETER :: XVSPHE2 = 11574.074 +REAL, PARAMETER :: XVSPHE3 = .5 +REAL, PARAMETER :: XVSPHE4 = .1 +REAL, PARAMETER :: XVTAIL1 = 1.28E-17 +REAL, PARAMETER :: XVTAIL2 = 4.22E-19 +REAL, PARAMETER :: XVGRAT1 = 5. +REAL, PARAMETER :: XVGRAT2 = 15. +REAL, PARAMETER :: XVFI = 1.0417E-9 +REAL, PARAMETER :: XVTELV1 = 0.005 +! +INTEGER,PARAMETER :: NVDENT1 = 3 +! +INTEGER :: NVARDIMS !number of dimensions of netcdf input variable +INTEGER :: NLENDIM1,NLENDIM2,NLENDIM3 +INTEGER :: NID_VAR ! Netcdf IDs for variable +! +INTEGER :: NID_FILE +REAL, DIMENSION(:,:,:), POINTER :: XDRDT0,XTAU,XKAPPA ! field read +! +END MODULE MODD_SNOW_METAMO + + + diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_par.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_par.F new file mode 100644 index 000000000..35ab52d38 --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_snow_par.F @@ -0,0 +1,403 @@ +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ###################### + MODULE MODD_SNOW_PAR +! ###################### +! +!!**** *MODD_SNOW_PAR* - declaration of parameters related +!! to the snow parameterization +!! +!! PURPOSE +!! ------- +! The purpose of this declarative module is to specify the +! parameters related to the surface parameterization of snow. +! +!! +!!** IMPLICIT ARGUMENTS +!! ------------------ +!! None +!! +!! REFERENCE +!! --------- +!! +!! +!! AUTHOR +!! ------ +!! V. Masson *Meteo France* +!! +!! MODIFICATIONS +!! ------------- +!! Original 01/2004 +!! P. Samuelsson 10/2014 MEB complements +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +IMPLICIT NONE +! +!-------------------------------------------------------------------------------- +! Snow on the ground: Given in ini_surf_csts and/or in NAM_SURF_CSTS +!-------------------------------------------------------------------------------- +! +! Snow emissivity: +! +!REAL, SAVE :: XEMISSN +REAL, PARAMETER :: XEMISSN = 0.99 ! trude. Check how this stands up to ini_sfc_csts. +! +! Minimum and maximum values of the albedo of snow: +! +!REAL, SAVE :: XANSMIN +!REAL, SAVE :: XANSMAX +REAL, PARAMETER :: XANSMIN=0.50 ! (orig 0.50, trude test with 0.55 (0.6)) ! trude +REAL, PARAMETER :: XANSMAX =0.85 !trude + + +! +! Minimum and maximum values of the albedo of permanet snow/ice: +! +!REAL, SAVE :: XAGLAMIN +!REAL, SAVE :: XAGLAMAX +REAL, PARAMETER :: XAGLAMIN = 0.8 ! trude +REAL, PARAMETER :: XAGLAMAX = 0.85 ! trude + +! +! Use recommended settings for snow albedo (FALSE = ISBA default) +! +LOGICAL,SAVE :: LMEBREC +! +! Fraction of maximum value of the albedo of snow that is reached for melting +! snow +! +REAL, SAVE :: XANSFRACMEL +! +! Threeshold temperature above which the snow albedo starts to decrease +! +REAL, SAVE :: XTEMPANS +! +! Minimum value of the albedo of snow reached under canopy vegetation: +! +REAL, SAVE :: XANSMINMEB +! +! Prescribed ice albedo in 3 spectral bands for glacier simulation with CROCUS scheme. +!REAL, SAVE :: XALBICE1,XALBICE2,XALBICE3 +!REAL, PARAMETER :: XALBICE1 = 0.23 ! (0.23 from Gerbaux, 0.38 orig crocus) ! trude +!REAL, PARAMETER :: XALBICE2 = 0.15 ! (0.15 from Gerbaux, 0.23 orig crocus) ! trude +!REAL, PARAMETER :: XALBICE3 = 0.06 ! 0.06 from Gerbaux , 0.08 orig crocus ! trude +REAL, PARAMETER :: XALBICE1 = 0.38 ! (0.23 from Gerbaux, 0.38 orig crocus) ! trude +REAL, PARAMETER :: XALBICE2 = 0.23 ! (0.15 from Gerbaux, 0.23 orig crocus) ! trude +REAL, PARAMETER :: XALBICE3 = 0.08 ! 0.06 from Gerbaux , 0.08 orig crocus ! trude + +!REAL, PARAMETER :: XALBICE1 = 0.67 ! (0.23 from Gerbaux, 0.38 orig crocus) ! trude test snowalbedo instead +!REAL, PARAMETER :: XALBICE2 = 0.67 ! (0.15 from Gerbaux, 0.23 orig crocus) ! trude +!REAL, PARAMETER :: XALBICE3 = 0.67 ! 0.06 from Gerbaux , 0.08 orig crocus ! trude + +! + +! Density threshold for ice detection in CROCUS scheme. +!REAL, SAVE :: XRHOTHRESHOLD_ICE ! trude comment out in modd_csts + +!for ageing effects +!REAL, SAVE :: XVAGING_NOGLACIER, XVAGING_GLACIER +REAL, PARAMETER :: XVAGING_NOGLACIER = 60. +REAL, PARAMETER :: XVAGING_GLACIER = 900. + +! percentage of the total pore volume to compute the max liquid water holding capacity +!REAL, SAVE :: XPERCENTAGEPORE +REAL, PARAMETER :: XPERCENTAGEPORE = 0.03 ! 5 ! trude try 3 instead of 5. +!REAL, PARAMETER :: XPERCENTAGEPORE = 0.05 ! 5 ! trude try 3 instead of 5. +! Height (m) of aged snow in glacier case (allows Pn=1) +! +REAL, SAVE :: XHGLA +! +! Coefficient for calculation of snow fraction over vegetation +! +REAL, SAVE :: XWSNV +! +! Roughness length of pure snow surface (m) +! +!REAL, SAVE :: XZ0SN +!REAL, PARAMETER :: XZ0SN =0.00005 ! trude, (0.05 mm) +!REAL, PARAMETER :: XZ0SN =0.00013 ! trude, (0.13 mm) +REAL, PARAMETER :: XZ0SN =0.001 ! trude, (1.0 mm) +!REAL, PARAMETER :: XZ0SN =0.0002 ! trude, (0.2 mm) +! Roughness length for heat of pure snow surface (m) +! +!REAL, SAVE :: XZ0HSN +REAL, PARAMETER :: XZ0HSN =0.00015 ! trude (test 5 mm instead of 0.5 mm) +!REAL, PARAMETER :: XZ0HSN =0.0001 ! orignal in surfex is 0.0001 + + +! Roughness length ratio between ice and snow +!REAL, SAVE :: XZ0ICEZ0SNOW ! trude comment out. declared in modd_csts +! +! Snow Melt timescale with D95 (s): needed to prevent time step +! dependence of melt when snow fraction < unity. +! +REAL, SAVE :: XTAU_SMELT +! +!-------------------------------------------------------------------------------- +! Snow on the ground: PARAMETER +!-------------------------------------------------------------------------------- +! +! Critical value of the equivalent water content +! of the snow reservoir for snow fractional coverage and albedo computations +! +REAL, PARAMETER :: XWCRN = 10.0 ! (kg m-2) Veg (default value) +REAL, PARAMETER :: XWCRN_EXPL = 1.0 ! (kg m-2) Veg explicit +REAL, PARAMETER :: XWCRN_ROOF = 1.0 ! (kg m-2) Roofs +REAL, PARAMETER :: XWCRN_ROAD = 1.0 ! (kg m-2) Roads +REAL, PARAMETER :: XWCRN_VEG = 1.0 ! (kg m-2) Urban veg +! +! Critical value of the total snow depth for ground snow fractional coverage +! +REAL, PARAMETER :: XDCRN_EXPL = 0.01 ! (m) Veg explicit +! +! Critical value of snow emissivity +! +REAL, PARAMETER :: XEMCRIN = 0.98 +! +! Minimum and maximum values of the albedo of snow: +! +REAL, PARAMETER :: XANSMIN_ROOF = 0.30 ! (-) Roofs +REAL, PARAMETER :: XANSMIN_ROAD = 0.15 ! (-) Roads +! +REAL, PARAMETER :: XANSMAX_ROOF = 0.85 ! (-) Roofs +REAL, PARAMETER :: XANSMAX_ROAD = 0.85 ! (-) Roads +! +! Snow aging coefficients (albedo and Force-Restore density): +! +REAL, PARAMETER :: XANS_TODRY = 0.008 ! (-) Veg (default value) +REAL, PARAMETER :: XANS_TODRY_ROOF = 0.008 ! (-) Roofs +REAL, PARAMETER :: XANS_TODRY_ROAD = 0.008 ! (-) Roads +REAL, PARAMETER :: XANS_TODRY_MEB = 0.016 ! (-) Surface under canopy vegetation +! +REAL, PARAMETER :: XANS_T = 0.240 ! (-) Veg (default value) +REAL, PARAMETER :: XANS_T_ROOF = 0.174 ! (-) Roofs +REAL, PARAMETER :: XANS_T_ROAD = 0.174 ! (-) Roads (alley simul) +REAL, PARAMETER :: XANS_T_MEB = 0.480 ! (-) Surface under canopy vegetation +! +! Minimum and maximum values of the density of snow +! for Force-Restore snow option +! +REAL, PARAMETER :: XRHOSMIN = 100. ! (kg m-3) Veg (Default value) +REAL, PARAMETER :: XRHOSMIN_ROOF = 100. ! (kg m-3) Roofs +REAL, PARAMETER :: XRHOSMIN_ROAD = 100. ! (kg m-3) Roads +! +REAL, PARAMETER :: XRHOSMAX = 300. ! (kg m-3) Veg (Default value) +REAL, PARAMETER :: XRHOSMAX_ROOF = 300. ! (kg m-3) Roofs +REAL, PARAMETER :: XRHOSMAX_ROAD = 350. ! (kg m-3) Roads +! +! Minimum and maximum values of the density of snow +! for ISBA-ES snow option +! +REAL, PARAMETER :: XRHOSMIN_ES = 50. ! (kg m-3) +REAL, PARAMETER :: XRHOSMAX_ES = 750. ! (kg m-3) +! +! ISBA-ES Critical snow depth at which snow grid thicknesses constant +! +REAL, PARAMETER :: XSNOWCRITD = 0.03 ! (m) +! +! ISBA-ES Minimum total snow depth for thermal calculations. +! Used to prevent numerical problems as snow becomes vanishingly thin. +! +REAL, PARAMETER :: XSNOWDMIN = 0.000001 ! (m) +! +! Maximum Richardson number limit for very stable conditions using the ISBA-ES 'RIL' option +! +REAL, PARAMETER :: X_RI_MAX = 0.20 +!REAL, PARAMETER :: X_RI_MAX = 0.026 ! trude test lower limit +! +! ISBA-ES Maximum snow liquid water holding capacity (fraction by mass) parameters: +! +REAL, PARAMETER :: XWSNOWHOLDMAX2 = 0.10 ! (-) +REAL, PARAMETER :: XWSNOWHOLDMAX1 = 0.03 ! (-) +REAL, PARAMETER :: XSNOWRHOHOLD = 200.0 ! (kg/m3) +! +! ISBA-ES arameters for grain size computation : +! +REAL, PARAMETER :: XSNOW_AGRAIN = 1.6e-4 ! (m) +REAL, PARAMETER :: XSNOW_BGRAIN = 1.1e-13 ! (m13/kg4) +REAL, PARAMETER :: XSNOW_CGRAIN = 0.5e-4 ! (m) +REAL, PARAMETER :: XDSGRAIN_MAX = 2.796e-3 ! m +! +!-------------------------------------------------------------------------------- +! Calibration coefficients for CROCUS and ES albedo computation +!-------------------------------------------------------------------------------- +! +REAL, PARAMETER :: XD1 = 1., XD2 = 3., XD3 = 4., XX = 99., & + XVALB2 = .96, XVALB3 = 1.58, XVALB4 = .92, XVALB5 = .90, & + XVALB6 = 15.4, XVALB7 = 346.3, XVALB8 = 32.31, XVALB9 = .88, & + XVALB10 = .200, XVALB11 = .65, XVDIOP1 = 2.3E-3, XVRPRE1 = .5, & + XVRPRE2=1.5 + +! trude , test XVALB11 = 0.7 instead of 0.6 +! trude , test XVALB11 = 0.65 instead of 0.6 + +! for ageing effects: +REAL, PARAMETER :: XVPRES1 = 87000. +! +! spectral bands +! +INTEGER, PARAMETER :: NSPEC_BAND_SNOW = 3 +! +! for spectral distribution and thickness effects +REAL, PARAMETER :: XVSPEC1 = .71, XVSPEC2 = .21, XVSPEC3 = .08 +! +! for thickness effects +REAL, PARAMETER :: XVW1 = .80, XVW2 = .20 , XVD1 = .02, XVD2 = .01 +! +!-------------------------------------------------------------------------------- +! calibration coefficients for exctinction computation +REAL, PARAMETER :: XVBETA1 = 1.92E-3, XVBETA2 = 40., XVBETA3 = 1.098E-2, & + XVBETA4 = 100., XVBETA5 = 2000. +! +! ISBA-ES minimum cosinus of zenithal angle +REAL, PARAMETER :: XMINCOSZEN = 0.01 +! +!-------------------------------------------------------------------------------- +! ISBA-ES Thermal conductivity coefficients from Anderson (1976): +! see Boone, Meteo-France/CNRM Note de Centre No. 70 (2002) +! +REAL, PARAMETER :: XSNOWTHRMCOND1 = 0.02 ! [W/(m K)] +REAL, PARAMETER :: XSNOWTHRMCOND2 = 2.5E-6 ! [W m5/(kg2 K)] +! +! ISBA-ES Thermal conductivity: Implicit vapor diffn effects +! (sig only for new snow OR high altitudes) +! from Sun et al. (1999): based on data from Jordan (1991) +! see Boone, Meteo-France/CNRM Note de Centre No. 70 (2002) +! +REAL, PARAMETER :: XSNOWTHRMCOND_AVAP = -0.06023 ! [W/(m K)] +REAL, PARAMETER :: XSNOWTHRMCOND_BVAP = -2.5425 ! (W/m) +REAL, PARAMETER :: XSNOWTHRMCOND_CVAP = -289.99 ! (K) +! +! Crocus thermal conducitivity coefficient from Yen (1981) +REAL, PARAMETER :: XVRKZ6 = 1.88 +! +!-------------------------------------------------------------------------------- +! ISBA-ES CROCUS (Pahaut 1976): snowfall density coefficients: +! +REAL, PARAMETER :: XSNOWFALL_A_SN = 109.0 ! kg/m3 +REAL, PARAMETER :: XSNOWFALL_B_SN = 6.0 ! kg/(m3 K) +REAL, PARAMETER :: XSNOWFALL_C_SN = 26.0 ! kg/(m7/2 s1/2) +! +! Coefficients for the optimal vertical grid calculation +REAL, PARAMETER :: XDZ1 = 0.01 +REAL, PARAMETER :: XDZ2 = 0.0125 +REAL, PARAMETER :: XDZ3 = 0.015 +REAL, PARAMETER :: XDZ3_BIS = 0.03 +REAL, PARAMETER :: XDZ4 = 0.04 +REAL, PARAMETER :: XDZ5 = 0.05 +REAL, PARAMETER :: XDZ_BASE = 0.02 +REAL, PARAMETER :: XDZ_INTERNAL = 0.07 +REAL, PARAMETER :: XSCALE_CM = 100. +REAL,DIMENSION(5), PARAMETER :: XDZMAX_INTERNAL = (/0.5,1.,2.,4.,10./) +REAL, PARAMETER :: XDZMIN_TOP_EXTREM = 0.0001 +! +! Below this threshold of snowfall, new snowfall are aggregated with surface layer to avoid numerical problems +! (0.03 mm/h) +REAL,PARAMETER :: XSNOWFALL_THRESHOLD = 0.0333/3600. + +! The ratio between a new surface layer thickness and the second layer surface thickness is limited to 1/10 +REAL,PARAMETER :: XRATIO_NEWLAYER = 0.1 + +! Coefficients for cases with very thick snowpacks +REAL, PARAMETER :: XDEPTH_THRESHOLD1 = 3. +REAL, PARAMETER :: XDEPTH_THRESHOLD2 = 20. +REAL, PARAMETER :: XDEPTH_SURFACE = 3. +! +! Coefficients for computing the difference in 2 snow layer characteristics +REAL, PARAMETER :: XDIFF_1 = 20. +REAL, PARAMETER :: XDIFF_MAX = 200. +REAL, PARAMETER :: XSCALE_DIFF = 25. +! +! Coeefficients for snow layer splitting +REAL, PARAMETER :: XDZMIN_TOP = 0.01 +REAL, PARAMETER :: XDZMIN_TOP_BIS = 0.005 +REAL, PARAMETER :: XDZMIN_BOT = 0.02 +REAL, PARAMETER :: XSPLIT_COEF = 8. +! +! Coeefficients for snow layer agregation +REAL, PARAMETER :: XAGREG_COEF_1 = 5. +REAL, PARAMETER :: XAGREG_COEF_2 = 4.5 +! +!-------------------------------------------------------------------------------- +! +! Calibration coefficients +REAL, PARAMETER :: XVTIME = 48*3600. ! characteristic time for +!compaction and metamorphism by wind drift +! +REAL, PARAMETER :: XVROMAX = 350. ! maximum density for +! drift compaction UNIT : kg m-3 +REAL, PARAMETER :: XVROMIN = 50. ! minimum density for +! mobility computation UNIT : kg m-3 +REAL, PARAMETER :: XVMOB1 = 0.295 ! coefficient for computing +! the mobility index +REAL, PARAMETER :: XVMOB2 = 0.833 ! coefficient for computing +! the mobility index +REAL, PARAMETER :: XVMOB3 = 0.583 ! coefficient for computing +! the mobility index +REAL, PARAMETER :: XVMOB4 = -0.0583 ! coefficient for computing +! the mobility index +REAL, PARAMETER :: XVDRIFT1 = 2.868 ! coefficient for computing +! the drift index +REAL, PARAMETER :: XVDRIFT2 = 0.085 ! coefficient for computing +! the drift index +REAL, PARAMETER :: XVDRIFT3 = 3.25 ! coefficient for computing +! the drift index +REAL, PARAMETER :: XVSIZEMIN = 3.E-4 ! minimum size decrease +! by drift UNIT = m +! +! modif_EB pour sublim +! a pour but de tenir compte du fait que le vent moyen est > rafales +! on en tient compte egalement pour diminuer la duree de l'effet +REAL, PARAMETER :: XCOEF_FF = 1.25 ! coefficient for gust diagnosis from average wind +REAL, PARAMETER :: XCOEF_EFFECT = 1.0 ! coefficient for impact on density du drift +REAL, PARAMETER :: XQS_REF = 2.E-5 ! valeur de reference de ZQS pour effet neige +! +!-------------------------------------------------------------------------------- +! +! ISBA-ES snow grid parameters +! +REAL, PARAMETER, DIMENSION(3) :: XSGCOEF1 = (/0.25, 0.50, 0.25/) +REAL, PARAMETER, DIMENSION(2) :: XSGCOEF2 = (/0.05, 0.34/) +REAL, PARAMETER, DIMENSION(10) :: XSGCOEF3 = (/0.025, 0.033, 0.043, & + 0.055, 0.071, 0.091, 0.117, 0.150, & + 0.193, 0.247/) +! +! Minimum total snow depth at which surface layer thickness is constant: +! +REAL, PARAMETER :: XSNOWTRANS = 0.20 ! (m) +REAL, PARAMETER :: XSNOWTRANS1 = 0.40 ! (m) +REAL, PARAMETER :: XSNOWTRANS2 = 0.6061 ! (m) +REAL, PARAMETER :: XSNOWTRANS3 = 0.7143 ! (m) +REAL, PARAMETER :: XSNOWTRANS4 = 0.9259 ! (m) +REAL, PARAMETER :: XSNOWTRANS5 = 1.4493 ! (m) + +! * qsat computation +! + CHARACTER(LEN=3), PARAMETER :: CQSAT = 'NEW' ! qsat computation option +! ! 'OLD' = do not depend on temperature +! ! 'NEW' = qsat and qsati merged (recommended) +! +REAL, PARAMETER :: XUNDEF = 1.E+20 + + +! +!------------------------------------------------------------------------------ +! +END MODULE MODD_SNOW_PAR + + + + + + + + + + + + diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_surf_atm.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_surf_atm.F new file mode 100644 index 000000000..572db9ccb --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/modd_surf_atm.F @@ -0,0 +1,88 @@ +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! #################### + MODULE MODD_SURF_ATM +! #################### +! +!!**** *MODD_SURF_ATM - declaration of surface ATM +!! +!! PURPOSE +!! ------- +! Declaration of surface parameters +! +!! +!!** IMPLICIT ARGUMENTS +!! ------------------ +!! None +!! +!! REFERENCE +!! --------- +!! +!! AUTHOR +!! ------ +!! P. Le Moigne *Meteo France* +!! +!! MODIFICATIONS +!! ------------- +!! Original 10/2007 +! +!* 0. DECLARATIONS +! ------------ +! +!! B.Decharme 04/2009 Add flag used to Read/Write precipitation forcing from/into the restart file for ARPEGE/ALADIN run +!! B.Decharme 08/2009 Add flag used to know if you use SURFEX in the Earth System Model +!! B.Decharme 09/2012 New wind implicitation key option +!! B.Decharme 04/2013 Flag used to Read/Write some field from/into the restart file for coupling with ARPEGE/ALADIN +!! Delete LRW_PRECIP, LSAVE_PRECIP +!! Vertical shift for LW and Precip +!! R. Séférian 03/2014 Adding key for decouple CO2 for photosynthesis (XCO2UNCPL) +! +IMPLICIT NONE +! +!----------------------------------------------------------------------------------------------------- +REAL,PARAMETER :: XCISMIN=6.7e-5 ! minimum wind shear +REAL,PARAMETER :: XVMODMIN=0.0 ! minimum wind speed +LOGICAL,PARAMETER :: LALDTHRES=.FALSE. ! activate aladin threshold for wind +! +LOGICAL :: LDRAG_COEF_ARP ! activate aladin formulation for Cd and Ch +LOGICAL :: LALDZ0H +! +LOGICAL :: LNOSOF ! No parameterization of Subgrid Orography effects on atmospheric Forcing +LOGICAL :: LVERTSHIFT ! vertical shift from atmospheric orography to surface orography +LOGICAL :: LVSHIFT_LW ! vertical shift for LW +LOGICAL :: LVSHIFT_PRCP ! vertical shift for Precip +! +LOGICAL :: LVZIUSTAR0_ARP ! activate aladin formulation for zoh over sea +LOGICAL :: LRRGUST_ARP ! activate aladin formulation for CD CH, CDN, correction due to moist gustiness +LOGICAL :: LCPL_ARP ! activate aladin formulation for Cp and L +LOGICAL :: LQVNPLUS ! An option for the resolution of the surface temperature equation +! +LOGICAL :: LCPL_GCM ! Flag used to Read/Write some field from/into the restart file for coupling with ARPEGE/ALADIN +! +REAL :: XEDB +REAL :: XEDC +REAL :: XEDD +REAL :: XEDK +REAL :: XUSURIC +REAL :: XUSURID +REAL :: XUSURICL +REAL :: XVCHRNK +REAL :: XVZ0CM +REAL,PARAMETER :: XRIMAX=0.2 +REAL :: XDELTA_MAX ! Maximum fraction of the foliage covered by intercepted water for high vegetation +! +REAL :: XWINDMIN ! minimum wind speed (canopy) +! +REAL :: XRZHZ0M +REAL :: XVZIUSTAR0 +REAL :: XRRSCALE +REAL :: XRRGAMMA +REAL :: XUTILGUST +! +REAL :: XCO2UNCPL ! uncoupled CO2 values (ppmv) +! +!----------------------------------------------------------------------------------------------------- +! +END MODULE MODD_SURF_ATM diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_snow3l.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_snow3l.F new file mode 100644 index 000000000..1e303f50d --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_snow3l.F @@ -0,0 +1,2360 @@ +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ################## + MODULE MODE_SNOW3L +! ################## +! +!!**** *MODE_SNOW * - contains explicit snow (ISBA-ES) characteristics functions +!! for total liquid water holding capacity of a snow layer (m) +!! and the thermal heat capacity of a layer (J K-1 m-3) +!! +!! PURPOSE +!! ------- +! +!!** METHOD +!! ------ +!! direct calculation +!! +!! EXTERNAL +!! -------- +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! REFERENCE +!! --------- +!! Boone and Etchevers, J. HydroMeteor., 2001 +!! +!! +!! AUTHOR +!! ------ +!! A. Boone * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 01/08/02 +!! V. Masson 01/2004 add snow grid computations +!! V. Vionnet 06/2008 -Introduction of Crocus formulation to +! calculate maximum liquid water holding capacity +!! - New algorithm to compute snow grid : +! 10 layers +!! - Routine to aggregate snow grain type +! from 2 layers +!! _ Routine to compute average grain +! type when snow depth< 3 cm. +! S. Morin 02/2011 - Add routines for Crocus +! A. Boone 02/2012 - Add optimization of do-loops. +! C. Carmagnola 12/2012 - Add the case CSNOWMETAMO!='B92' in subroutine SNOW3LAVGRAIN and in function SNOW3LDIFTYP +! M. Lafaysse 01/2013 - Remove SNOWCROWLIQMAX routines (not used) +! M. Lafaysse 08/2013 - simplification of routine SNOW3LAVGRAIN (logical GDENDRITIC) +! B. Decharme 07/2013 - SNOW3LGRID cleanning +! New algorithm to compute snow grid for 6-L or 12-L +! A. Boone 10/2014 - Added snow thermal conductivity routines +! B. Decharme 01/2015 - Added optical snow grain size diameter +!---------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! +! +INTERFACE SNOW3LWLIQMAX + MODULE PROCEDURE SNOW3LWLIQMAX_3D + MODULE PROCEDURE SNOW3LWLIQMAX_2D + MODULE PROCEDURE SNOW3LWLIQMAX_1D +END INTERFACE +! +INTERFACE SNOW3LHOLD + MODULE PROCEDURE SNOW3LHOLD_3D + MODULE PROCEDURE SNOW3LHOLD_2D + MODULE PROCEDURE SNOW3LHOLD_1D + MODULE PROCEDURE SNOW3LHOLD_0D +END INTERFACE +INTERFACE SNOWCROHOLD + MODULE PROCEDURE SNOWCROHOLD_3D + MODULE PROCEDURE SNOWCROHOLD_2D + MODULE PROCEDURE SNOWCROHOLD_1D + MODULE PROCEDURE SNOWCROHOLD_0D +END INTERFACE +! +INTERFACE SNOW3LSCAP + MODULE PROCEDURE SNOW3LSCAP_3D + MODULE PROCEDURE SNOW3LSCAP_2D + MODULE PROCEDURE SNOW3LSCAP_1D + MODULE PROCEDURE SNOW3LSCAP_0D +END INTERFACE +! +INTERFACE SNOW3L_MARBOUTY + MODULE PROCEDURE SNOW3L_MARBOUTY +END INTERFACE +! +INTERFACE SNOW3LGRID + MODULE PROCEDURE SNOW3LGRID_2D + MODULE PROCEDURE SNOW3LGRID_1D +END INTERFACE +! +INTERFACE SNOW3LAGREG + MODULE PROCEDURE SNOW3LAGREG +END INTERFACE +! +INTERFACE SNOW3LAVGRAIN + MODULE PROCEDURE SNOW3LAVGRAIN +END INTERFACE +! +INTERFACE SNOW3LDIFTYP + MODULE PROCEDURE SNOW3LDIFTYP +END INTERFACE +! +INTERFACE GET_MASS_HEAT + MODULE PROCEDURE GET_MASS_HEAT +END INTERFACE +! +INTERFACE GET_DIAM + MODULE PROCEDURE GET_DIAM +END INTERFACE +! +! +INTERFACE SNOW3LTHRM + MODULE PROCEDURE SNOW3LTHRM +END INTERFACE +! +INTERFACE SNOW3LDOPT + MODULE PROCEDURE SNOW3LDOPT_2D + MODULE PROCEDURE SNOW3LDOPT_1D + MODULE PROCEDURE SNOW3LDOPT_0D +END INTERFACE +! +INTERFACE SNOW3LALB + MODULE PROCEDURE SNOW3LALB +END INTERFACE +! +!------------------------------------------------------------------------------- + CONTAINS +! +!#################################################################### + FUNCTION SNOW3LWLIQMAX_3D(PSNOWRHO) RESULT(PWLIQMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES, XSNOWRHOHOLD, & + XWSNOWHOLDMAX2, XWSNOWHOLDMAX1 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:,:), INTENT(IN) :: PSNOWRHO ! (kg/m3) +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2),SIZE(PSNOWRHO,3)) :: PWLIQMAX ! (kg/m3) +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2),SIZE(PSNOWRHO,3)) :: ZHOLDMAXR, ZSNOWRHO +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!----------------------------------------------------------------------- +! Evaluate capacity using upper density limit: +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LWLIQMAX_3D',0,ZHOOK_HANDLE) +ZSNOWRHO(:,:,:) = MIN(XRHOSMAX_ES, PSNOWRHO(:,:,:)) +! +! Maximum ratio of liquid to SWE: +! +ZHOLDMAXR(:,:,:) = XWSNOWHOLDMAX1 + (XWSNOWHOLDMAX2-XWSNOWHOLDMAX1)* & + MAX(0.,XSNOWRHOHOLD-ZSNOWRHO(:,:,:))/XSNOWRHOHOLD +! +! Maximum liquid water holding capacity of the snow (kg/m3): +! +PWLIQMAX(:,:,:) = ZHOLDMAXR(:,:,:)*ZSNOWRHO(:,:,:) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LWLIQMAX_3D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LWLIQMAX_3D +!#################################################################### + FUNCTION SNOW3LWLIQMAX_2D(PSNOWRHO) RESULT(PWLIQMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES, XSNOWRHOHOLD, & + XWSNOWHOLDMAX2, XWSNOWHOLDMAX1 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWRHO ! (kg/m3) +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: PWLIQMAX ! (kg/m3) +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZHOLDMAXR, ZSNOWRHO +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!----------------------------------------------------------------------- +! Evaluate capacity using upper density limit: +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LWLIQMAX_2D',0,ZHOOK_HANDLE) +ZSNOWRHO(:,:) = MIN(XRHOSMAX_ES, PSNOWRHO(:,:)) +! +! Maximum ratio of liquid to SWE: +! +ZHOLDMAXR(:,:) = XWSNOWHOLDMAX1 + (XWSNOWHOLDMAX2-XWSNOWHOLDMAX1)* & + MAX(0.,XSNOWRHOHOLD-ZSNOWRHO(:,:))/XSNOWRHOHOLD +! +! Maximum liquid water holding capacity of the snow (kg/m3): +! +PWLIQMAX(:,:) = ZHOLDMAXR(:,:)*ZSNOWRHO(:,:) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LWLIQMAX_2D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LWLIQMAX_2D +!#################################################################### + FUNCTION SNOW3LWLIQMAX_1D(PSNOWRHO) RESULT(PWLIQMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES, XSNOWRHOHOLD, & + XWSNOWHOLDMAX2, XWSNOWHOLDMAX1 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWRHO ! (kg/m3) +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: PWLIQMAX ! (kg/m3) +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: ZHOLDMAXR, ZSNOWRHO +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!---------------------------------------------------------------------- +! Evaluate capacity using upper density limit: +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LWLIQMAX_1D',0,ZHOOK_HANDLE) +ZSNOWRHO(:) = MIN(XRHOSMAX_ES, PSNOWRHO(:)) +! +! Maximum ratio of liquid to SWE: +! +ZHOLDMAXR(:) = XWSNOWHOLDMAX1 + (XWSNOWHOLDMAX2-XWSNOWHOLDMAX1)* & + MAX(0.,XSNOWRHOHOLD-ZSNOWRHO(:))/XSNOWRHOHOLD +! +! Maximum liquid water holding capacity of the snow (kg/m3): +! +PWLIQMAX(:) = ZHOLDMAXR(:)*ZSNOWRHO(:) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LWLIQMAX_1D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LWLIQMAX_1D + +!#################################################################### +!#################################################################### +!#################################################################### + FUNCTION SNOW3LHOLD_3D(PSNOWRHO,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES, XSNOWRHOHOLD, & + XWSNOWHOLDMAX2, XWSNOWHOLDMAX1 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:,:), INTENT(IN) :: PSNOWDZ, PSNOWRHO +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2),SIZE(PSNOWRHO,3)) :: PWHOLDMAX +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2),SIZE(PSNOWRHO,3)) :: ZHOLDMAXR, ZSNOWRHO +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------- +! Evaluate capacity using upper density limit: +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_3D',0,ZHOOK_HANDLE) +ZSNOWRHO(:,:,:) = MIN(XRHOSMAX_ES, PSNOWRHO(:,:,:)) +! +! Maximum ratio of liquid to SWE: +! +ZHOLDMAXR(:,:,:) = XWSNOWHOLDMAX1 + (XWSNOWHOLDMAX2-XWSNOWHOLDMAX1)* & + MAX(0.,XSNOWRHOHOLD-ZSNOWRHO(:,:,:))/XSNOWRHOHOLD +! +! Maximum liquid water holding capacity of the snow (m): +! +PWHOLDMAX(:,:,:) = ZHOLDMAXR(:,:,:)*PSNOWDZ(:,:,:)*ZSNOWRHO(:,:,:)/XRHOLW +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_3D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LHOLD_3D +!#################################################################### + FUNCTION SNOW3LHOLD_2D(PSNOWRHO,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES, XSNOWRHOHOLD, & + XWSNOWHOLDMAX2, XWSNOWHOLDMAX1 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWDZ, PSNOWRHO +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: PWHOLDMAX +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZHOLDMAXR, ZSNOWRHO +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!----------------------------------------------------------------------- +! Evaluate capacity using upper density limit: +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_2D',0,ZHOOK_HANDLE) +ZSNOWRHO(:,:) = MIN(XRHOSMAX_ES, PSNOWRHO(:,:)) +! +! Maximum ratio of liquid to SWE: +! +ZHOLDMAXR(:,:) = XWSNOWHOLDMAX1 + (XWSNOWHOLDMAX2-XWSNOWHOLDMAX1)* & + MAX(0.,XSNOWRHOHOLD-ZSNOWRHO(:,:))/XSNOWRHOHOLD +! +! Maximum liquid water holding capacity of the snow (m): +! +PWHOLDMAX(:,:) = ZHOLDMAXR(:,:)*PSNOWDZ(:,:)*ZSNOWRHO(:,:)/XRHOLW +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_2D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LHOLD_2D +!#################################################################### + FUNCTION SNOW3LHOLD_1D(PSNOWRHO,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES, XSNOWRHOHOLD, & + XWSNOWHOLDMAX2, XWSNOWHOLDMAX1 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWDZ, PSNOWRHO +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: PWHOLDMAX +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: ZHOLDMAXR, ZSNOWRHO +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!----------------------------------------------------------------------- +! Evaluate capacity using upper density limit: +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_1D',0,ZHOOK_HANDLE) +ZSNOWRHO(:) = MIN(XRHOSMAX_ES, PSNOWRHO(:)) +! +! Maximum ratio of liquid to SWE: +! +ZHOLDMAXR(:) = XWSNOWHOLDMAX1 + (XWSNOWHOLDMAX2-XWSNOWHOLDMAX1)* & + MAX(0.,XSNOWRHOHOLD-ZSNOWRHO(:))/XSNOWRHOHOLD +! +! Maximum liquid water holding capacity of the snow (m): +! +PWHOLDMAX(:) = ZHOLDMAXR(:)*PSNOWDZ(:)*ZSNOWRHO(:)/XRHOLW +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_1D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LHOLD_1D +!#################################################################### + FUNCTION SNOW3LHOLD_0D(PSNOWRHO,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW +USE MODD_SNOW_PAR, ONLY : XRHOSMAX_ES, XSNOWRHOHOLD, & + XWSNOWHOLDMAX2, XWSNOWHOLDMAX1 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PSNOWDZ, PSNOWRHO +! +REAL :: PWHOLDMAX +! +!* 0.2 declarations of local variables +! +REAL :: ZHOLDMAXR, ZSNOWRHO +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! Evaluate capacity using upper density limit: +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_0D',0,ZHOOK_HANDLE) +ZSNOWRHO = MIN(XRHOSMAX_ES, PSNOWRHO) +! +! Maximum ratio of liquid to SWE: +! +ZHOLDMAXR = XWSNOWHOLDMAX1 + (XWSNOWHOLDMAX2-XWSNOWHOLDMAX1) * & + MAX(0.,XSNOWRHOHOLD-ZSNOWRHO)/XSNOWRHOHOLD +! +! Maximum liquid water holding capacity of the snow (m): +! +PWHOLDMAX = ZHOLDMAXR*PSNOWDZ*ZSNOWRHO/XRHOLW +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LHOLD_0D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LHOLD_0D +!#################################################################### + FUNCTION SNOWCROHOLD_3D(PSNOWRHO,PSNOWLIQ,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW,XRHOLI +USE MODD_SNOW_PAR, ONLY : XPERCENTAGEPORE +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:,:), INTENT(IN) :: PSNOWDZ, PSNOWLIQ, PSNOWRHO +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2),SIZE(PSNOWRHO,3)) :: PWHOLDMAX +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! computation of water holding capacity based on Crocus, +!taking into account the conversion between wet and dry density - +!S. Morin/V. Vionnet 2010 12 09 + +! PWHOLDMAX is expressed in m water for each layer +! In short, PWHOLDMAX = XPERCENTAGEPORE * porosity * PSNOWDZ . +! The porosity is computed as (rho_ice - (rho_snow - lwc))/(rho_ice) +! where everything has to be in kg m-3 units. In practice, since +! PSNOWLIQ is expressed in m water, expressing the lwc in kg m-3 +! is achieved as PSNOWLIQ*XRHOLW/PSNOWDZ. After some rearranging one +! obtains the equation given above. +! Note that equation (19) in Vionnet et al., GMD 2012, is wrong, +! because it does not take into account the fact that liquid water +! content has to be substracted from total density to compute the +! porosity. + +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_3D',0,ZHOOK_HANDLE) +PWHOLDMAX(:,:,:) = XPERCENTAGEPORE/XRHOLI * (PSNOWDZ * (XRHOLI-PSNOWRHO) + PSNOWLIQ*XRHOLW) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_3D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOWCROHOLD_3D +!#################################################################### + FUNCTION SNOWCROHOLD_2D(PSNOWRHO,PSNOWLIQ,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW,XRHOLI +USE MODD_SNOW_PAR, ONLY : XPERCENTAGEPORE +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWDZ, PSNOWRHO, PSNOWLIQ +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: PWHOLDMAX +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! computation of water holding capacity based on Crocus, +!taking into account the conversion between wet and dry density - +!S. Morin/V. Vionnet 2010 12 09 + +! PWHOLDMAX is expressed in m water for each layer +! In short, PWHOLDMAX = XPERCENTAGEPORE * porosity * PSNOWDZ . +! The porosity is computed as (rho_ice - (rho_snow - lwc))/(rho_ice) +! where everything has to be in kg m-3 units. In practice, since +! PSNOWLIQ is expressed in m water, expressing the lwc in kg m-3 +! is achieved as PSNOWLIQ*XRHOLW/PSNOWDZ. After some rearranging one +! obtains the equation given above. +! Note that equation (19) in Vionnet et al., GMD 2012, is wrong, +! because it does not take into account the fact that liquid water +! content has to be substracted from total density to compute the +! porosity. +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_2D',0,ZHOOK_HANDLE) +PWHOLDMAX(:,:) = XPERCENTAGEPORE/XRHOLI * (PSNOWDZ * (XRHOLI-PSNOWRHO) + PSNOWLIQ*XRHOLW) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_2D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOWCROHOLD_2D +!#################################################################### +!#################################################################### +!#################################################################### + FUNCTION SNOWCROHOLD_1D(PSNOWRHO,PSNOWLIQ,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW,XRHOLI +USE MODD_SNOW_PAR, ONLY : XPERCENTAGEPORE +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWDZ, PSNOWRHO, PSNOWLIQ +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: PWHOLDMAX +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! computation of water holding capacity based on Crocus, +!taking into account the conversion between wet and dry density - +!S. Morin/V. Vionnet 2010 12 09 + +! PWHOLDMAX is expressed in m water for each layer +! In short, PWHOLDMAX = XPERCENTAGEPORE * porosity * PSNOWDZ . +! The porosity is computed as (rho_ice - (rho_snow - lwc))/(rho_ice) +! where everything has to be in kg m-3 units. In practice, since +! PSNOWLIQ is expressed in m water, expressing the lwc in kg m-3 +! is achieved as PSNOWLIQ*XRHOLW/PSNOWDZ. After some rearranging one +! obtains the equation given above. +! Note that equation (19) in Vionnet et al., GMD 2012, is wrong, +! because it does not take into account the fact that liquid water +! content has to be substracted from total density to compute the +! porosity. +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_1D',0,ZHOOK_HANDLE) +PWHOLDMAX(:) = XPERCENTAGEPORE/XRHOLI * (PSNOWDZ * (XRHOLI-PSNOWRHO) + PSNOWLIQ*XRHOLW) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_1D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOWCROHOLD_1D +!#################################################################### + FUNCTION SNOWCROHOLD_0D(PSNOWRHO,PSNOWLIQ,PSNOWDZ) RESULT(PWHOLDMAX) +! +!! PURPOSE +!! ------- +! Calculate the maximum liquid water holding capacity of +! snow layer(s). +! +USE MODD_CSTS, ONLY : XRHOLW,XRHOLI +USE MODD_SNOW_PAR, ONLY : XPERCENTAGEPORE +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PSNOWDZ, PSNOWRHO, PSNOWLIQ +! +REAL :: PWHOLDMAX +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! computation of water holding capacity based on Crocus, +!taking into account the conversion between wet and dry density - +!S. Morin/V. Vionnet 2010 12 09 + +! PWHOLDMAX is expressed in m water for each layer +! In short, PWHOLDMAX = XPERCENTAGEPORE * porosity * PSNOWDZ . +! The porosity is computed as (rho_ice - (rho_snow - lwc))/(rho_ice) +! where everything has to be in kg m-3 units. In practice, since +! PSNOWLIQ is expressed in m water, expressing the lwc in kg m-3 +! is achieved as PSNOWLIQ*XRHOLW/PSNOWDZ. After some rearranging one +! obtains the equation given above. +! Note that equation (19) in Vionnet et al., GMD 2012, is wrong, +! because it does not take into account the fact that liquid water +! content has to be substracted from total density to compute the +! porosity. + +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_0D',0,ZHOOK_HANDLE) +PWHOLDMAX = XPERCENTAGEPORE/XRHOLI * (PSNOWDZ * (XRHOLI-PSNOWRHO) + PSNOWLIQ*XRHOLW) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOWCROHOLD_0D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOWCROHOLD_0D +!#################################################################### +!#################################################################### +!#################################################################### + FUNCTION SNOW3LSCAP_3D(PSNOWRHO) RESULT(PSCAP) +! +!! PURPOSE +!! ------- +! Calculate the heat capacity of a snow layer. +! +USE MODD_CSTS,ONLY : XCI +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:,:), INTENT(IN) :: PSNOWRHO +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2),SIZE(PSNOWRHO,3)) :: PSCAP +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! The method of Verseghy (1991), Int. J. Climat., 11, 111-133. +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_3D',0,ZHOOK_HANDLE) +PSCAP(:,:,:) = PSNOWRHO(:,:,:)*XCI ! (J K-1 m-3) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_3D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LSCAP_3D +!#################################################################### + FUNCTION SNOW3LSCAP_2D(PSNOWRHO) RESULT(PSCAP) +! +!! PURPOSE +!! ------- +! Calculate the heat capacity of a snow layer. +! +USE MODD_CSTS,ONLY : XCI +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWRHO +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: PSCAP +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! The method of Verseghy (1991), Int. J. Climat., 11, 111-133. +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_2D',0,ZHOOK_HANDLE) +PSCAP(:,:) = PSNOWRHO(:,:)*XCI ! (J K-1 m-3) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_2D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LSCAP_2D +!#################################################################### + FUNCTION SNOW3LSCAP_1D(PSNOWRHO) RESULT(PSCAP) +! +!! PURPOSE +!! ------- +! Calculate the heat capacity of a snow layer. +! +USE MODD_CSTS,ONLY : XCI +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWRHO +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: PSCAP +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! The method of Verseghy (1991), Int. J. Climat., 11, 111-133. +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_1D',0,ZHOOK_HANDLE) +PSCAP(:) = PSNOWRHO(:)*XCI ! (J K-1 m-3) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_1D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LSCAP_1D +!#################################################################### + FUNCTION SNOW3LSCAP_0D(PSNOWRHO) RESULT(PSCAP) +! +!! PURPOSE +!! ------- +! Calculate the heat capacity of a snow layer. +! +USE MODD_CSTS,ONLY : XCI +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PSNOWRHO +! +REAL :: PSCAP +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! The method of Verseghy (1991), Int. J. Climat., 11, 111-133. +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_0D',0,ZHOOK_HANDLE) +PSCAP = PSNOWRHO*XCI ! (J K-1 m-3) +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LSCAP_0D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LSCAP_0D +! +!#################################################################### +!#################################################################### +!#################################################################### + FUNCTION SNOW3L_MARBOUTY(PSNOWRHO,PSNOWTEMP,PGRADT) RESULT(PDANGL) +!**** *ZDANGL* - CROISSANCE DES GRAINS NON DENDRITIQUES ET ANGULEUX . +! - GROWTH RATES FOR NON DENDRITIC GRAINS WITH SPHERICITY=0 + + +! OBJET. +! ------ + +!** INTERFACE. +! ---------- + +! *ZDANGL*(PST,PSRO,PGRADT)* + +! *PST* - TEMPERATURE DE LA STRATE DE NEIGE. +! *PSRO* - MASSE VOLUMIQUE DE LA STRATE DE NEIGE. +! *PGRADT* - GRADIENT DE TEMPERATURE AFFECTANT LA STRATE DE NEIGE. + +! METHODE. +! -------- +! THE FUNCTION RETURN A VALUE BETWEEN 0 AND 1 WHICH IS USED IN THE DETERMINATION OF THE +! GROWTH RATE FOR THE CONSIDERED LAYER. +! THIS VALUE (WITHOUT UNIT) IS THE PRODUCT OF 3 FUNCTIONS (WHICH HAVE THEIR SOLUTIONS BETWEEN 0 AND 1) : +! F(TEMPERATURE) * H(DENSITY) * G(TEMPERATURE GRADIENT) + +! EXTERNES. +! --------- + +! REFERENCES. +! ----------- +! MARBOUTY D (1980) AN EXPERIMENTAL STUDY OF TEMPERATURE GRADIENT +! METAMORPHISM J GLACIOLOGY + +! AUTEURS. +! -------- +! DOMINIQUE MARBOUTY (FMARBO/GMARBO/HMARBO). + +! MODIFICATIONS. +! -------------- +! 08/95: YANNICK DANIELOU - CODAGE A LA NORME DOCTOR. +! 03/06: JM WILLEMET - F90 AND SI UNITS +! 01/08: JM WILLEMET - ERROR ON THE FORMULATION OF G FUNCTION (WITH GRADIENT) IS CORRECTED + +USE MODD_CSTS, ONLY : XTT +USE MODD_SNOW_METAMO +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +! DECLARATIONS. +! ------------- +! +REAL ,INTENT(IN) :: PSNOWTEMP, PSNOWRHO, PGRADT +! +REAL :: PDANGL +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3L_MARBOUTY',0,ZHOOK_HANDLE) +! +PDANGL = 0.0 +! +! INFLUENCE DE LA TEMPERATURE /TEMPERATURE INFLUENCE. +IF( PSNOWTEMP>=XTT-XVTANG1 ) THEN + ! + IF ( PSNOWTEMP>=XTT-XVTANG2 ) THEN + PDANGL = XVTANG4 + XVTANG5 * (XTT-PSNOWTEMP) / XVTANG6 + ELSEIF( PSNOWTEMP>=XTT-XVTANG3 ) THEN + PDANGL = XVTANG7 - XVTANG8 * (XTT-XVTANG2-PSNOWTEMP) / XVTANG9 + ELSE + PDANGL = XVTANGA - XVTANGB * (XTT-XVTANG3-PSNOWTEMP) / XVTANGC + ENDIF + ! + ! INFLUENCE DE LA MASSE VOLUMIQUE / DENSITY INFLUENCE. + IF ( PSNOWRHO<=XVRANG1 ) THEN + ! + IF ( PSNOWRHO>XVRANG2 ) THEN + PDANGL = PDANGL * ( 1. - (PSNOWRHO-XVRANG2)/(XVRANG1-XVRANG2) ) + ENDIF + ! + ! INFLUENCE DU GRADIENT DE TEMPERATURE / TEMPERATURE GRADIENT INFLUENCE. + IF ( PGRADT<=XVGANG1 ) THEN + ! + IF ( PGRADT<=XVGANG2 ) THEN + PDANGL = PDANGL * XVGANG5 * (PGRADT-XVGANG6)/(XVGANG2-XVGANG6) + ELSEIF( PGRADT<=XVGANG3 ) THEN + PDANGL = PDANGL * ( XVGANG7 + XVGANG8 * (PGRADT-XVGANG2)/(XVGANG3-XVGANG2) ) + ELSEIF( PGRADT<=XVGANG4 )THEN + PDANGL = PDANGL * ( XVGANG9 + XVGANGA * (PGRADT-XVGANG3)/(XVGANG4-XVGANG3) ) + ELSE + PDANGL = PDANGL * ( XVGANGB + XVGANGC * (PGRADT-XVGANG4)/(XVGANG1-XVGANG4) ) + ENDIF + ! + ENDIF + ! + ELSE + ! + PDANGL = 0. + ! + ENDIF + ! +ELSE + ! + PDANGL = 0. + ! +ENDIF +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3L_MARBOUTY',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3L_MARBOUTY +! +!#################################################################### +!#################################################################### +!#################################################################### +! + SUBROUTINE SNOW3LGRID_2D(PSNOWDZ,PSNOW,PSNOWDZ_OLD) +! +!! PURPOSE +!! ------- +! Once during each time step, update grid to maintain +! grid proportions. Similar to approach of Lynch-Steiglitz, +! 1994, J. Clim., 7, 1842-1855. Corresponding mass and +! heat adjustments made directly after the call to this +! routine. 3 grid configurations: +! 1) for very thin snow, constant grid spacing +! 2) for intermediate thicknesses, highest resolution at soil/snow +! interface and at the snow/atmosphere interface +! 3) for deep snow, vertical resoution finest at snow/atmosphere +! interface (set to a constant value) and increases with snow depth. +! Second layer can't be more than an order of magnitude thicker +! than surface layer. +! +! +!USE MODD_SURF_PAR, ONLY : XUNDEF +USE MODD_SNOW_PAR, ONLY : XSNOWCRITD, XUNDEF +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(: ), INTENT(IN ) :: PSNOW +REAL, DIMENSION(:,:), INTENT(OUT) :: PSNOWDZ +REAL, DIMENSION(:,:), INTENT(IN ), OPTIONAL :: PSNOWDZ_OLD +! +!* 0.1 declarations of local variables +! +INTEGER :: JJ, JI +! +INTEGER :: INLVLS, INI +! +REAL, DIMENSION(SIZE(PSNOW)) :: ZWORK +! +LOGICAL , DIMENSION(SIZE(PSNOW)) :: GREGRID + +! ISBA-ES snow grid parameters +! +REAL, PARAMETER, DIMENSION(3) :: ZSGCOEF1 = (/0.25, 0.50, 0.25/) +REAL, PARAMETER, DIMENSION(2) :: ZSGCOEF2 = (/0.05, 0.34/) +! +REAL, PARAMETER, DIMENSION(3) :: ZSGCOEF = (/0.3, 0.4, 0.3/) +! +! Minimum total snow depth at which surface layer thickness is constant: +! +REAL, PARAMETER :: ZSNOWTRANS = 0.20 ! (m) +! +! Minimum snow depth by layer for 6-L or 12-L configuration : +! +REAL, PARAMETER :: ZDZ1=0.01 +REAL, PARAMETER :: ZDZ2=0.05 +REAL, PARAMETER :: ZDZ3=0.15 +REAL, PARAMETER :: ZDZ4=0.50 +REAL, PARAMETER :: ZDZ5=1.00 +REAL, PARAMETER :: ZDZN0=0.02 +REAL, PARAMETER :: ZDZN1=0.1 +REAL, PARAMETER :: ZDZN2=0.5 +REAL, PARAMETER :: ZDZN3=1.0 +! +REAL, PARAMETER :: ZCOEF1 = 0.5 +REAL, PARAMETER :: ZCOEF2 = 1.5 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!------------------------------------------------------------------------------- +! +! 0. Initialization: +! ------------------ +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LGRID_2D',0,ZHOOK_HANDLE) +! +INLVLS = SIZE(PSNOWDZ(:,:),2) +INI = SIZE(PSNOWDZ(:,:),1) +! +ZWORK (:) = 0.0 +GREGRID(:) = .TRUE. +! +! 1. Calculate current grid for 3-layer (default) configuration): +! --------------------------------------------------------------- +! Based on formulation of Lynch-Stieglitz (1994) +! except for 3 modifications: +! i) smooth transition here at ZSNOWTRANS +! ii) constant ratio for very thin snow: +! iii) ratio of layer 2 to surface layer <= 10 +! +IF(INLVLS == 1)THEN +! + DO JI=1,INI + PSNOWDZ(JI,1) = PSNOW(JI) + ENDDO +! +ELSEIF(INLVLS == 3)THEN +! + WHERE(PSNOW <= XSNOWCRITD+0.01) + PSNOWDZ(:,1) = MIN(0.01, PSNOW(:)/INLVLS) + PSNOWDZ(:,3) = MIN(0.01, PSNOW(:)/INLVLS) + PSNOWDZ(:,2) = PSNOW(:) - PSNOWDZ(:,1) - PSNOWDZ(:,3) + END WHERE +! + WHERE(PSNOW <= ZSNOWTRANS .AND. PSNOW > XSNOWCRITD+0.01) + PSNOWDZ(:,1) = PSNOW(:)*ZSGCOEF1(1) + PSNOWDZ(:,2) = PSNOW(:)*ZSGCOEF1(2) + PSNOWDZ(:,3) = PSNOW(:)*ZSGCOEF1(3) + END WHERE +! + WHERE(PSNOW > ZSNOWTRANS) + PSNOWDZ(:,1) = ZSGCOEF2(1) + PSNOWDZ(:,2) = (PSNOW(:)-ZSGCOEF2(1))*ZSGCOEF2(2) + ZSGCOEF2(1) +! +! When using simple finite differences, limit the thickness +! factor between the top and 2nd layers to at most 10 +! + PSNOWDZ(:,2) = MIN(10*ZSGCOEF2(1), PSNOWDZ(:,2)) + PSNOWDZ(:,3) = PSNOW(:) - PSNOWDZ(:,2) - PSNOWDZ(:,1) + END WHERE +! +! +! 2. Calculate current grid for 6-layer : +! --------------------------------------------------------------- +! +ELSEIF(INLVLS == 6)THEN +! +! critere a satisfaire pour remaillage +! + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID(:) = PSNOWDZ_OLD(:,1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,6) < ZCOEF1 * MIN(ZDZN1,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,6) > ZCOEF2 * MIN(ZDZN1,PSNOW(:)/INLVLS) + ENDIF +! + WHERE(GREGRID(:)) +! top layers + PSNOWDZ(:,1) = MIN(ZDZ1,PSNOW(:)/INLVLS) + PSNOWDZ(:,2) = MIN(ZDZ2,PSNOW(:)/INLVLS) +! last layers + PSNOWDZ(:,6) = MIN(ZDZN1,PSNOW(:)/INLVLS) +! remaining snow for remaining layers + ZWORK(:) = PSNOW(:) - PSNOWDZ(:,1) - PSNOWDZ(:,2) - PSNOWDZ(:,6) + PSNOWDZ(:,3) = ZWORK(:)*ZSGCOEF(1) + PSNOWDZ(:,4) = ZWORK(:)*ZSGCOEF(2) + PSNOWDZ(:,5) = ZWORK(:)*ZSGCOEF(3) +! layer 3 tickness >= layer 2 tickness + ZWORK(:)=MIN(0.0,PSNOWDZ(:,3)-PSNOWDZ(:,2)) + PSNOWDZ(:,3)=PSNOWDZ(:,3)-ZWORK(:) + PSNOWDZ(:,4)=PSNOWDZ(:,4)+ZWORK(:) +! layer 5 tickness >= layer 6 tickness + ZWORK(:)=MIN(0.0,PSNOWDZ(:,5)-PSNOWDZ(:,6)) + PSNOWDZ(:,5)=PSNOWDZ(:,5)-ZWORK(:) + PSNOWDZ(:,4)=PSNOWDZ(:,4)+ZWORK(:) + ENDWHERE +! +! 3. Calculate current grid for 9-layer : +! --------------------------------------------------------------- +! +ELSEIF(INLVLS == 9)THEN +! +! critere a satisfaire pour remaillage +! + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID(:) = PSNOWDZ_OLD(:,1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,9) < ZCOEF1 * MIN(ZDZN0,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,9) > ZCOEF2 * MIN(ZDZN0,PSNOW(:)/INLVLS) + ENDIF +! + WHERE(GREGRID(:)) +! top layers + PSNOWDZ(:,1) = MIN(ZDZ1,PSNOW(:)/INLVLS) + PSNOWDZ(:,2) = MIN(ZDZ2,PSNOW(:)/INLVLS) + PSNOWDZ(:,3) = MIN(ZDZ3,PSNOW(:)/INLVLS) +! last layers + PSNOWDZ(:,9)= MIN(ZDZN0,PSNOW(:)/INLVLS) + PSNOWDZ(:,8)= MIN(ZDZN1,PSNOW(:)/INLVLS) + PSNOWDZ(:,7)= MIN(ZDZN2,PSNOW(:)/INLVLS) +! remaining snow for remaining layers + ZWORK(:) = PSNOW(:) - PSNOWDZ(:, 1) - PSNOWDZ(:, 2) - PSNOWDZ(:, 3) & + - PSNOWDZ(:, 7) - PSNOWDZ(:, 8) - PSNOWDZ(:, 9) + PSNOWDZ(:,4) = ZWORK(:)*ZSGCOEF(1) + PSNOWDZ(:,5) = ZWORK(:)*ZSGCOEF(2) + PSNOWDZ(:,6) = ZWORK(:)*ZSGCOEF(3) +! layer 4 tickness >= layer 3 tickness + ZWORK(:)=MIN(0.0,PSNOWDZ(:,4)-PSNOWDZ(:,3)) + PSNOWDZ(:,4)=PSNOWDZ(:,4)-ZWORK(:) + PSNOWDZ(:,5)=PSNOWDZ(:,5)+ZWORK(:) +! layer 6 tickness >= layer 7 tickness + ZWORK(:)=MIN(0.0,PSNOWDZ(:,6)-PSNOWDZ(:,7)) + PSNOWDZ(:,6)=PSNOWDZ(:,6)-ZWORK(:) + PSNOWDZ(:,5)=PSNOWDZ(:,5)+ZWORK(:) + ENDWHERE +! +! 4. Calculate current grid for 12-layer : +! --------------------------------------------------------------- +! +ELSEIF(INLVLS == 12)THEN +! +! critere a satisfaire pour remaillage +! + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID(:) = PSNOWDZ_OLD(:, 1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:, 1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:, 2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:, 2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,12) < ZCOEF1 * MIN(ZDZN0,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,12) > ZCOEF2 * MIN(ZDZN0,PSNOW(:)/INLVLS) + ENDIF +! + WHERE(GREGRID(:)) +! top layers + PSNOWDZ(:,1) = MIN(ZDZ1,PSNOW(:)/INLVLS) + PSNOWDZ(:,2) = MIN(ZDZ2,PSNOW(:)/INLVLS) + PSNOWDZ(:,3) = MIN(ZDZ3,PSNOW(:)/INLVLS) + PSNOWDZ(:,4) = MIN(ZDZ4,PSNOW(:)/INLVLS) + PSNOWDZ(:,5) = MIN(ZDZ5,PSNOW(:)/INLVLS) +! last layers + PSNOWDZ(:,12)= MIN(ZDZN0,PSNOW(:)/INLVLS) + PSNOWDZ(:,11)= MIN(ZDZN1,PSNOW(:)/INLVLS) + PSNOWDZ(:,10)= MIN(ZDZN2,PSNOW(:)/INLVLS) + PSNOWDZ(:, 9)= MIN(ZDZN3,PSNOW(:)/INLVLS) +! remaining snow for remaining layers + ZWORK(:) = PSNOW(:) - PSNOWDZ(:, 1) - PSNOWDZ(:, 2) - PSNOWDZ(:, 3) & + - PSNOWDZ(:, 4) - PSNOWDZ(:, 5) - PSNOWDZ(:, 9) & + - PSNOWDZ(:,10) - PSNOWDZ(:,11) - PSNOWDZ(:,12) + PSNOWDZ(:,6) = ZWORK(:)*ZSGCOEF(1) + PSNOWDZ(:,7) = ZWORK(:)*ZSGCOEF(2) + PSNOWDZ(:,8) = ZWORK(:)*ZSGCOEF(3) +! layer 6 tickness >= layer 5 tickness + ZWORK(:)=MIN(0.0,PSNOWDZ(:,6)-PSNOWDZ(:,5)) + PSNOWDZ(:,6)=PSNOWDZ(:,6)-ZWORK(:) + PSNOWDZ(:,7)=PSNOWDZ(:,7)+ZWORK(:) +! layer 8 tickness >= layer 9 tickness + ZWORK(:)=MIN(0.0,PSNOWDZ(:,8)-PSNOWDZ(:,9)) + PSNOWDZ(:,8)=PSNOWDZ(:,8)-ZWORK(:) + PSNOWDZ(:,7)=PSNOWDZ(:,7)+ZWORK(:) + ENDWHERE +! +! 4. Calculate other non-optimized grid : +! --------------------------------------- +! +ELSEIF(INLVLS<10.AND.INLVLS/=3.AND.INLVLS/=6.AND.INLVLS/=9) THEN +! + DO JJ=1,INLVLS + DO JI=1,INI + PSNOWDZ(JI,JJ) = PSNOW(JI)/INLVLS + ENDDO + ENDDO +! + PSNOWDZ(:,INLVLS) = PSNOWDZ(:,INLVLS) + (PSNOWDZ(:,1) - MIN(0.05, PSNOWDZ(:,1))) + PSNOWDZ(:,1) = MIN(0.05, PSNOWDZ(:,1)) +! +ELSE !(INLVLS>=10 and /=12) +! +! critere a satisfaire pour remaillage +! + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID(:) = PSNOWDZ_OLD(:, 1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:, 1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:, 2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:, 2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,INLVLS) < ZCOEF1 * MIN(0.05*PSNOW(:),PSNOW(:)/INLVLS) .OR. & + & PSNOWDZ_OLD(:,INLVLS) > ZCOEF2 * MIN(0.05*PSNOW(:),PSNOW(:)/INLVLS) + ENDIF +! + WHERE(GREGRID(:)) + PSNOWDZ(:,1 ) = MIN(ZDZ1 ,PSNOW(:)/INLVLS) + PSNOWDZ(:,2 ) = MIN(ZDZ2 ,PSNOW(:)/INLVLS) + PSNOWDZ(:,3 ) = MIN(ZDZ3 ,PSNOW(:)/INLVLS) + PSNOWDZ(:,4 ) = MIN(ZDZ4 ,PSNOW(:)/INLVLS) + PSNOWDZ(:,5 ) = MIN(ZDZ5 ,PSNOW(:)/INLVLS) + PSNOWDZ(:,INLVLS) = MIN(0.05*PSNOW(:),PSNOW(:)/INLVLS) + ENDWHERE +! + DO JJ=6,INLVLS-1,1 + DO JI=1,INI + IF(GREGRID(JI))THEN + ZWORK(JI) = PSNOWDZ(JI,1)+PSNOWDZ(JI,2)+PSNOWDZ(JI,3)+PSNOWDZ(JI,4)+PSNOWDZ(JI,5) + PSNOWDZ(JI,JJ) = (PSNOW(JI)-ZWORK(JI)-PSNOWDZ(JI,INLVLS))/(INLVLS-6) + ENDIF + ENDDO + ENDDO +! +ENDIF +! +DO JJ=1,INLVLS + DO JI=1,INI + IF(PSNOW(JI)==XUNDEF)THEN + PSNOWDZ(JI,JJ) = XUNDEF + ELSEIF(.NOT.GREGRID(JI))THEN + PSNOWDZ(JI,JJ)=PSNOWDZ_OLD(JI,JJ) + ENDIF + ENDDO +ENDDO +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LGRID_2D',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOW3LGRID_2D +!#################################################################### +!#################################################################### +!#################################################################### +! + SUBROUTINE SNOW3LGRID_1D(PSNOWDZ,PSNOW,PSNOWDZ_OLD) +! +!! PURPOSE +!! ------- +! Once during each time step, update grid to maintain +! grid proportions. Similar to approach of Lynch-Steiglitz, +! 1994, J. Clim., 7, 1842-1855. Corresponding mass and +! heat adjustments made directly after the call to this +! routine. 3 grid configurations: +! 1) for very thin snow, constant grid spacing +! 2) for intermediate thicknesses, highest resolution at soil/snow +! interface and at the snow/atmosphere interface +! 3) for deep snow, vertical resoution finest at snow/atmosphere +! interface (set to a constant value) and increases with snow depth. +! Second layer can't be more than an order of magnitude thicker +! than surface layer. +! +! +!USE MODD_SURF_PAR, ONLY : XUNDEF +USE MODD_SNOW_PAR, ONLY : XSNOWCRITD, XUNDEF +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN ) :: PSNOW +REAL, DIMENSION(:), INTENT(OUT) :: PSNOWDZ +REAL, DIMENSION(:), INTENT(IN ), OPTIONAL :: PSNOWDZ_OLD +! +!* 0.1 declarations of local variables +! +INTEGER JJ +! +INTEGER :: INLVLS +! +REAL :: ZWORK +! +! modif_EB pour maillage +LOGICAL :: GREGRID + +! ISBA-ES snow grid parameters +! +REAL, PARAMETER, DIMENSION(3) :: ZSGCOEF1 = (/0.25, 0.50, 0.25/) +REAL, PARAMETER, DIMENSION(2) :: ZSGCOEF2 = (/0.05, 0.34/) +! +REAL, PARAMETER, DIMENSION(3) :: ZSGCOEF = (/0.3, 0.4, 0.3/) +! +! Minimum total snow depth at which surface layer thickness is constant: +! +REAL, PARAMETER :: ZSNOWTRANS = 0.20 ! (m) +! +! Minimum snow depth by layer for 6-L or 12-L configuration : +! +REAL, PARAMETER :: ZDZ1=0.01 +REAL, PARAMETER :: ZDZ2=0.05 +REAL, PARAMETER :: ZDZ3=0.15 +REAL, PARAMETER :: ZDZ4=0.50 +REAL, PARAMETER :: ZDZ5=1.00 +REAL, PARAMETER :: ZDZN0=0.02 +REAL, PARAMETER :: ZDZN1=0.1 +REAL, PARAMETER :: ZDZN2=0.5 +REAL, PARAMETER :: ZDZN3=1.0 +! +REAL, PARAMETER :: ZCOEF1 = 0.5 +REAL, PARAMETER :: ZCOEF2 = 1.5 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!------------------------------------------------------------------------------- +! +! 0. Initialization: +! ------------------ +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LGRID_1D',0,ZHOOK_HANDLE) +! +INLVLS = SIZE(PSNOWDZ(:),1) +! +GREGRID = .TRUE. +! +! 1. Calculate current grid for 3-layer (default) configuration): +! --------------------------------------------------------------- +! Based on formulation of Lynch-Stieglitz (1994) +! except for 3 modifications: +! i) smooth transition here at ZSNOWTRANS +! ii) constant ratio for very thin snow: +! iii) ratio of layer 2 to surface layer <= 10 +! +IF(INLVLS == 1)THEN +! + PSNOWDZ(1) = PSNOW +! +ELSEIF(INLVLS == 3)THEN +! + IF(PSNOW <= XSNOWCRITD+0.01)THEN + PSNOWDZ(1) = MIN(0.01, PSNOW/INLVLS) + PSNOWDZ(3) = MIN(0.01, PSNOW/INLVLS) + PSNOWDZ(2) = PSNOW - PSNOWDZ(1) - PSNOWDZ(3) + ENDIF +! + IF(PSNOW <= ZSNOWTRANS .AND. PSNOW > XSNOWCRITD+0.01)THEN + PSNOWDZ(1) = PSNOW*ZSGCOEF1(1) + PSNOWDZ(2) = PSNOW*ZSGCOEF1(2) + PSNOWDZ(3) = PSNOW*ZSGCOEF1(3) + ENDIF +! + IF(PSNOW > ZSNOWTRANS)THEN + PSNOWDZ(1) = ZSGCOEF2(1) + PSNOWDZ(2) = (PSNOW-ZSGCOEF2(1))*ZSGCOEF2(2) + ZSGCOEF2(1) +! +! When using simple finite differences, limit the thickness +! factor between the top and 2nd layers to at most 10 +! + PSNOWDZ(2) = MIN(10*ZSGCOEF2(1), PSNOWDZ(2)) + PSNOWDZ(3) = PSNOW - PSNOWDZ(2) - PSNOWDZ(1) + END IF +! +! +! 2. Calculate current grid for 6-layer : +! --------------------------------------------------------------- +! +ELSEIF(INLVLS == 6)THEN +! +! critere a satisfaire pour remaillage +! + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID = PSNOWDZ_OLD(1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(6) < ZCOEF1 * MIN(ZDZN1,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(6) > ZCOEF2 * MIN(ZDZN1,PSNOW/INLVLS) + ENDIF +! + IF(GREGRID)THEN +! top layers + PSNOWDZ(1) = MIN(ZDZ1,PSNOW/INLVLS) + PSNOWDZ(2) = MIN(ZDZ2,PSNOW/INLVLS) +! last layers + PSNOWDZ(6) = MIN(ZDZN1,PSNOW/INLVLS) +! remaining snow for remaining layers + ZWORK = PSNOW - PSNOWDZ(1) - PSNOWDZ(2) - PSNOWDZ(6) + PSNOWDZ(3) = ZWORK*ZSGCOEF(1) + PSNOWDZ(4) = ZWORK*ZSGCOEF(2) + PSNOWDZ(5) = ZWORK*ZSGCOEF(3) +! layer 3 tickness >= layer 2 tickness + ZWORK=MIN(0.0,PSNOWDZ(3)-PSNOWDZ(2)) + PSNOWDZ(3)=PSNOWDZ(3)-ZWORK + PSNOWDZ(4)=PSNOWDZ(4)+ZWORK +! layer 5 tickness >= layer 6 tickness + ZWORK=MIN(0.0,PSNOWDZ(5)-PSNOWDZ(6)) + PSNOWDZ(5)=PSNOWDZ(5)-ZWORK + PSNOWDZ(4)=PSNOWDZ(4)+ZWORK + ENDIF +! +! 3. Calculate current grid for 9-layer : +! --------------------------------------------------------------- +! +ELSEIF(INLVLS == 9)THEN +! +! critere a satisfaire pour remaillage +! + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID = PSNOWDZ_OLD(1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(9) < ZCOEF1 * MIN(ZDZN0,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(9) > ZCOEF2 * MIN(ZDZN0,PSNOW/INLVLS) + ENDIF +! + IF(GREGRID)THEN +! top layers + PSNOWDZ(1) = MIN(ZDZ1,PSNOW/INLVLS) + PSNOWDZ(2) = MIN(ZDZ2,PSNOW/INLVLS) + PSNOWDZ(3) = MIN(ZDZ3,PSNOW/INLVLS) +! last layers + PSNOWDZ(9)= MIN(ZDZN0,PSNOW/INLVLS) + PSNOWDZ(8)= MIN(ZDZN1,PSNOW/INLVLS) + PSNOWDZ(7)= MIN(ZDZN2,PSNOW/INLVLS) +! remaining snow for remaining layers + ZWORK = PSNOW - PSNOWDZ( 1) - PSNOWDZ( 2) - PSNOWDZ( 3) & + - PSNOWDZ( 7) - PSNOWDZ( 8) - PSNOWDZ( 9) + PSNOWDZ(4) = ZWORK*ZSGCOEF(1) + PSNOWDZ(5) = ZWORK*ZSGCOEF(2) + PSNOWDZ(6) = ZWORK*ZSGCOEF(3) +! layer 4 tickness >= layer 3 tickness + ZWORK=MIN(0.0,PSNOWDZ(4)-PSNOWDZ(3)) + PSNOWDZ(4)=PSNOWDZ(4)-ZWORK + PSNOWDZ(5)=PSNOWDZ(5)+ZWORK +! layer 6 tickness >= layer 7 tickness + ZWORK=MIN(0.0,PSNOWDZ(6)-PSNOWDZ(7)) + PSNOWDZ(6)=PSNOWDZ(6)-ZWORK + PSNOWDZ(5)=PSNOWDZ(5)+ZWORK + ENDIF +! +! 4. Calculate current grid for 12-layer : +! --------------------------------------------------------------- +! +ELSEIF(INLVLS == 12)THEN +! +! modif_EB pour maillage +! critere a satisfaire pour remaillage + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID = PSNOWDZ_OLD(1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(12) < ZCOEF1 * MIN(ZDZN0,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(12) > ZCOEF2 * MIN(ZDZN0,PSNOW/INLVLS) + ENDIF +! + IF (GREGRID)THEN +! top layers + PSNOWDZ(1) = MIN(ZDZ1,PSNOW/INLVLS) + PSNOWDZ(2) = MIN(ZDZ2,PSNOW/INLVLS) + PSNOWDZ(3) = MIN(ZDZ3,PSNOW/INLVLS) + PSNOWDZ(4) = MIN(ZDZ4,PSNOW/INLVLS) + PSNOWDZ(5) = MIN(ZDZ5,PSNOW/INLVLS) +! last layers + PSNOWDZ(12)= MIN(ZDZN0,PSNOW/INLVLS) + PSNOWDZ(11)= MIN(ZDZN1,PSNOW/INLVLS) + PSNOWDZ(10)= MIN(ZDZN2,PSNOW/INLVLS) + PSNOWDZ( 9)= MIN(ZDZN3,PSNOW/INLVLS) +! remaining snow for remaining layers + ZWORK = PSNOW - PSNOWDZ( 1) - PSNOWDZ( 2) - PSNOWDZ( 3) & + - PSNOWDZ( 4) - PSNOWDZ( 5) - PSNOWDZ( 9) & + - PSNOWDZ(10) - PSNOWDZ(11) - PSNOWDZ(12) + PSNOWDZ(6) = ZWORK*ZSGCOEF(1) + PSNOWDZ(7) = ZWORK*ZSGCOEF(2) + PSNOWDZ(8) = ZWORK*ZSGCOEF(3) +! layer 6 tickness >= layer 5 tickness + ZWORK=MIN(0.0,PSNOWDZ(6)-PSNOWDZ(5)) + PSNOWDZ(6)=PSNOWDZ(6)-ZWORK + PSNOWDZ(7)=PSNOWDZ(7)+ZWORK +! layer 8 tickness >= layer 9 tickness + ZWORK=MIN(0.0,PSNOWDZ(8)-PSNOWDZ(9)) + PSNOWDZ(8)=PSNOWDZ(8)-ZWORK + PSNOWDZ(7)=PSNOWDZ(7)+ZWORK + ENDIF +! +! 4. Calculate other non-optimized grid to allow CROCUS PREP : +! ------------------------------------------------------------ +! +ELSE IF(INLVLS<10.AND.INLVLS/=3.AND.INLVLS/=6.AND.INLVLS/=9) THEN +! + DO JJ=1,INLVLS + PSNOWDZ(JJ) = PSNOW/INLVLS + ENDDO +! + PSNOWDZ(INLVLS) = PSNOWDZ(INLVLS) + (PSNOWDZ(1) - MIN(0.05, PSNOWDZ(1))) + PSNOWDZ(1) = MIN(0.05, PSNOWDZ(1)) +! +ELSE +! + IF(PRESENT(PSNOWDZ_OLD))THEN + GREGRID = PSNOWDZ_OLD( 1) < ZCOEF1 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD( 1) > ZCOEF2 * MIN(ZDZ1 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD( 2) < ZCOEF1 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD( 2) > ZCOEF2 * MIN(ZDZ2 ,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(INLVLS) < ZCOEF1 * MIN(0.05*PSNOW,PSNOW/INLVLS) .OR. & + & PSNOWDZ_OLD(INLVLS) > ZCOEF2 * MIN(0.05*PSNOW,PSNOW/INLVLS) + ENDIF +! + IF (GREGRID)THEN + PSNOWDZ( 1) = MIN(ZDZ1 ,PSNOW/INLVLS) + PSNOWDZ( 2) = MIN(ZDZ2 ,PSNOW/INLVLS) + PSNOWDZ( 3) = MIN(ZDZ3 ,PSNOW/INLVLS) + PSNOWDZ( 4) = MIN(ZDZ4 ,PSNOW/INLVLS) + PSNOWDZ( 5) = MIN(ZDZ5 ,PSNOW/INLVLS) + PSNOWDZ(INLVLS) = MIN(0.05*PSNOW,PSNOW/INLVLS) + ZWORK = SUM(PSNOWDZ(1:5)) + DO JJ=6,INLVLS-1,1 + PSNOWDZ(JJ) = (PSNOW - ZWORK -PSNOWDZ(INLVLS))/(INLVLS-6) + END DO + ENDIF +! +ENDIF +! +DO JJ=1,INLVLS + IF(PSNOW==XUNDEF)THEN + PSNOWDZ(JJ) = XUNDEF + ELSEIF(.NOT.GREGRID)THEN + PSNOWDZ(JJ) = PSNOWDZ_OLD(JJ) + ENDIF +END DO +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LGRID_1D',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOW3LGRID_1D +! +!################################################################################### +!################################################################################### +SUBROUTINE SNOW3LAGREG(PSNOWDZN,PSNOWDZ,PSNOWRHO,PSNOWGRAN1, PSNOWGRAN2, & + PSNOWHIST,PSNOWGRAN1N,PSNOWGRAN2N,PSNOWHISTN, & + KL1,KL2,PSNOWDDZ ) +! +USE MODD_SNOW_METAMO +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +! 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWDZN,PSNOWDZ,PSNOWRHO,PSNOWDDZ +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST +REAL, DIMENSION(:), INTENT(OUT) :: PSNOWGRAN1N,PSNOWGRAN2N,PSNOWHISTN +! +INTEGER, INTENT(IN) :: KL1 ! Indice couche de reference (i) +INTEGER, INTENT(IN) :: KL2 ! Indice de la couche (i-1 ou i+1) dont une + ! partie est aggregee à la couche (i) +! +! 0.2 declaration of local variables +! +REAL, DIMENSION(SIZE(PSNOWRHO,1)) :: ZSNOWRHO +REAL, DIMENSION(SIZE(PSNOWRHO,1)) :: ZDIAMD,ZDIAMV,ZSPHERD,ZSPHERV,& + ZDIAMN,ZSPHERN,ZDENT +! +REAL :: ZDELTA, ZCOMP +! +INTEGER :: IDENT, IVIEU, IL +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LAGREG',0,ZHOOK_HANDLE) +! +IF( KL10.0 .OR. & + ( PSNOWGRAN1(KL1)==0.0 .AND. PSNOWGRAN1(KL2)>=0.0 ) .OR. & + ( PSNOWGRAN1(KL2)==0.0 .AND. PSNOWGRAN1(KL1)>=0.0 ) ) THEN + ! + !code original vincent PSNOWGRAN1N(KL1)=(PSNOWGRAN1(KL1)*PSNOWRHO(KL1)& + !code original vincent *(PSNOWDZN(KL1)-(1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))-ZDELTA*& + !code original vincent ABS(PSNOWDDZ(KL2)))+PSNOWGRAN1(KL2)* & + !code original vincent PSNOWRHO(KL2)*((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ & + !code original vincent ZDELTA*ABS(PSNOWDDZ(KL2))))/((PSNOWDZN(KL1)-(1.0-ZDELTA)& + !code original vincent *ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2)))* & + !code original vincent PSNOWRHO(KL1)+((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ & + !code original vincent ZDELTA*ABS(PSNOWDDZ(KL2)))*PSNOWRHO(KL2)) + !code original vincent ! + !code original vincent PSNOWGRAN2N(KL1)=(PSNOWGRAN2(KL1)*PSNOWRHO(KL1) & + !code original vincent *(PSNOWDZN(KL1)-(1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))-ZDELTA* & + !code original vincent ABS(PSNOWDDZ(KL2)))+PSNOWGRAN2(KL2)* & + !code original vincent PSNOWRHO(KL2)*((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1)) & + !code original vincent +ZDELTA*ABS(PSNOWDDZ(KL2))))/((PSNOWDZN(KL1)-(1.0-ZDELTA)& + !code original vincent *ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2)))* & + !code original vincent PSNOWRHO(KL1)+((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ & + !code original vincent ZDELTA*ABS(PSNOWDDZ(KL2)))*PSNOWRHO(KL2)) + ! + !plm + CALL GET_AGREG(KL1,KL2,PSNOWGRAN1(KL1),PSNOWGRAN1(KL2),PSNOWGRAN1N(KL1)) + ! + CALL GET_AGREG(KL1,KL2,PSNOWGRAN2(KL1),PSNOWGRAN2(KL2),PSNOWGRAN2N(KL1)) + ! + !plm + ! +ELSE + ! + ! 2.2 Different types + ! + IF ( PSNOWGRAN1(KL1)<0.0 ) THEN + IDENT = KL1 + IVIEU = KL2 + ELSE + IDENT = KL2 + IVIEU = KL1 + ENDIF + ! + ZDIAMD (KL1) = - PSNOWGRAN1(IDENT)/XGRAN * XDIAET + ( 1.0 + PSNOWGRAN1(IDENT)/XGRAN ) * & + ( PSNOWGRAN2(IDENT)/XGRAN * XDIAGF + ( 1.0 - PSNOWGRAN2(IDENT)/XGRAN ) * XDIAFP ) + ! + ZSPHERD(KL1) = PSNOWGRAN2(IDENT)/XGRAN + ZDIAMV (KL1) = PSNOWGRAN2(IVIEU) + ZSPHERV(KL1) = PSNOWGRAN1(IVIEU)/XGRAN + !IF(KL1==1)THEN + !write(*,*) 'ZDD1',ZDIAMD(1),'ZSD1',ZSPHERD(1) + !write(*,*) 'ZDV1',ZDIAMV(1),'ZSV1',ZSPHERV(1) + !ENDIF + ! + IF ( IDENT==KL1 ) THEN + !code original vincent ZDIAMN(KL1)= (ZDIAMD(KL1)*PSNOWRHO(IDENT)*& + !code original vincent (PSNOWDZN(IDENT)-(1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))-ZDELTA* & + !code original vincent ABS(PSNOWDDZ(KL2)))+ZDIAMV(KL1)*PSNOWRHO(IVIEU)*( & + !code original vincent (1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2))))/& + !code original vincent ((PSNOWDZN(KL1)-(1.0-ZDELTA)* & + !code original vincent ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2)))* & + !code original vincent PSNOWRHO(KL1)+((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ & + !code original vincent ZDELTA*ABS(PSNOWDDZ(KL2)))*PSNOWRHO(KL2)) + ! + !plm + CALL GET_AGREG(IDENT,IVIEU,ZDIAMD(KL1),ZDIAMV(KL1),ZDIAMN(KL1)) + ! + !plm + ! + !code original vincent ZSPHERN(KL1)= (ZSPHERD(KL1)*PSNOWRHO(IDENT)*& + !code original vincent (PSNOWDZN(IDENT)-(1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))-ZDELTA* & + !code original vincent ABS(PSNOWDDZ(KL2)))+ZSPHERV(KL1)*PSNOWRHO(IVIEU)*( & + !code original vincent (1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2))))/& + !code original vincent ((PSNOWDZN(KL1)-(1.0-ZDELTA)* & + !code original vincent ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2)))* & + !code original vincent PSNOWRHO(KL1)+((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ & + !code original vincent ZDELTA*ABS(PSNOWDDZ(KL2)))*PSNOWRHO(KL2)) + + !plm + CALL GET_AGREG(IDENT,IVIEU,ZSPHERD(KL1),ZSPHERV(KL1),ZSPHERN(KL1)) + !plm + ! + ELSE + !code original vincent ZDIAMN(KL1)= (ZDIAMD(KL1)*PSNOWRHO(IDENT)*& + !code original vincent ((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ZDELTA*ABS(PSNOWDDZ(KL2)))& + !code original vincent +ZDIAMV(KL1)*PSNOWRHO(IVIEU)*(PSNOWDZN(IVIEU)-(1.0-ZDELTA)* & + !code original vincent ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2))))/& + !code original vincent ((PSNOWDZN(KL1)-(1.0-ZDELTA)* & + !code original vincent ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2)))* & + !code original vincent PSNOWRHO(KL1)+((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ & + !code original vincent ZDELTA*ABS(PSNOWDDZ(KL2)))*PSNOWRHO(KL2)) + !code original vincent! + !code original vincent ZSPHERN(KL1)= (ZSPHERD(KL1)*PSNOWRHO(IDENT)*& + !code original vincent ((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ZDELTA*ABS(PSNOWDDZ(KL2)))& + !code original vincent +ZSPHERV(KL1)*PSNOWRHO(IVIEU)*(PSNOWDZN(IVIEU)-(1.0-ZDELTA)* & + !code original vincent ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2))))/& + !code original vincent ((PSNOWDZN(KL1)-(1.0-ZDELTA)* & + !code original vincent ABS(PSNOWDDZ(KL1))-ZDELTA*ABS(PSNOWDDZ(KL2)))* & + !code original vincent PSNOWRHO(KL1)+((1.0-ZDELTA)*ABS(PSNOWDDZ(KL1))+ & + !code original vincent ZDELTA*ABS(PSNOWDDZ(KL2)))*PSNOWRHO(KL2)) + !plm + ! + CALL GET_AGREG(IVIEU,IDENT,ZDIAMV(KL1),ZDIAMD(KL1),ZDIAMN(KL1)) + ! + CALL GET_AGREG(IVIEU,IDENT,ZSPHERV(KL1),ZSPHERD(KL1),ZSPHERN(KL1)) + !plm + ! + ENDIF + ! + ZCOMP = ZSPHERN(KL1) * XDIAGF + ( 1.-ZSPHERN(KL1) ) * XDIAFP + IF( ZDIAMN(KL1) < ZCOMP ) THEN + ! + ZDENT(KL1) = ( ZDIAMN(KL1) - ZCOMP ) / ( XDIAET - ZCOMP ) + !IF(KL1==1) write(*,*) 'ZDENT',ZDENT(1) + PSNOWGRAN1N(KL1) = - XGRAN * ZDENT (KL1) + PSNOWGRAN2N(KL1) = XGRAN * ZSPHERN(KL1) + ! + ELSE + ! + PSNOWGRAN1N(KL1) = XGRAN * ZSPHERN(KL1) + PSNOWGRAN2N(KL1) = ZDIAMN(KL1) + ! + ENDIF + ! +ENDIF +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LAGREG',1,ZHOOK_HANDLE) +! +! 3. Update snow grains parameters : GRAN1, GRAN2 +! PSNOWGRAN1(KL1)=ZSNOWGRAN1(KL1) +! PSNOWGRAN2(KL1)=ZSNOWGRAN2(KL1) +! + CONTAINS +! +SUBROUTINE GET_AGREG(KID1,KID2,PFIELD1,PFIELD2,PFIELD) +! +INTEGER, INTENT(IN) :: KID1, KID2 +REAL, INTENT(IN) :: PFIELD1, PFIELD2 +REAL, INTENT(OUT) :: PFIELD +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LAGREG:GET_AGREG',0,ZHOOK_HANDLE) +! +PFIELD = ( PFIELD1 * PSNOWRHO(KID1) * ( PSNOWDZN(KID1) - ABS(PSNOWDDZ(IL)) ) & + + PFIELD2 * PSNOWRHO(KID2) * ABS(PSNOWDDZ(IL)) ) / & + ( PSNOWRHO (KL1) * ( PSNOWDZN (KL1) - ABS(PSNOWDDZ(IL)) ) + & + PSNOWRHO (KL2) * ABS(PSNOWDDZ(IL)) ) +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LAGREG:GET_AGREG',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_AGREG +! +END SUBROUTINE SNOW3LAGREG +!############################################################################### +!############################################################################### +! +! +!ajout EB : ajout des arguments "N" pour faire idem variables d'origine +SUBROUTINE SNOW3LAVGRAIN(PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST, & + PSNOWGRAN1N,PSNOWGRAN2N,PSNOWHISTN,PNDENT,PNVIEU,& + HSNOWMETAMO) +! +USE MODD_SNOW_METAMO, ONLY : XVDIAM6, XUEPSI +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +! 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWGRAN1,PSNOWGRAN2,PSNOWHIST +! ajout EB +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWGRAN1N,PSNOWGRAN2N,PSNOWHISTN +! +REAL, DIMENSION(:), INTENT(IN) :: PNDENT, PNVIEU +! + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO +! 0.2 declaration of local variables +! +REAL, DIMENSION(SIZE(PSNOWGRAN1,1)) :: ZGRAN1, ZGRAN2, ZHIST +! +LOGICAL, DIMENSION(SIZE(PSNOWGRAN1,1),SIZE(PSNOWGRAN1,2)) :: GDENDRITIC +! +INTEGER :: JI, JL +INTEGER :: INLVLS, INI +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +! 0.3 initialization +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LAVGRAIN',0,ZHOOK_HANDLE) +! +INLVLS = SIZE(PSNOWGRAN1,2) +INI = SIZE(PSNOWGRAN1,1) +! +ZGRAN1(:) = 0.0 +ZGRAN2(:) = 0.0 +ZHIST (:) = 0.0 +! +DO JI = 1,INI + ! + IF ( PNDENT(JI)==0.0 .AND. PNVIEU(JI)==0.0 ) THEN + ! + ZGRAN1(JI) = 1.0 + ZGRAN2(JI) = 1.0 + ZHIST (JI) = 1.0 + ! + ELSE + ! + DO JL = 1,INLVLS + IF ( HSNOWMETAMO=='B92' ) THEN + GDENDRITIC(JI,JL) = ( PSNOWGRAN1(JI,JL) < 0.0 ) + ELSE + GDENDRITIC(JI,JL) = ( PSNOWGRAN1(JI,JL) < XVDIAM6*(4.-PSNOWGRAN2(JI,JL)) - XUEPSI ) + ENDIF + ENDDO + ! + IF ( PNDENT(JI)>=PNVIEU(JI) ) THEN ! more dendritic than non dendritic snow layer + ! + DO JL = 1,INLVLS + IF ( GDENDRITIC(JI,JL) ) THEN + ZGRAN1(JI) = ZGRAN1(JI) + PSNOWGRAN1(JI,JL) + ZGRAN2(JI) = ZGRAN2(JI) + PSNOWGRAN2(JI,JL) + ENDIF + ENDDO + ! + PSNOWGRAN1N(JI,:) = ZGRAN1(JI) / PNDENT(JI) + PSNOWGRAN2N(JI,:) = ZGRAN2(JI) / PNDENT(JI) + PSNOWHISTN (JI,:) = 0.0 + ! + ELSE ! more non dendritic than dendritic snow layers + ! + DO JL = 1,INLVLS + IF ( .NOT.GDENDRITIC(JI,JL) ) THEN + ZGRAN1(JI) = ZGRAN1(JI) + PSNOWGRAN1(JI,JL) + ZGRAN2(JI) = ZGRAN2(JI) + PSNOWGRAN2(JI,JL) + ZHIST (JI) = ZHIST (JI) + PSNOWHIST (JI,JL) + ENDIF + ENDDO + ! + PSNOWGRAN1N(JI,:) = ZGRAN1(JI) / PNVIEU(JI) + PSNOWGRAN2N(JI,:) = ZGRAN2(JI) / PNVIEU(JI) + PSNOWHISTN (JI,:) = ZHIST (JI) / PNVIEU(JI) + ! + ENDIF + ! + ENDIF + ! +ENDDO + + + +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LAVGRAIN',1,ZHOOK_HANDLE) +! +END SUBROUTINE SNOW3LAVGRAIN +! +!#################################################################### +!#################################################################### +!#################################################################### +FUNCTION SNOW3LDIFTYP(PGRAIN1,PGRAIN2,PGRAIN3,PGRAIN4,HSNOWMETAMO) RESULT(ZDIFTYPE) +! +! à remplacer sans doute par une routine equivalente du nouveau crocus +!* CALCUL DE LA DIFFERENCE ENTRE DEUX TYPES DE GRAINS +! VALEUR ENTRE 200 ET 0 +! +USE MODD_SNOW_METAMO, ONLY : XGRAN, XVDIAM6, XUEPSI +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +!* 0.1 declarations of arguments +REAL, INTENT(IN) :: PGRAIN1, PGRAIN2, PGRAIN3, PGRAIN4 + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO +REAL :: ZDIFTYPE, ZCOEF3, ZCOEF4 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE + +!* 0.2 calcul de la difference entre type de grains +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LDIFTYP',0,ZHOOK_HANDLE) +! +IF ( HSNOWMETAMO=='B92' ) THEN + ! + IF ( ( PGRAIN1<0. .AND. PGRAIN2>=0.) .OR. ( PGRAIN1>=0. .AND. PGRAIN2<0. ) ) THEN + ZDIFTYPE = 200. + ELSEIF ( PGRAIN1<0. ) THEN + ZDIFTYPE = ABS( PGRAIN1-PGRAIN2 ) * .5 + ABS( PGRAIN3-PGRAIN4 ) * .5 + ELSE + ZDIFTYPE = ABS( PGRAIN1-PGRAIN2 ) + ABS( PGRAIN3-PGRAIN4 ) * 5. * 10000. + ENDIF + ! +ELSE + ! + ZCOEF3 = XVDIAM6 * (4.-PGRAIN3) - XUEPSI + ZCOEF4 = XVDIAM6 * (4.-PGRAIN4) - XUEPSI + IF ( ( PGRAIN1=ZCOEF4 ) .OR. ( PGRAIN1>=ZCOEF3 .AND. PGRAIN2 no contribution + ELSEIF ( PSNOWZBOT_OLD(JST_OLD)>=PSNOWZTOP_NEW(JST_NEW) ) THEN + ! JST_OLD higher than JJ_NEW ==> no contribution + ELSE + ! old layer contributes to the new one + ! computation of its contributing ratio and mass/heat + ZPROPOR = ( MIN( PSNOWZTOP_OLD(JST_OLD), PSNOWZTOP_NEW(JST_NEW) ) & + - MAX( PSNOWZBOT_OLD(JST_OLD), PSNOWZBOT_NEW(JST_NEW) ) ) & + / PSNOWDZO(JST_OLD) + ZMASDZ_OLD = ZPROPOR * PSNOWRHOO(JST_OLD) * PSNOWDZO(JST_OLD) +! write(6,*) "zpropor ", zpropor +! write(6,*) "psnowrhoo ", psnowrhoo(jst_old) +! write(6,*) "psnowdzo ", psnowdzo(jst_old) + ! + ZMASTOTN = ZMASTOTN + ZMASDZ_OLD +! write(6,*) "zmastotn ", zmastotn +! write(6,*) "zmasdz_old ", zmasdz_old + ZMASTOT_T07 = ZMASTOT_T07 + 1. + ! + ZSNOWHEAN = ZSNOWHEAN + ZPROPOR * PSNOWHEATO(JST_OLD) + ! + IF ( HSNOWMETAMO=='B92' ) THEN + ! + ! contribution to the grain optical size and then to the albedo + IF ( PSNOWGRAN1O(JST_OLD)<0. ) THEN + ZDIAM = -PSNOWGRAN1O(JST_OLD)*XD1/XX + (1.+PSNOWGRAN1O(JST_OLD)/XX) * & + ( PSNOWGRAN2O(JST_OLD)*XD2/XX + (1.-PSNOWGRAN2O(JST_OLD)/XX)*XD3 ) + ZDIAM = ZDIAM/10000. + ZDENTMOYN = ZDENTMOYN - ZMASDZ_OLD * PSNOWGRAN1O(JST_OLD) / XX + ZSPHERMOYN = ZSPHERMOYN + ZMASDZ_OLD * PSNOWGRAN2O(JST_OLD) / XX + ELSE + ZDIAM = PSNOWGRAN2O(JST_OLD) + ZDENTMOYN = ZDENTMOYN + ZMASDZ_OLD * 0. + ZSPHERMOYN = ZSPHERMOYN + ZMASDZ_OLD * PSNOWGRAN1O(JST_OLD) / XX + ENDIF + ! + ELSE + ! + ZDIAM = PSNOWGRAN1O(JST_OLD) + ZSPHERMOYN = ZSPHERMOYN + ZMASDZ_OLD * PSNOWGRAN2O(JST_OLD) + ! + ENDIF + ! + ZALBMOYN = ZALBMOYN + MAX( 0., ZMASDZ_OLD * (XVALB5-XVALB6*SQRT(ZDIAM)) ) + ZHISTMOYN = ZHISTMOYN + ZMASDZ_OLD * PSNOWHISTO(JST_OLD) + ZAGEMOYN = ZAGEMOYN + ZMASDZ_OLD * PSNOWAGEO (JST_OLD) + ! + ENDIF + ! + ENDDO + ! + ! the new layer inherits from the weihted average properties of the old ones + ! heat and mass + PSNOWHEATN(JST_NEW) = ZSNOWHEAN +! trude test + +! write(6,*) "zmastotn ", zmastotn +! write(6,*) "psnowdzn ", psnowdzn(jst_new) + PSNOWRHON (JST_NEW) = ZMASTOTN / PSNOWDZN(JST_NEW) + ! write(6,*) "psnowrhon ", psnowrhon(jst_new) + ! grain type and size decuced from the average albedo + ZALBMOYN = ZALBMOYN / ZMASTOTN + ZSPHERMOYN = MAX( 0., ZSPHERMOYN/ZMASTOTN ) + ZDENTMOYN = MAX( 0., ZDENTMOYN /ZMASTOTN ) + ZDIAM = ( (XVALB5-ZALBMOYN)/XVALB6 )**2 + ! + IF ( HSNOWMETAMO=='B92' ) THEN + ! + ! size between D2 and D3 and dendricity < 0 + ! sphericity is firts preserved, if possible. If not, + ! denditricity =0 + PSNOWGRAN1N(JST_NEW) = -XX * ZDENTMOYN + ! + IF ( ZDENTMOYN/=1.) THEN + PSNOWGRAN2N(JST_NEW) = XX * ( ( ZDIAM*10000. + PSNOWGRAN1N(JST_NEW)*XD1/XX ) & + / ( 1. + PSNOWGRAN1N(JST_NEW)/XX ) - XD3 ) & + / ( XD2-XD3 ) + ENDIF + ! + ! dendricity is preserved if possible and sphericity is adjusted + IF ( ZDIAM < XD2/10000. - 0.0000001 ) THEN + ! + IF ( ABS( PSNOWGRAN1N(JST_NEW)+XX ) < 0.01 ) THEN + ! + PSNOWGRAN2N(JST_NEW) = XX * ZSPHERMOYN + ! + ELSEIF ( ABS( PSNOWGRAN1N(JST_NEW) ) < 0.0001 ) THEN ! dendritic snow + ! + PSNOWGRAN1N(JST_NEW) = XX * ZSPHERMOYN + PSNOWGRAN2N(JST_NEW) = ZDIAM + ! + ELSEIF ( PSNOWGRAN2N(JST_NEW) < 0. ) THEN ! non dendritic + ! + PSNOWGRAN2N(JST_NEW) = 0. + ! + ELSEIF ( PSNOWGRAN2N(JST_NEW) > XX + 0.0000001 ) THEN ! non dendritic + ! + PSNOWGRAN2N(JST_NEW) = XX + ! + ENDIF + ! + ELSEIF ( ZDIAM > XD3/10000. .OR. ZDENTMOYN <= 0. + 0.0000001 .OR. & + PSNOWGRAN2N(JST_NEW) < 0. .OR. PSNOWGRAN2N(JST_NEW) > XX ) THEN + ! + ! dendritic snow + ! inconsistency with ZDIAM ==> dendricity = 0 + ! size between D2 and D3 and dendricity == 0 + PSNOWGRAN1N(JST_NEW) = XX * ZSPHERMOYN + PSNOWGRAN2N(JST_NEW) = ZDIAM + ! + ENDIF + ! + ELSE + ! + PSNOWGRAN1N(JST_NEW) = ZDIAM + PSNOWGRAN2N(JST_NEW) = MIN( 1., ZSPHERMOYN ) + ! + ENDIF + ! + PSNOWHISTN(JST_NEW) = NINT( ZHISTMOYN/ZMASTOTN ) + PSNOWAGEN (JST_NEW) = ZAGEMOYN / ZMASTOTN + ! +ENDDO +! +!IF (LHOOK) CALL DR_HOOK('GET_MASS_HEAT',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_MASS_HEAT +!#################################################################### +SUBROUTINE GET_DIAM(PSNOWGRAN1,PSNOWGRAN2,PDIAM,HSNOWMETAMO) +! +USE MODD_SNOW_PAR, ONLY : XD1, XD2, XD3, XX +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +REAL, INTENT(IN) :: PSNOWGRAN1 +REAL, INTENT(IN) :: PSNOWGRAN2 +REAL, INTENT(OUT) :: PDIAM +! + CHARACTER(3), INTENT(IN) :: HSNOWMETAMO +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!IF (LHOOK) CALL DR_HOOK('GET_DIAM',0,ZHOOK_HANDLE) +! +IF ( HSNOWMETAMO=='B92' ) THEN + ! + IF( PSNOWGRAN1<0. ) THEN + PDIAM = -PSNOWGRAN1*XD1/XX + (1.+PSNOWGRAN1/XX) * & + ( PSNOWGRAN2*XD2/XX + (1.-PSNOWGRAN2/XX) * XD3 ) + PDIAM = PDIAM/10000. + ELSE + PDIAM = PSNOWGRAN2*PSNOWGRAN1/XX + & + MAX( 0.0004, 0.5*PSNOWGRAN2 ) * ( 1.-PSNOWGRAN1/XX ) + ENDIF + ! +ELSE + ! + PDIAM = PSNOWGRAN1 + ! +ENDIF +! +!IF (LHOOK) CALL DR_HOOK('GET_DIAM',1,ZHOOK_HANDLE) +! +END SUBROUTINE GET_DIAM +!#################################################################### +!#################################################################### +!#################################################################### +!#################################################################### +!#################################################################### +!#################################################################### + SUBROUTINE SNOW3LTHRM(PSNOWRHO,PSCOND,PSNOWTEMP,PPS) +! +!! PURPOSE +!! ------- +! Calculate snow thermal conductivity from +! Sun et al. 1999, J. of Geophys. Res., 104, 19587-19579 (vapor) +! and Yen, 1981, CRREL Rep 81-10 (snow) +! or Anderson, 1976, NOAA Tech. Rep. NWS 19 (snow). +! +! +USE MODD_CSTS, ONLY : XP00, XCONDI, XRHOLW +! +USE MODD_SNOW_PAR, ONLY : XVRKZ6, XSNOWTHRMCOND1, & + XSNOWTHRMCOND2, & + XSNOWTHRMCOND_AVAP, & + XSNOWTHRMCOND_BVAP, & + XSNOWTHRMCOND_CVAP +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PPS +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWTEMP, PSNOWRHO +! +REAL, DIMENSION(:,:), INTENT(OUT) :: PSCOND +! +! +!* 0.2 declarations of local variables +! +INTEGER :: JJ, JI +! +INTEGER :: INI +INTEGER :: INLVLS +! + CHARACTER(LEN=5) :: YSNOWCOND !should be in namelist +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LTHRM',0,ZHOOK_HANDLE) +! +INI = SIZE(PSNOWRHO(:,:),1) +INLVLS = SIZE(PSNOWRHO(:,:),2) +! +! 1. Snow thermal conductivity +! ---------------------------- +! +YSNOWCOND='YEN81' !should be in namelist +! +IF(YSNOWCOND=='AND76')THEN +! Thermal conductivity coefficients from Anderson (1976) + PSCOND(:,:) = (XSNOWTHRMCOND1 + XSNOWTHRMCOND2*PSNOWRHO(:,:)*PSNOWRHO(:,:)) +ELSE +! Thermal conductivity coefficients from Yen (1981) + PSCOND(:,:) = XCONDI * EXP(XVRKZ6*LOG(PSNOWRHO(:,:)/XRHOLW)) +ENDIF +! +! 2. Implicit vapor diffn effects +! ------------------------------- +! +DO JJ=1,INLVLS + DO JI=1,INI + PSCOND(JI,JJ) = PSCOND(JI,JJ) + MAX(0.0,(XSNOWTHRMCOND_AVAP+(XSNOWTHRMCOND_BVAP/(PSNOWTEMP(JI,JJ) & + + XSNOWTHRMCOND_CVAP)))*(XP00/PPS(JI))) + ENDDO +ENDDO +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LTHRM',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE SNOW3LTHRM +!#################################################################### +!#################################################################### +!#################################################################### +FUNCTION SNOW3LDOPT_2D(PSNOWRHO,PSNOWAGE) RESULT(PDOPT) +! +!! PURPOSE +!! ------- +! Calculate the optical grain diameter. +! +USE MODD_SNOW_PAR, ONLY : XDSGRAIN_MAX,XSNOW_AGRAIN, & + XSNOW_BGRAIN,XSNOW_CGRAIN +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PSNOWRHO,PSNOWAGE +! +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: PDOPT +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZAGE +REAL, DIMENSION(SIZE(PSNOWRHO,1),SIZE(PSNOWRHO,2)) :: ZSRHO4 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LDOPT_2D',0,ZHOOK_HANDLE) +! +ZAGE(:,:) = MIN(15.,PSNOWAGE(:,:)) +! +ZSRHO4(:,:) = PSNOWRHO(:,:)*PSNOWRHO(:,:)*PSNOWRHO(:,:)*PSNOWRHO(:,:) +! +PDOPT(:,:) = MIN(XDSGRAIN_MAX,XSNOW_AGRAIN+XSNOW_BGRAIN*ZSRHO4(:,:)+XSNOW_CGRAIN*ZAGE(:,:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LDOPT_2D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LDOPT_2D +!#################################################################### +FUNCTION SNOW3LDOPT_1D(PSNOWRHO,PSNOWAGE) RESULT(PDOPT) +! +!! PURPOSE +!! ------- +! Calculate the optical grain diameter. +! +USE MODD_SNOW_PAR, ONLY : XDSGRAIN_MAX,XSNOW_AGRAIN, & + XSNOW_BGRAIN,XSNOW_CGRAIN +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWRHO,PSNOWAGE +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: PDOPT +REAL, DIMENSION(SIZE(PSNOWRHO)) :: ZAGE +REAL, DIMENSION(SIZE(PSNOWRHO)) :: ZSRHO4 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LDOPT_1D',0,ZHOOK_HANDLE) +! +ZAGE(:) = MIN(15.,PSNOWAGE(:)) +! +ZSRHO4(:) = PSNOWRHO(:)*PSNOWRHO(:)*PSNOWRHO(:)*PSNOWRHO(:) +! +PDOPT(:) = MIN(XDSGRAIN_MAX,XSNOW_AGRAIN+XSNOW_BGRAIN*ZSRHO4(:)+XSNOW_CGRAIN*ZAGE(:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LDOPT_1D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LDOPT_1D +!#################################################################### +FUNCTION SNOW3LDOPT_0D(PSNOWRHO,PSNOWAGE) RESULT(PDOPT) +! +!! PURPOSE +!! ------- +! Calculate the optical grain diameter. +! +USE MODD_SNOW_PAR, ONLY : XDSGRAIN_MAX,XSNOW_AGRAIN, & + XSNOW_BGRAIN,XSNOW_CGRAIN +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, INTENT(IN) :: PSNOWRHO,PSNOWAGE +! +REAL :: PDOPT +REAL :: ZAGE +REAL :: ZSRHO4 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LDOPT_0D',0,ZHOOK_HANDLE) +! +ZAGE = MIN(15.,PSNOWAGE) +! +ZSRHO4 = PSNOWRHO*PSNOWRHO*PSNOWRHO*PSNOWRHO +! +PDOPT = MIN(XDSGRAIN_MAX,XSNOW_AGRAIN+XSNOW_BGRAIN*ZSRHO4+XSNOW_CGRAIN*ZAGE) +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LDOPT_0D',1,ZHOOK_HANDLE) +! +END FUNCTION SNOW3LDOPT_0D +!#################################################################### +!#################################################################### +!#################################################################### +SUBROUTINE SNOW3LALB(PALBEDOSC,PSPECTRALALBEDO,PSNOWRHO,PSNOWAGE, & + PPERMSNOWFRAC,PPS) +! +!! PURPOSE +!! ------- +! Calculate the snow surface albedo. Use the method of +! CROCUS with 3 spectral albedo depending on snow density +! and age +! +! +USE MODD_SNOW_PAR, ONLY : XVAGING_GLACIER, XVAGING_NOGLACIER, & + XVALB2,XVALB3,XVALB4,XVALB5,XVALB6, & + XVALB7,XVALB8,XVALB9,XVALB10,XVALB11, & + XVDIOP1,XVRPRE1,XVRPRE2,XVPRES1, & + XVW1,XVW2,XVSPEC1,XVSPEC2,XVSPEC3 +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:), INTENT(IN) :: PSNOWRHO +REAL, DIMENSION(:), INTENT(IN) :: PSNOWAGE +REAL, DIMENSION(:), INTENT(IN) :: PPERMSNOWFRAC +REAL, DIMENSION(:), INTENT(IN) :: PPS +! +REAL, DIMENSION(:), INTENT(INOUT) :: PALBEDOSC +REAL, DIMENSION(:,:), INTENT(INOUT) :: PSPECTRALALBEDO +! +!* 0.2 declarations of local variables +! +REAL, PARAMETER :: ZALBNIR1 = 0.3 +REAL, PARAMETER :: ZALBNIR2 = 0.0 +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: ZVAGING, ZDIAM, ZAGE, & + ZWORK, ZPRES_EFFECT +! +REAL, DIMENSION(SIZE(PSNOWRHO)) :: ZALB1, ZALB2, ZALB3 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LALB',0,ZHOOK_HANDLE) +! +! 0. Initialize: +! ------------------ +! +!Snow age effect parameter for Visible (small over glacier) +ZVAGING(:)=XVAGING_GLACIER*PPERMSNOWFRAC(:) + XVAGING_NOGLACIER*(1.0-PPERMSNOWFRAC(:)) +! +!Atm pression effect parameter on albedo +ZPRES_EFFECT(:) = XVALB10*MIN(MAX(PPS(:)/XVPRES1,XVRPRE1),XVRPRE2) +! +! 1. Snow optical grain diameter : +! -------------------------------- +! +!Snow optical diameter do not depend on snow age over glacier or polar regions +ZAGE(:) = (1.0-PPERMSNOWFRAC(:))*PSNOWAGE(:) +! +ZDIAM(:) = SNOW3LDOPT(PSNOWRHO(:),ZAGE(:)) +! +! 2. spectral albedo over 3 bands : +! --------------------------------- +! +!Snow age effect limited to 1 year +ZAGE(:) = MIN(365.,PSNOWAGE(:)) +! +ZWORK(:)=SQRT(ZDIAM(:)) +! +! Visible +ZALB1(:)=MIN(XVALB4,XVALB2-XVALB3*ZWORK(:)) +ZALB1(:)=MAX(XVALB11,ZALB1(:)-ZPRES_EFFECT(:)*ZAGE(:)/ZVAGING(:)) +! +! near Infra-red 1 +ZALB2(:)=XVALB5-XVALB6*ZWORK(:) +ZALB2(:)=MAX(ZALBNIR1,ZALB2(:)) +! +! near Infra-red 2 +ZDIAM(:)=MIN(XVDIOP1,ZDIAM(:)) +ZWORK(:)=SQRT(ZDIAM(:)) +ZALB3(:)=XVALB7*ZDIAM(:)-XVALB8*ZWORK(:)+XVALB9 +ZALB3(:)=MAX(ZALBNIR2,ZALB3(:)) +! +PSPECTRALALBEDO(:,1)=ZALB1(:) +PSPECTRALALBEDO(:,2)=ZALB2(:) +PSPECTRALALBEDO(:,3)=ZALB3(:) +! +! 3. total albedo : +! ----------------- +! +PALBEDOSC(:)=XVSPEC1*ZALB1(:)+XVSPEC2*ZALB2(:)+XVSPEC3*ZALB3(:) +! +!IF (LHOOK) CALL DR_HOOK('MODE_SNOW3L:SNOW3LALB',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE SNOW3LALB +!#################################################################### +!#################################################################### +!#################################################################### +END MODULE MODE_SNOW3L + diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_surf_coefs.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_surf_coefs.F new file mode 100644 index 000000000..766097ba2 --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_surf_coefs.F @@ -0,0 +1,485 @@ +MODULE MODE_SURF_COEFS + +!++Trude. To reduce the numbers of module used, I merged module modi_surface_aero_cond, modi_surface_cd and modi_surface_ri into one module. + +!++ Trude: Also included wind_threshold function +CONTAINS + +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ###################################################################### + SUBROUTINE SURFACE_AERO_COND(PRI, PZREF, PUREF, PVMOD, PZ0,& + PZ0H, PAC, PRA, PCH ) +! ###################################################################### +! +!!**** *SURFACE_AERO_COND* +!! +!! PURPOSE +!! ------- +! +! Computes the drag coefficients for heat and momentum near the ground +! +! +!!** METHOD +!! ------ +! +! +! +! 1 and 2 : computation of relative humidity near the ground +! +! 3 : richardson number +! +! 4 : the aerodynamical resistance for heat transfers is deduced +! +! 5 : the drag coefficient for momentum ZCD is computed +! +! +!! EXTERNAL +!! -------- +!! +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! MODD_CST +!! +!! +!! REFERENCE +!! --------- +!! +!! +!! AUTHOR +!! ------ +!! +!! V. Masson * Meteo-France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 20/01/98 +!! 02/04/01 (P Jabouille) limitation of Z0 with 0.5 PUREF +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS,ONLY : XKARMAN +!USE MODI_WIND_THRESHOLD +! +USE MODE_THERMOS +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +! +REAL, DIMENSION(:), INTENT(IN) :: PRI ! Richardson number +REAL, DIMENSION(:), INTENT(IN) :: PVMOD ! module of the horizontal wind +REAL, DIMENSION(:), INTENT(IN) :: PZREF ! reference height of the first + ! atmospheric level +REAL, DIMENSION(:), INTENT(IN) :: PUREF ! reference height of the wind + ! NOTE this is different from ZZREF + ! ONLY in stand-alone/forced mode, + ! NOT when coupled to a model (MesoNH) +REAL, DIMENSION(:), INTENT(IN) :: PZ0 ! roughness length for momentum +REAL, DIMENSION(:), INTENT(IN) :: PZ0H ! roughness length for heat +! +REAL, DIMENSION(:), INTENT(OUT) :: PAC ! aerodynamical conductance +REAL, DIMENSION(:), INTENT(OUT) :: PRA ! aerodynamical resistance +REAL, DIMENSION(:), INTENT(OUT) :: PCH ! drag coefficient for heat +! +!* 0.2 declarations of local variables +! +! +REAL, DIMENSION(SIZE(PRI)) :: ZZ0, ZZ0H, ZMU, & + ZFH, ZCHSTAR, ZPH, ZCDN, & + ZSTA, ZDI, ZWORK1, ZWORK2, ZWORK3 +REAL, DIMENSION(SIZE(PRI)) :: ZVMOD +! +INTEGER :: JJ +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +! Functions: +REAL :: X, CHSTAR, PH + CHSTAR(X) = 3.2165 + 4.3431*X + 0.5360*X*X - 0.0781*X*X*X +PH (X) = 0.5802 - 0.1571*X + 0.0327*X*X - 0.0026*X*X*X +! +!------------------------------------------------------------------------------- +! +!* 4. Surface aerodynamic resistance for heat transfers +! ------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('SURFACE_AERO_COND',0,ZHOOK_HANDLE) +ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:)) +! +DO JJ=1,SIZE(PRI) +!write(*,*) PZ0(jj), puref(jj), zz0(jj), pz0h(jj) + ZZ0(JJ) = MIN(PZ0(JJ),PUREF(JJ)*0.5) + ZZ0H(JJ) = MIN(ZZ0(JJ),PZ0H(JJ)) + ZZ0H(JJ) = MIN(ZZ0H(JJ),PZREF(JJ)*0.5) +! + ZWORK1(JJ)=LOG( PUREF(JJ)/ZZ0(JJ) ) + ZWORK2(JJ)=PZREF(JJ)/ZZ0H(JJ) + ZWORK3(JJ)=ZVMOD(JJ)*ZVMOD(JJ) + + ZMU(JJ) = MAX( LOG( ZZ0(JJ)/ZZ0H(JJ) ), 0.0 ) + ZFH(JJ) = ZWORK1(JJ) / LOG(ZWORK2(JJ)) +! + ZCHSTAR(JJ) = CHSTAR(ZMU(JJ)) + ZPH(JJ) = PH(ZMU(JJ)) +! +! + ZCDN(JJ) = (XKARMAN/ZWORK1(JJ))**2. +! +! + ZSTA(JJ) = PRI(JJ)*ZWORK3(JJ) +! +! + IF ( PRI(JJ) < 0.0 ) THEN + ZDI(JJ) = 1. / ( ZVMOD(JJ) & + +ZCHSTAR(JJ)*ZCDN(JJ)*15. & + *ZWORK2(JJ)**ZPH(JJ) & + *ZFH(JJ) * SQRT(-ZSTA(JJ)) & + ) + PAC(JJ) = ZCDN(JJ)*(ZVMOD(JJ)-15.* ZSTA(JJ)*ZDI(JJ))*ZFH(JJ) + + ELSE + ZDI(JJ) = SQRT(ZWORK3(JJ) + 5. * ZSTA(JJ) ) + PAC(JJ) = ZCDN(JJ)*ZVMOD(JJ)/(1.+15.*ZSTA(JJ)*ZDI(JJ) & + / ZWORK3(JJ) /ZVMOD(JJ) )*ZFH(JJ) + ENDIF +! + PRA(JJ) = 1. / PAC(JJ) +! + PCH(JJ) = 1. / (PRA(JJ) * ZVMOD(JJ)) +! +ENDDO +!IF (LHOOK) CALL DR_HOOK('SURFACE_AERO_COND',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE SURFACE_AERO_COND + +! ################################################################# + SUBROUTINE SURFACE_CD(PRI, PZREF, PUREF, PZ0EFF, PZ0H, & + PCD, PCDN) +! ################################################################# +! +!!**** *SURFACE_CD* +!! +!! PURPOSE +!! ------- +! +! Computes the drag coefficients for momentum near the ground +! +! +!!** METHOD +!! ------ +! +! +! +! 1 and 2 : computation of relative humidity near the ground +! +! 3 : richardson number +! +! 4 : the aerodynamical resistance for heat transfers is deduced +! +! 5 : the drag coefficient for momentum ZCD is computed +! +! +!! EXTERNAL +!! -------- +!! +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! MODD_CST +!! MODD_GROUND_PAR +!! +!! +!! REFERENCE +!! --------- +!! +!! +!! AUTHOR +!! ------ +!! +!! V. Masson * Meteo-France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 20/01/98 +!! 02/04/01 (P Jabouille) limitation of Z0 with 0.5 PUREF +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS,ONLY : XKARMAN +! +USE MODE_THERMOS +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +! +REAL, DIMENSION(:), INTENT(IN) :: PRI ! Richardson number +REAL, DIMENSION(:), INTENT(IN) :: PZREF ! reference height of the first + ! atmospheric level +REAL, DIMENSION(:), INTENT(IN) :: PUREF ! reference height of the wind +! ! NOTE this is different from ZZREF +! ! ONLY in stand-alone/forced mode, +! ! NOT when coupled to a model (MesoNH) +REAL, DIMENSION(:), INTENT(IN) :: PZ0EFF ! roughness length for momentum + ! with subgrid-scale orography +REAL, DIMENSION(:), INTENT(IN) :: PZ0H ! roughness length for heat +! +REAL, DIMENSION(:), INTENT(OUT) :: PCD ! drag coefficient for momentum +REAL, DIMENSION(:), INTENT(OUT) :: PCDN ! neutral drag coefficient for momentum +! +!* 0.2 declarations of local variables +! +! +REAL :: ZZ0EFF, ZZ0H, ZMU, & + ZCMSTAR, ZPM, ZCM, ZFM +INTEGER :: JJ +!REAL(KIND=JPRB) :: ZHOOK_HANDLE + +! Functions : +REAL :: X, CMSTAR, PM + CMSTAR(X) = 6.8741 + 2.6933*X - 0.3601*X*X + 0.0154*X*X*X +PM (X) = 0.5233 - 0.0815*X + 0.0135*X*X - 0.0010*X*X*X + +!------------------------------------------------------------------------------- +! +!* 1. Drag coefficient for momentum transfers +! --------------------------------------- +! + +! +!IF (LHOOK) CALL DR_HOOK('SURFACE_CD',0,ZHOOK_HANDLE) +DO JJ=1,SIZE(PRI) + ZZ0EFF = MIN(PZ0EFF(JJ),PUREF(JJ)*0.5) + ZZ0H = MIN(ZZ0EFF,PZ0H(JJ)) +! + ZMU = LOG( MIN(ZZ0EFF/ZZ0H,200.) ) +! + PCDN(JJ) = (XKARMAN/LOG(PUREF(JJ)/ZZ0EFF))**2 + + ZCMSTAR = CMSTAR(ZMU) + ZPM = PM(ZMU) +! + ZCM = 10.*ZCMSTAR*PCDN(JJ)*( PUREF(JJ)/ZZ0EFF )**ZPM +! + IF ( PRI(JJ) > 0.0 ) THEN + ZFM = 1. + 10.*PRI(JJ) / SQRT( 1.+5.*PRI(JJ) ) + ZFM = 1. / ZFM + ELSE + ZFM = 1. - 10.*PRI(JJ) / ( 1.+ZCM*SQRT(-PRI(JJ)) ) + ENDIF +! + PCD(JJ) = PCDN(JJ)*ZFM +! +ENDDO +!IF (LHOOK) CALL DR_HOOK('SURFACE_CD',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE SURFACE_CD + +! ######### + SUBROUTINE SURFACE_RI(PTG, PQS, PEXNS, PEXNA, PTA, PQA, & + PZREF, PUREF, PDIRCOSZW, PVMOD, PRI ) +! ###################################################################### +! +!!**** *SURFACE_RI* +!! +!! PURPOSE +!! ------- +! +! Computes the richardson number near the ground +! +! +!!** METHOD +!! ------ +! +! +! +! +!! EXTERNAL +!! -------- +!! +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! MODD_CST +!! MODD_GROUND_PAR +!! +!! +!! REFERENCE +!! --------- +!! +!! +!! AUTHOR +!! ------ +!! +!! V. Masson * Meteo-France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 22/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS, ONLY : XRV, XRD, XG +USE MODD_SURF_ATM, ONLY : XRIMAX +!USE MODI_WIND_THRESHOLD +! +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +! +REAL, DIMENSION(:), INTENT(IN) :: PTG ! surface temperature +REAL, DIMENSION(:), INTENT(IN) :: PQS ! surface specific humidity +REAL, DIMENSION(:), INTENT(IN) :: PEXNS ! surface exner function +REAL, DIMENSION(:), INTENT(IN) :: PTA ! temperature at the lowest level +REAL, DIMENSION(:), INTENT(IN) :: PQA ! specific humidity + ! at the lowest level +REAL, DIMENSION(:), INTENT(IN) :: PEXNA ! exner function + ! at the lowest level +REAL, DIMENSION(:), INTENT(IN) :: PVMOD ! module of the horizontal wind +! +REAL, DIMENSION(:), INTENT(IN) :: PZREF ! reference height of the first + ! atmospheric level +REAL, DIMENSION(:), INTENT(IN) :: PUREF ! reference height of the wind +! ! NOTE this is different from ZZREF +! ! ONLY in stand-alone/forced mode, +! ! NOT when coupled to a model (MesoNH) +REAL, DIMENSION(:), INTENT(IN) :: PDIRCOSZW! Cosine of the angle between +! ! the normal to the surface and +! ! the vertical +! +REAL, DIMENSION(:), INTENT(OUT) :: PRI ! Richardson number +! +!* 0.2 declarations of local variables +! +! +REAL, DIMENSION(SIZE(PTG)) :: ZTHVA, ZTHVS +REAL, DIMENSION(SIZE(PVMOD)) :: ZVMOD +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +! 1. Richardson number +! ----------------- +! +! virtual potential +! temperature at the +! first atmospheric level and +! at the surface +! +!IF (LHOOK) CALL DR_HOOK('SURFACE_RI',0,ZHOOK_HANDLE) +! +ZTHVA(:)=PTA(:)/PEXNA(:)*( 1.+(XRV/XRD-1.)*PQA(:) ) +ZTHVS(:)=PTG(:)/PEXNS(:)*( 1.+(XRV/XRD-1.)*PQS(:) ) +! +ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:)) +! + ! Richardson's number +PRI(:) = XG * PDIRCOSZW(:) * PUREF(:) * PUREF(:) & + * (ZTHVA(:)-ZTHVS(:)) / (0.5 * (ZTHVA(:)+ZTHVS(:)) ) & + / (ZVMOD(:)*ZVMOD(:)) /PZREF(:) +! +PRI(:) = MIN(PRI(:),XRIMAX) +! +!IF (LHOOK) CALL DR_HOOK('SURFACE_RI',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END SUBROUTINE SURFACE_RI + + +! ######### + FUNCTION WIND_THRESHOLD(PWIND,PUREF) RESULT(PWIND_NEW) +! ############################################################################ +! +!!**** *WIND_THRESHOLD* +!! +!! PURPOSE +!! ------- +! +! Set a minimum value to the wind for exchange coefficient computations. +! This minimum value depends on the forcing height +! +!! AUTHOR +!! ------ +!! +!! V. Masson * Meteo-France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 09/2007 +!------------------------------------------------------------------------------- +! +USE MODD_SURF_ATM, ONLY: XCISMIN, XVMODMIN, LALDTHRES +! +!* 0. DECLARATIONS +! ------------ +! +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +! +REAL, DIMENSION(:), INTENT(IN) :: PWIND ! wind +REAL, DIMENSION(:), INTENT(IN) :: PUREF ! forcing level +! +REAL, DIMENSION(SIZE(PWIND)) :: PWIND_NEW ! modified wind +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! +! +! +!* 0.2 declarations of local variables +! +!------------------------------------------------------------------------------- +! +! wind gradient +! +!IF (LHOOK) CALL DR_HOOK('WIND_THRESHOLD',0,ZHOOK_HANDLE) +IF (.NOT.LALDTHRES) THEN +! +! minimum value for exchange coefficients computations : 1m/s / 10m + PWIND_NEW = MAX(PWIND , 0.1 * MIN(10.,PUREF) ) +ELSE +! minimum value for exchange coefficients computations : 1m/s / 10m + PWIND_NEW = MAX( XVMODMIN, SQRT( PWIND**2 + (XCISMIN*PUREF)**2 ) ) +ENDIF +!IF (LHOOK) CALL DR_HOOK('WIND_THRESHOLD',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END FUNCTION WIND_THRESHOLD + + + + +END MODULE MODE_SURF_COEFS diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_thermos.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_thermos.F new file mode 100644 index 000000000..75968e339 --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/mode_thermos.F @@ -0,0 +1,1314 @@ +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +! ######spl + MODULE MODE_THERMOS +! #################### +! +!!**** *MODE_THERMO* - +!! +!! PURPOSE +!! ------- +! +! +!! +!!** IMPLICIT ARGUMENTS +!! ------------------ +!! NONE +!! +!! REFERENCE +!! --------- +!! +!! +!! AUTHOR +!! ------ +!! V. Ducrocq * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 28/08/94 +!! Modified 01/2006 : sea flux parameterization. +!! B. Decharme 05/2013 : Qsat function of XTT +!! so, Qsat=Qsati if Tg <= XTT and inversely +!! S. Belamari 03/2014 : new formula (QSAT_SEAWATER2) for sat. air pressure +!! over seawater (with explicit salinity dependency) +!! +!-------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +!------------------------------------------------------------------------------- +! +! +!USE YOMHOOK ,ONLY : LHOOK, DR_HOOK +!USE PARKIND1 ,ONLY : JPRB +! +INTERFACE PSAT + MODULE PROCEDURE PSAT_0D + MODULE PROCEDURE PSAT_1D + MODULE PROCEDURE PSAT_2D +END INTERFACE +INTERFACE DPSAT + MODULE PROCEDURE DPSAT_1D +END INTERFACE + +INTERFACE QSAT + MODULE PROCEDURE QSATW_0D + MODULE PROCEDURE QSATW_1D + MODULE PROCEDURE QSATW_2D +END INTERFACE +INTERFACE QSAT_SEAWATER + MODULE PROCEDURE QSATSEAW_1D +END INTERFACE +INTERFACE QSAT_SEAWATER2 + MODULE PROCEDURE QSATSEAW2_1D +END INTERFACE +INTERFACE DQSAT + MODULE PROCEDURE DQSATW_O_DT_1D +END INTERFACE +INTERFACE QSATI + MODULE PROCEDURE QSATI_1D + MODULE PROCEDURE QSATI_2D +END INTERFACE +INTERFACE DQSATI + MODULE PROCEDURE DQSATI_O_DT_1D +END INTERFACE + CONTAINS +!------------------------------------------------------------------------------- +! ###################################### + FUNCTION PSAT_0D(PT) RESULT(PPSAT) +! ###################################### +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +!++ Trude, moved CQSAT to MODD_SNOW_PAR +!USE MODD_REPROD_OPER, ONLY : CQSAT +USE MODD_SNOW_PAR +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, INTENT(IN) :: PT ! Temperature (Kelvin) +REAL :: PPSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +REAL :: ZALP, ZBETA, ZGAM +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:PSAT_0D',0,ZHOOK_HANDLE) +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! + +ZALP = XALPW +ZBETA = XBETAW +ZGAM = XGAMW +! +IF(CQSAT=='NEW'.AND.PT<=XTT)THEN + ZALP = XALPI + ZBETA = XBETAI + ZGAM = XGAMI +ENDIF +! +PPSAT = EXP( ZALP - ZBETA/PT - ZGAM*LOG(PT) ) +! +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:PSAT_0D',1,ZHOOK_HANDLE) +! +END FUNCTION PSAT_0D +!------------------------------------------------------------------------------- +! ###################################### + FUNCTION PSAT_1D(PT) RESULT(PPSAT) +! ###################################### +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +!++ Trude, moved CQSAT to MODD_SNOW_PAR +!USE MODD_REPROD_OPER, ONLY : CQSAT +USE MODD_SNOW_PAR +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature (Kelvin) +REAL, DIMENSION(SIZE(PT)) :: PPSAT ! saturation vapor pressure (Pa) +! +REAL, DIMENSION(SIZE(PT)) :: ZALP, ZBETA, ZGAM +! +INTEGER :: JJ !loop index +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:PSAT_1D',0,ZHOOK_HANDLE) +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! + +ZALP (:) = XALPW +ZBETA(:) = XBETAW +ZGAM (:) = XGAMW +! +IF(CQSAT=='NEW')THEN + WHERE(PT<=XTT) + ZALP (:) = XALPI + ZBETA (:) = XBETAI + ZGAM (:) = XGAMI + ENDWHERE +ENDIF +! +!cdir nodep +DO JJ=1,SIZE(PT) + PPSAT(JJ) = EXP( ZALP(JJ) - ZBETA(JJ)/PT(JJ) - ZGAM(JJ)*LOG(PT(JJ)) ) +ENDDO +! +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:PSAT_1D',1,ZHOOK_HANDLE) +! +END FUNCTION PSAT_1D +!------------------------------------------------------------------------------- +! ###################################### + FUNCTION PSAT_2D(PT,KMASK) RESULT(PPSAT) +! ###################################### +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +!++ Trude, moved CQSAT to MODD_SNOW_PAR +!USE MODD_REPROD_OPER, ONLY : CQSAT +USE MODD_SNOW_PAR + +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:,:), INTENT(IN) :: PT ! Temperature (Kelvin) +INTEGER, DIMENSION(:), INTENT(IN) :: KMASK +! +REAL, DIMENSION(SIZE(PT,1),SIZE(PT,2)) :: PPSAT ! saturation vapor pressure (Pa) +! +REAL, DIMENSION(SIZE(PT,1),SIZE(PT,2)) :: ZALP, ZBETA, ZGAM +! +INTEGER :: JJ, JL, INI, INL, IWORK !loop index +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:PSAT_2D',0,ZHOOK_HANDLE) +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! + +INI=SIZE(PT,1) +INL=SIZE(PT,2) +! +PPSAT(:,:) = 0.0 +! +ZALP (:,:) = XALPW +ZBETA(:,:) = XBETAW +ZGAM (:,:) = XGAMW +! +IF(CQSAT=='NEW')THEN + WHERE(PT(:,:)<=XTT) + ZALP (:,:) = XALPI + ZBETA (:,:) = XBETAI + ZGAM (:,:) = XGAMI + ENDWHERE +ENDIF +! +DO JL=1,INL + DO JJ=1,INI + IWORK=KMASK(JJ) + IF(JL<=IWORK)THEN + PPSAT(JJ,JL) = EXP( ZALP(JJ,JL) - ZBETA(JJ,JL)/PT(JJ,JL) - ZGAM(JJ,JL)*LOG(PT(JJ,JL)) ) + ENDIF + ENDDO +ENDDO +! +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:PSAT_2D',1,ZHOOK_HANDLE) +! +END FUNCTION PSAT_2D +!------------------------------------------------------------------------------- +! ###################################### + FUNCTION DPSAT_1D(PT) RESULT(PDPSAT) +! ###################################### +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +!++ Trude moved CQSAT to MODD_SNOW_PAR +!USE MODD_REPROD_OPER, ONLY : CQSAT +USE MODD_SNOW_PAR +! +IMPLICIT NONE + +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature (Kelvin) +! +REAL, DIMENSION(SIZE(PT)) :: PDPSAT +! +REAL, DIMENSION(SIZE(PT)) :: ZBETA, ZGAM +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:DPSAT_1D',0,ZHOOK_HANDLE) +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! + +ZBETA(:) = XBETAW +ZGAM (:) = XGAMW +! +IF(CQSAT=='NEW')THEN + WHERE(PT<=XTT) + ZBETA (:) = XBETAI + ZGAM (:) = XGAMI + ENDWHERE +ENDIF +! +PDPSAT(:) = ZBETA(:)/PT(:)**2 - ZGAM(:)/PT(:) +! +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:DPSAT_1D',1,ZHOOK_HANDLE) +! +END FUNCTION DPSAT_1D +!------------------------------------------------------------------------------- +! ###################################### + FUNCTION QSATW_0D(PT,PP) RESULT(PQSAT) +! ###################################### +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! +!! es(T)= EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMW) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPW : Constant for saturation vapor pressure function +!! XBETAW : Constant for saturation vapor pressure function +!! XGAMW : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! +!! +!! AUTHOR +!! ------ +!! V. Masson * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 21/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, INTENT(IN) :: PT ! Temperature (Kelvin) +REAL, INTENT(IN) :: PP ! Pressure (Pa) +REAL :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL :: ZWORK1 +REAL :: ZWORK2 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATW_0D',0,ZHOOK_HANDLE) +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZFOES = PSAT(PT) +ZWORK1 = ZFOES/PP +ZWORK2 = XRD/XRV +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +PQSAT = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1) +! +!------------------------------------------------------------------------------- +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATW_0D',1,ZHOOK_HANDLE) +! +END FUNCTION QSATW_0D +!------------------------------------------------------------------------------- +! +! ###################################### + FUNCTION QSATW_1D(PT,PP) RESULT(PQSAT) +! ###################################### +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! +!! es(T)= EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMW) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPW : Constant for saturation vapor pressure function +!! XBETAW : Constant for saturation vapor pressure function +!! XGAMW : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! +!! +!! AUTHOR +!! ------ +!! V. Masson * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 21/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:), INTENT(IN) :: PP ! Pressure + ! (Pa) +REAL, DIMENSION(SIZE(PT)) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL, DIMENSION(SIZE(PT)) :: ZWORK1 +REAL :: ZWORK2 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATW_1D',0,ZHOOK_HANDLE) +! +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZFOES (:) = PSAT(PT(:)) +ZWORK1(:) = ZFOES(:)/PP(:) +ZWORK2 = XRD/XRV +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +PQSAT(:) = ZWORK2*ZWORK1(:) / (1.+(ZWORK2-1.)*ZWORK1(:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATW_1D',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END FUNCTION QSATW_1D +! +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! +! ###################################### + FUNCTION QSATW_2D(PT,PP,KMASK,KL) RESULT(PQSAT) +! ###################################### +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! +!! es(T)= EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMW) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPW : Constant for saturation vapor pressure function +!! XBETAW : Constant for saturation vapor pressure function +!! XGAMW : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! +!! +!! AUTHOR +!! ------ +!! V. Masson * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 21/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_SNOW_PAR, ONLY : XUNDEF +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:,:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:,:), INTENT(IN) :: PP ! Pressure + ! (Pa) +! +INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK +! KMASK = Number of soil moisture layers (DIF option) +INTEGER, INTENT(IN), OPTIONAL :: KL +! KL = Max number of soil moisture layers (DIF option) +! +REAL, DIMENSION(SIZE(PT,1),SIZE(PT,2)) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT,1),SIZE(PT,2)) :: ZFOES +! +INTEGER, DIMENSION(SIZE(PT,1)) :: IMASK +! +INTEGER :: INL +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATW_2D',0,ZHOOK_HANDLE) +! +IF(PRESENT(KMASK).AND.PRESENT(KL))THEN + IMASK(:)=KMASK(:) + INL=KL +ELSE + IMASK(:)=SIZE(PT,2) + INL=SIZE(PT,2) +ENDIF +! + +PQSAT(:,:)=XUNDEF +ZFOES(:,:)=0.0 +! +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZFOES(:,1:INL) = PSAT(PT(:,1:INL),IMASK(:)) +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +PQSAT(:,:) = XRD/XRV*ZFOES(:,:)/PP(:,:) / (1.+(XRD/XRV-1.)*ZFOES(:,:)/PP(:,:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATW_2D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION QSATW_2D +! +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- +! +! ###################################### + FUNCTION QSATSEAW_1D(PT,PP) RESULT(PQSAT) +! ###################################### +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature over saline seawater +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! The reduction due to salinity is compute with the factor 0.98 (reduction of 2%) +!! +!! es(T)= 0.98*EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMW) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPW : Constant for saturation vapor pressure function +!! XBETAW : Constant for saturation vapor pressure function +!! XGAMW : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! Zeng, X., Zhao, M., and Dickinson, R. E., 1998 : Intercomparaison of bulk +!! aerodynamic algorithm for the computation of sea surface fluxes using +!! TOGA COARE and TAO data. Journal of Climate, vol 11, n°10, pp 2628--2644 +!! +!! +!! AUTHOR +!! ------ +!! C. Lebeaupin * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 6/04/2005 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:), INTENT(IN) :: PP ! Pressure + ! (Pa) +REAL, DIMENSION(SIZE(PT)) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL, DIMENSION(SIZE(PT)) :: ZWORK1 +REAL :: ZWORK2 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',0,ZHOOK_HANDLE) +! +ZFOES (:) = PSAT(PT(:)) +ZFOES (:) = 0.98*ZFOES(:) +! vapor pressure reduction of 2% over saline seawater could have a significant +! impact on the computation of surface latent heat flux under strong wind +! conditions (Zeng et al, 1998). +! +ZWORK1(:) = ZFOES(:)/PP(:) +ZWORK2 = XRD/XRV +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +PQSAT(:) = ZWORK2*ZWORK1(:) / (1.+(ZWORK2-1.)*ZWORK1(:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION QSATSEAW_1D +! +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! +! ###################################### + FUNCTION QSATSEAW2_1D(PT,PP,PSSS) RESULT(PQSAT) +! ###################################### +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature over saline seawater +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT) and salinity S (PSSS), the saturation vapor +!! pressure es(T,S) (FOES(PT,PSSS)) is computed following Weiss and Price +!! (1980). +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : contains physical constants +!! +!! REFERENCE +!! --------- +!! Weiss, R.F., and Price, B.A., 1980 : Nitrous oxide solubility in water +!! and seawater. Marine Chemistry, n°8, pp 347-359. +!! +!! +!! AUTHOR +!! ------ +!! S. Belamari * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 19/03/2014 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS, ONLY : XRD, XRV +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:), INTENT(IN) :: PP ! Pressure + ! (Pascal) +REAL, DIMENSION(:), INTENT(IN) :: PSSS ! Salinity + ! (g/kg) +REAL, DIMENSION(SIZE(PT)) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL, DIMENSION(SIZE(PT)) :: ZWORK1 +REAL :: ZWORK2 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',0,ZHOOK_HANDLE) +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZFOES(:) = EXP( 24.4543 -67.4509*(100.0/PT(:)) -4.8489*LOG(PT(:)/100.0) & + -5.44E-04*(PSSS(:)/1.00472) ) !see Sharqawy et al (2010) Eq32 p368 +ZFOES(:) = ZFOES(:)*1013.25E+02 !convert from atm to Pa +! +ZWORK1(:) = ZFOES(:)/PP(:) +ZWORK2 = XRD/XRV +! +!* 2. COMPUTE SATURATION SPECIFIC HUMIDITY +! ------------------------------------ +! +PQSAT(:) = ZWORK2*ZWORK1(:) / (1.0+(ZWORK2-1.0)*ZWORK1(:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION QSATSEAW2_1D +! +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! ############################################################## + FUNCTION DQSATW_O_DT_1D(PT,PP,PQSAT) RESULT(PDQSAT) +! ############################################################## +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! +!! es(T)= EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMW) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! Finally, dqsat / dT (T) is computed. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPW : Constant for saturation vapor pressure function +!! XBETAW : Constant for saturation vapor pressure function +!! XGAMW : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! +!! +!! AUTHOR +!! ------ +!! V. Masson * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 21/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:), INTENT(IN) :: PP ! Pressure + ! (Pa) +REAL, DIMENSION(:), INTENT(IN) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg)) +REAL, DIMENSION(SIZE(PT)) :: PDQSAT ! derivative according + ! to temperature of + ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg)) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL :: ZWORK1 +REAL, DIMENSION(SIZE(PT)) :: ZWORK2 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:DQSATW_O_DT_1D',0,ZHOOK_HANDLE) +! +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZWORK1 = XRD/XRV +ZFOES (:) = PP(:) / (1.+ZWORK1*(1./PQSAT(:)-1.)) +ZWORK2(:) = DPSAT(PT(:)) +! +!* 2. DERIVATION ACCORDING TO TEMPERATURE +! ----------------------------------- +! +PDQSAT(:) = ZWORK2(:) * PQSAT(:) / (1.+(ZWORK1-1.)*ZFOES(:)/PP(:) ) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:DQSATW_O_DT_1D',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END FUNCTION DQSATW_O_DT_1D +! +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! ############################################################## + FUNCTION DQSATI_O_DT_1D(PT,PP,PQSAT) RESULT(PDQSAT) +! ############################################################## +! +!!**** *QSATW * - function to compute saturation vapor humidity from +!! temperature (with respect to ice) +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! +!! es(T)= EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMW) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! Finally, dqsat / dT (T) is computed. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPW : Constant for saturation vapor pressure function +!! XBETAW : Constant for saturation vapor pressure function +!! XGAMW : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! +!! +!! AUTHOR +!! ------ +!! V. Masson * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 21/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:), INTENT(IN) :: PP ! Pressure + ! (Pa) +REAL, DIMENSION(:), INTENT(IN) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg)) +REAL, DIMENSION(SIZE(PT)) :: PDQSAT ! derivative according + ! to temperature of + ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg)) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL :: ZWORK1 +REAL, DIMENSION(SIZE(PT)) :: ZWORK2 +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:DQSATI_O_DT_1D',0,ZHOOK_HANDLE) +! +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZWORK1 = XRD/XRV +ZFOES (:) = PP(:) / (1.+ZWORK1*(1./PQSAT(:)-1.)) +ZWORK2(:) = DPSAT(PT(:)) +! +!* 2. DERIVATION ACCORDING TO TEMPERATURE +! ----------------------------------- +! +PDQSAT(:) = ZWORK2(:) * PQSAT(:) / (1.+(ZWORK1-1.)*ZFOES(:)/PP(:) ) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:DQSATI_O_DT_1D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION DQSATI_O_DT_1D +! +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! +! ###################################### + FUNCTION QSATI_1D(PT,PP) RESULT(PQSAT) +! ###################################### +! +!!**** *QSATI * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! +!! es(T)= EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPI) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAI) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMI) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPI : Constant for saturation vapor pressure function +!! XBETAI : Constant for saturation vapor pressure function +!! XGAMI : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! +!! +!! AUTHOR +!! ------ +!! V. Masson * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 21/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:), INTENT(IN) :: PP ! Pressure + ! (Pa) +REAL, DIMENSION(SIZE(PT)) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT)) :: ZFOES ! saturation vapor + ! pressure + ! (Pascal) +! +REAL, DIMENSION(SIZE(PT)) :: ZWORK1 +REAL :: ZWORK2 +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATI_1D',0,ZHOOK_HANDLE) +! +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZFOES (:) = PSAT(PT(:)) +ZWORK1(:) = ZFOES(:)/PP(:) +ZWORK2 = XRD/XRV +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +PQSAT(:) = ZWORK2*ZWORK1(:) / (1.+(ZWORK2-1.)*ZWORK1(:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATI_1D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION QSATI_1D +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! +! ###################################### + FUNCTION QSATI_2D(PT,PP,KMASK,KL) RESULT(PQSAT) +! ###################################### +! +!!**** *QSATI * - function to compute saturation vapor humidity from +!! temperature +!! +!! PURPOSE +!! ------- +! The purpose of this function is to compute the saturation vapor +! pressure from temperature +! +! +!!** METHOD +!! ------ +!! Given temperature T (PT), the saturation vapor pressure es(T) +!! (FOES(PT)) is computed by integration of the Clapeyron equation +!! from the triple point temperature Tt (XTT) and the saturation vapor +!! pressure of the triple point es(Tt) (XESTT), i.e +!! +!! es(T)= EXP( alphaw - betaw /T - gammaw Log(T) ) +!! +!! with : +!! alphaw (XALPI) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) +!! betaw (XBETAI) = Lv(Tt)/Rv + gammaw Tt +!! gammaw (XGAMI) = (Cl -Cpv) /Rv +!! +!! Then, the specific humidity at saturation is deduced. +!! +!! +!! EXTERNAL +!! -------- +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! Module MODD_CST : comtains physical constants +!! XALPI : Constant for saturation vapor pressure function +!! XBETAI : Constant for saturation vapor pressure function +!! XGAMI : Constant for saturation vapor pressure function +!! +!! REFERENCE +!! --------- +!! Book2 of documentation of Meso-NH +!! +!! +!! AUTHOR +!! ------ +!! V. Masson * Meteo France * +!! +!! MODIFICATIONS +!! ------------- +!! Original 21/09/98 +!------------------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! ------------ +! +USE MODD_SNOW_PAR, ONLY : XUNDEF +USE MODD_CSTS +! +IMPLICIT NONE +! +!* 0.1 Declarations of arguments and results +! +! +REAL, DIMENSION(:,:), INTENT(IN) :: PT ! Temperature + ! (Kelvin) +REAL, DIMENSION(:,:), INTENT(IN) :: PP ! Pressure + ! (Pa) +! +INTEGER, DIMENSION(:), INTENT(IN), OPTIONAL :: KMASK +! KMASK = Number of soil moisture layers (DIF option) +INTEGER, INTENT(IN), OPTIONAL :: KL +! KL = Max number of soil moisture layers (DIF option) +! +REAL, DIMENSION(SIZE(PT,1),SIZE(PT,2)) :: PQSAT ! saturation vapor + ! specific humidity + ! with respect to + ! water (kg/kg) +! +!* 0.2 Declarations of local variables +! +REAL, DIMENSION(SIZE(PT,1),SIZE(PT,2)) :: ZFOES ! saturation vapor pressure (Pascal) +! +INTEGER, DIMENSION(SIZE(PT,1)) :: IMASK +! +INTEGER :: INL +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +!------------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATI_2D',0,ZHOOK_HANDLE) +! +IF(PRESENT(KMASK))THEN + IMASK(:)=KMASK(:) + INL=KL +ELSE + IMASK(:)=SIZE(PT,2) + INL=SIZE(PT,2) +ENDIF +! +PQSAT(:,:)=XUNDEF +ZFOES(:,:)=0.0 +! +! +!* 1. COMPUTE SATURATION VAPOR PRESSURE +! --------------------------------- +! +ZFOES(:,1:INL) = PSAT(PT(:,1:INL),IMASK(:)) +! +!* 2. COMPUTE SATURATION HUMIDITY +! --------------------------- +! +PQSAT(:,:) = XRD/XRV*ZFOES(:,:)/PP(:,:) / (1.+(XRD/XRV-1.)*ZFOES(:,:)/PP(:,:)) +! +!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATI_2D',1,ZHOOK_HANDLE) +!------------------------------------------------------------------------------- +! +END FUNCTION QSATI_2D +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- +END MODULE MODE_THERMOS diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/tridiag_ground_snowcro.F b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/tridiag_ground_snowcro.F new file mode 100644 index 000000000..f74cf28cd --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/tridiag_ground_snowcro.F @@ -0,0 +1,344 @@ +!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier +!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence +!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt +!SFX_LIC for details. version 1. +MODULE MODI_TRIDIAG_GROUND_SNOWCRO +! +INTERFACE TRIDIAG_GROUND_SNOWCRO +! +SUBROUTINE TRIDIAG_GROUND_SNOWCRO_1D(PA,PB,PC,PY,PX,KNLVLS_USE,KDIFLOOP) +REAL, DIMENSION(:,:), INTENT(IN) :: PA ! lower diag. elements of A matrix +REAL, DIMENSION(:,:), INTENT(IN) :: PB ! main diag. elements of A matrix +REAL, DIMENSION(:,:), INTENT(IN) :: PC ! upper diag. elements of A matrix +REAL, DIMENSION(:,:), INTENT(IN) :: PY ! r.h.s. term +! +REAL, DIMENSION(:,:), INTENT(OUT) :: PX ! solution of A.X = Y +! +INTEGER, DIMENSION(:), INTENT(IN) :: KNLVLS_USE ! number of effective layers +! +INTEGER, INTENT(IN) :: KDIFLOOP ! shift in control loops: 0 or 1 +END SUBROUTINE TRIDIAG_GROUND_SNOWCRO_1D +! +SUBROUTINE TRIDIAG_GROUND_SNOWCRO_2D(PA,PB,PC,PY,PX,KNLVLS_USE,KDIFLOOP) +REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! lower diag. elements of A matrix +REAL, DIMENSION(:,:,:), INTENT(IN) :: PB ! main diag. elements of A matrix +REAL, DIMENSION(:,:,:), INTENT(IN) :: PC ! upper diag. elements of A matrix +REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! r.h.s. term +! +REAL, DIMENSION(:,:,:), INTENT(OUT) :: PX ! solution of A.X = Y +! +INTEGER, DIMENSION(:,:), INTENT(IN) :: KNLVLS_USE ! number of effective layers +! +INTEGER, INTENT(IN) :: KDIFLOOP ! shift in control loops: 0 or 1 +END SUBROUTINE TRIDIAG_GROUND_SNOWCRO_2D +! +END INTERFACE TRIDIAG_GROUND_SNOWCRO +! +END MODULE MODI_TRIDIAG_GROUND_SNOWCRO +! +!################################################################### + SUBROUTINE TRIDIAG_GROUND_SNOWCRO_1D(PA,PB,PC,PY,PX,KNLVLS_USE,KDIFLOOP) +! ######################################### +! +! +!!**** *TRIDIAG_GROUND* - routine to solve a time implicit scheme +!! +!! +!! PURPOSE +!! ------- +! The purpose of this routine is to resolve the linear system: +! +! A.X = Y +! +! where A is a tridiagonal matrix, and X and Y two vertical vectors. +! However, the computations are performed at the same time for all +! the verticals where an inversion of the system is necessary. +! This explain the dimansion of the input variables. +! +!!** METHOD +!! ------ +!! +!! Then, the classical tridiagonal algorithm is used to invert the +!! implicit operator. Its matrix is given by: +!! +!! ( b(1) c(1) 0 0 0 0 0 0 ) +!! ( a(2) b(2) c(2) 0 ... 0 0 0 0 ) +!! ( 0 a(3) b(3) c(3) 0 0 0 0 ) +!! ....................................................................... +!! ( 0 ... 0 a(k) b(k) c(k) 0 ... 0 0 ) +!! ....................................................................... +!! ( 0 0 0 0 0 ... a(n-1) b(n-1) c(n-1)) +!! ( 0 0 0 0 0 ... 0 a(n) b(n) ) +!! +!! +!! All these computations are purely vertical and vectorizations are +!! easely achieved by processing all the verticals in parallel. +!! +!! EXTERNAL +!! -------- +!! +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! REFERENCE +!! --------- +!! +!! AUTHOR +!! ------ +!! V. Masson +!! +!! MODIFICATIONS +!! ------------- +!! Original May 13, 1998 +!! 05/2011: Brun Special treatment to tackle the variable number +!! of snow layers +!! In case of second call, a shift of 1 snow layer +!! is applied in the control loops. +!! --------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! +!USE YOMHOOK , ONLY : LHOOK, DR_HOOK +!USE PARKIND1, ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:), INTENT(IN) :: PA ! lower diag. elements of A matrix +REAL, DIMENSION(:,:), INTENT(IN) :: PB ! main diag. elements of A matrix +REAL, DIMENSION(:,:), INTENT(IN) :: PC ! upper diag. elements of A matrix +REAL, DIMENSION(:,:), INTENT(IN) :: PY ! r.h.s. term +! +REAL, DIMENSION(:,:), INTENT(OUT) :: PX ! solution of A.X = Y +! +INTEGER, DIMENSION(:), INTENT(IN) :: KNLVLS_USE ! number of effective layers +! +INTEGER, INTENT(IN) :: KDIFLOOP ! shift in control loops: 0 or 1 +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2)) :: ZW ! work array +REAL, DIMENSION(SIZE(PA,1) ) :: ZDET ! work array +! +! +INTEGER :: JL, JJ ! vertical loop control +INTEGER :: INL ! number of vertical levels +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! --------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('TRIDIAG_GROUND_SNOWCRO_1D',0,ZHOOK_HANDLE) +! +INL = SIZE(PX,2) +! +!* 1. levels going up +! --------------- +! +!* 1.1 first level +! ----------- +! +ZDET(:) = PB(:,1) +! +PX(:,1) = PY(:,1) / ZDET(:) +! +!* 1.2 other levels +! ------------ +! +DO JL = 2,INL + ! + DO JJ = 1,SIZE(PX,1) + ! + IF ( JL<=KNLVLS_USE(JJ)-KDIFLOOP ) THEN + ! + ZW(JJ,JL) = PC(JJ,JL-1)/ZDET(JJ) + ZDET(JJ) = PB(JJ,JL ) - PA(JJ,JL)*ZW(JJ,JL) + ! + PX(JJ,JL) = ( PY(JJ,JL) - PA(JJ,JL)*PX(JJ,JL-1) ) / ZDET(JJ) + ! + ENDIF + ! + ENDDO + ! +END DO +! +!------------------------------------------------------------------------------- +! +!* 2. levels going down +! ----------------- +! +DO JL = INL-1,1,-1 + ! + DO JJ = 1,SIZE(PX,1) + ! + IF ( JL<=KNLVLS_USE(JJ)-1-KDIFLOOP ) THEN + ! + PX(JJ,JL) = PX(JJ,JL) - ZW(JJ,JL+1)*PX(JJ,JL+1) + ! + ENDIF + ! + ENDDO + ! +END DO +! +!IF (LHOOK) CALL DR_HOOK('TRIDIAG_GROUND_SNOWCRO_1D',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE TRIDIAG_GROUND_SNOWCRO_1D +! +!################################################################### + SUBROUTINE TRIDIAG_GROUND_SNOWCRO_2D(PA,PB,PC,PY,PX,KNLVLS_USE,KDIFLOOP) +! ######################################### +! +! +!!**** *TRIDIAG_GROUND* - routine to solve a time implicit scheme +!! +!! +!! PURPOSE +!! ------- +! The purpose of this routine is to resolve the linear system: +! +! A.X = Y +! +! where A is a tridiagonal matrix, and X and Y two vertical vectors. +! However, the computations are performed at the same time for all +! the verticals where an inversion of the system is necessary. +! This explain the dimansion of the input variables. +! +!!** METHOD +!! ------ +!! +!! Then, the classical tridiagonal algorithm is used to invert the +!! implicit operator. Its matrix is given by: +!! +!! ( b(1) c(1) 0 0 0 0 0 0 ) +!! ( a(2) b(2) c(2) 0 ... 0 0 0 0 ) +!! ( 0 a(3) b(3) c(3) 0 0 0 0 ) +!! ....................................................................... +!! ( 0 ... 0 a(k) b(k) c(k) 0 ... 0 0 ) +!! ....................................................................... +!! ( 0 0 0 0 0 ... a(n-1) b(n-1) c(n-1)) +!! ( 0 0 0 0 0 ... 0 a(n) b(n) ) +!! +!! +!! All these computations are purely vertical and vectorizations are +!! easely achieved by processing all the verticals in parallel. +!! +!! EXTERNAL +!! -------- +!! +!! NONE +!! +!! IMPLICIT ARGUMENTS +!! ------------------ +!! +!! REFERENCE +!! --------- +!! +!! AUTHOR +!! ------ +!! V. Masson +!! +!! MODIFICATIONS +!! ------------- +!! Original May 13, 1998 +!! 05/2011: Brun Special treatment to tackle the variable number +!! of snow layers +!! In case of second call, a shift of 1 snow layer +!! is applied in the control loops. +!! --------------------------------------------------------------------- +! +!* 0. DECLARATIONS +! +!USE YOMHOOK , ONLY : LHOOK, DR_HOOK +!USE PARKIND1, ONLY : JPRB +! +IMPLICIT NONE +! +!* 0.1 declarations of arguments +! +REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! lower diag. elements of A matrix +REAL, DIMENSION(:,:,:), INTENT(IN) :: PB ! main diag. elements of A matrix +REAL, DIMENSION(:,:,:), INTENT(IN) :: PC ! upper diag. elements of A matrix +REAL, DIMENSION(:,:,:), INTENT(IN) :: PY ! r.h.s. term +! +REAL, DIMENSION(:,:,:), INTENT(OUT) :: PX ! solution of A.X = Y +! +INTEGER, DIMENSION(:,:), INTENT(IN) :: KNLVLS_USE ! number of effective layers +! +INTEGER, INTENT(IN) :: KDIFLOOP ! shift in control loops: 0 or 1 +! +!* 0.2 declarations of local variables +! +REAL, DIMENSION(SIZE(PA,2)) :: ZW ! work array +REAL :: ZDET ! work array +! +! +INTEGER :: JL, JJ, JB ! vertical loop control +INTEGER :: INL, INB ! number of vertical levels +! +!REAL(KIND=JPRB) :: ZHOOK_HANDLE +! --------------------------------------------------------------------------- +! +!IF (LHOOK) CALL DR_HOOK('TRIDIAG_GROUND_SNOWCRO_2D',0,ZHOOK_HANDLE) +! +INL = SIZE(PX,2) +INB = SIZE(PX,3) +! +!* 1. levels going up +! --------------- +! +!* 1.1 first level +! ----------- +! +DO JB = 1,INB + ! + DO JJ = 1,SIZE(PX,1) + ! + ZDET = PB(JJ,1,JB) + ! + PX(JJ,1,JB) = PY(JJ,1,JB) / ZDET + ! + !* 1.2 other levels + ! ------------ + ! + DO JL = 2,INL + ! + IF ( JL<=KNLVLS_USE(JJ,JB)-KDIFLOOP ) THEN + ! + ZW(JL) = PC(JJ,JL-1,JB) /ZDET + ZDET = PB(JJ,JL ,JB) - PA(JJ,JL,JB) * ZW(JL) + ! + PX(JJ,JL,JB) = ( PY(JJ,JL,JB) - PA(JJ,JL,JB) * PX(JJ,JL-1,JB) ) / ZDET + ! + ENDIF + ! + ENDDO + ! + !------------------------------------------------------------------------------- + ! + !* 2. levels going down + ! ----------------- + ! + DO JL = INL-1,1,-1 + ! + IF ( JL<=KNLVLS_USE(JJ,JB)-1-KDIFLOOP ) THEN + ! + PX(JJ,JL,JB) = PX(JJ,JL,JB) - ZW(JL+1) * PX(JJ,JL+1,JB) + ! + ENDIF + ! + ENDDO + ! + END DO + ! +ENDDO +! +!IF (LHOOK) CALL DR_HOOK('TRIDIAG_GROUND_SNOWCRO_2D',1,ZHOOK_HANDLE) +! +!------------------------------------------------------------------------------- +! +END SUBROUTINE TRIDIAG_GROUND_SNOWCRO_2D diff --git a/trunk/NDHMS/Land_models/NoahMP/run/Makefile b/trunk/NDHMS/Land_models/NoahMP/run/Makefile index 2cfe87e28..39838e403 100644 --- a/trunk/NDHMS/Land_models/NoahMP/run/Makefile +++ b/trunk/NDHMS/Land_models/NoahMP/run/Makefile @@ -10,14 +10,14 @@ include ../user_build_options ifeq ($(WRF_HYDRO_RAPID),1) PHDF5_INC=-I ${TACC_HDF5_INC} RAPID_MACRO = ${TAO_FORTRAN_LIB} ${TAO_LIB} ${PETSC_LIB} ${PHDF5_INC} \ - -Wl,-rpath,${TACC_HDF5_LIB} -L${TACC_HDF5_LIB} -lhdf5 -lz + -Wl,-rpath,${TACC_HDF5_LIB} -L${TACC_HDF5_LIB} -lhdf5 -lz RAPID_LIB = -lrapid else -RAPID_MACRO = -RAPID_LIB = +RAPID_MACRO = +RAPID_LIB = endif -OBJS_NoahMP = ../IO_code/module_NoahMP_hrldas_driver.o +OBJS_NoahMP = ../IO_code/module_NoahMP_hrldas_driver.o OBJS = \ ../IO_code/main_hrldas_driver.o \ @@ -29,7 +29,17 @@ OBJS = \ ../Utility_routines/module_wrf_utilities.o \ ../Utility_routines/module_model_constants.o \ ../Utility_routines/module_date_utilities.o \ - ../Utility_routines/kwm_string_utilities.o + ../Utility_routines/kwm_string_utilities.o\ + ../phys/surfex/modd_csts.o\ + ../phys/surfex/tridiag_ground_snowcro.o\ + ../phys/surfex/mode_surf_coefs.o\ + ../phys/surfex/mode_snow3l.o\ + ../phys/surfex/modd_snow_par.o\ + ../phys/surfex/ini_csts.o\ + ../phys/module_snowcro.o\ + ../phys/surfex/mode_thermos.o\ + ../phys/surfex/modd_surf_atm.o\ + ../phys/surfex/modd_snow_metamo.o CMD = hrldas.exe all: $(CMD) @@ -38,7 +48,7 @@ all: $(CMD) hrldas.exe: $(OBJS) @echo "" echo "${TAO_FORTRAN_LIB} ${TAO_LIB} ${PETSC_LIB} ${PHDF5_INC} -Wl,-rpath,${TACC_HDF5_LIB} -L${TACC_HDF5_LIB} -lhdf5 -lz" -# We have to include the modules built in ../IO_code +# We have to include the modules built in ../IO_code $(COMPILERF90) -o $(@) -I../IO_code -I../phys $(OBJS) $(OBJS_NoahMP) $(HYDRO_LIB) $(RAPID_LIB) $(NETCDFLIB) $(RAPID_MACRO) $(LDFLAGS) $(LIBS) @echo "" @@ -52,4 +62,3 @@ NoahMP: $(OBJS) # This command cleans up clean: $(RM) *~ $(CMD) - diff --git a/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F b/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F index 4a66d7218..1a79e6577 100644 --- a/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F +++ b/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F @@ -122,7 +122,6 @@ subroutine gw_write_io_real(numbasns,inV,ind,outV) tag2 = 63 call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, sizeInd(i+1) outV(ibuff(k)) = vbuff(k) end do @@ -181,7 +180,6 @@ subroutine gw_write_io_int(numbasns,inV,ind,outV) tag2 = 63 call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr) - do k = 1, sizeInd(i+1) outV(ibuff(k)) = vbuff(k) end do diff --git a/trunk/NDHMS/OrchestratorLayer/config.f90 b/trunk/NDHMS/OrchestratorLayer/config.f90 index 25727f05c..01ea26083 100644 --- a/trunk/NDHMS/OrchestratorLayer/config.f90 +++ b/trunk/NDHMS/OrchestratorLayer/config.f90 @@ -11,6 +11,8 @@ module config_base type NOAHLSM_OFFLINE_ character(len=256) :: indir integer :: nsoil ! number of soil layers + integer :: crocus_opt = 0 + integer :: act_lev = 0 integer :: forcing_timestep integer :: noah_timestep integer :: start_year @@ -42,7 +44,7 @@ module config_base integer :: crop_option = 0 integer :: imperv_option = 9 - integer :: split_output_count = 1 + integer :: split_output_count = 1 integer :: khour integer :: kday = -999 real :: zlvl @@ -69,19 +71,20 @@ module config_base TYPE namelist_rt_ integer :: nsoil, SOLVEG_INITSWC + integer :: act_lev = 0 real,allocatable,dimension(:) :: ZSOIL8 - real*8 :: out_dt, rst_dt - real :: dt !! dt is NOAH_TIMESTEP + real*8 :: out_dt, rst_dt + real :: dt !! dt is NOAH_TIMESTEP integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN character(len=256) :: restart_file = "" - integer :: split_output_count + integer :: split_output_count integer :: igrid integer :: rst_bi_in ! used for parallel io with large restart file. integer :: rst_bi_out ! used for parallel io with large restart file. ! each process will output the restart tile. character(len=256) :: geo_static_flnm = "" character(len=1024) :: land_spatial_meta_flnm = "" - integer :: DEEPGWSPIN + integer :: DEEPGWSPIN integer :: order_to_write, rst_typ character(len=256) :: upmap_file = "" ! user defined mapping file for NHDPLUS character(len=256) :: hydrotbl_f = "" ! hydrotbl file @@ -174,6 +177,11 @@ module config_base procedure, nopass :: init_nlst => init_namelist_rt_field end type Configuration_ + type crocus_options + integer :: crocus_opt = 0 + integer :: act_lev = 0 + end type crocus_options + integer, parameter :: max_domain = 5 type(NOAHLSM_OFFLINE_), protected, save :: noah_lsm @@ -308,6 +316,10 @@ subroutine rt_nlst_check(self) endif end do + if(self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then + call hydro_stop('hydro.namelist ERROR: Invalid NSOIL specified.') + endif + if(self%dxrt0 .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid DXRT specified.') endif @@ -520,6 +532,7 @@ subroutine init_namelist_rt_field(did) !!! add the following two dummy variables integer :: NSOIL real :: ZSOIL8(8) + type(crocus_options) :: crocus_opts logical :: dir_e character(len=1024) :: reservoir_obs_dir @@ -633,6 +646,7 @@ subroutine init_namelist_rt_field(did) #endif close(12) + call read_crocus_namelist(crocus_opts) ! #ifdef MPP_LAND ! endif ! #endif @@ -744,6 +758,7 @@ subroutine init_namelist_rt_field(did) call hydro_stop("module_namelist: DT not a multiple of DTRT_CH") endif + nlst(did)%act_lev = crocus_opts%act_lev nlst(did)%SUBRTSWCRT = SUBRTSWCRT nlst(did)%OVRTSWCRT = OVRTSWCRT nlst(did)%dxrt0 = dxrt @@ -862,6 +877,7 @@ subroutine init_noah_lsm_and_wrf_hydro() implicit none character(len=256) :: indir integer :: nsoil ! number of soil layers + type(crocus_options) :: crocus_opts integer :: forcing_timestep integer :: noah_timestep integer :: start_year @@ -922,7 +938,7 @@ subroutine init_noah_lsm_and_wrf_hydro() frozen_soil_option, radiative_transfer_option, snow_albedo_option, & pcp_partition_option, tbot_option, temp_time_scheme_option, & glacier_option, surface_resistance_option, & - + soil_data_option, pedotransfer_option, crop_option, & imperv_option, & @@ -983,6 +999,12 @@ subroutine init_noah_lsm_and_wrf_hydro() call hydro_stop (" FATAL ERROR: Problem reading namelist WRF_HYDRO_OFFLINE") endif +#ifndef NCEP_WCOSS + call read_crocus_namelist(crocus_opts, 30) +#else + call read_crocus_namelist(crocus_opts, 11) +#endif + #ifndef NCEP_WCOSS close(30) #else @@ -996,6 +1018,8 @@ subroutine init_noah_lsm_and_wrf_hydro() noah_lsm%indir = indir noah_lsm%nsoil = nsoil ! number of soil layers + noah_lsm%crocus_opt = crocus_opts%crocus_opt + noah_lsm%act_lev = crocus_opts%act_lev noah_lsm%forcing_timestep = forcing_timestep noah_lsm%noah_timestep = noah_timestep noah_lsm%start_year = start_year @@ -1057,4 +1081,42 @@ subroutine init_noah_lsm_and_wrf_hydro() end subroutine init_noah_lsm_and_wrf_hydro + subroutine read_crocus_namelist(opt, f_in) + type(crocus_options), intent(OUT) :: opt + integer, intent(IN), optional :: f_in + character(len=15) :: filename = "namelist.hrldas" + logical :: f_exists, f_opened + integer :: crocus_opt, act_lev + integer :: ierr, f_local + namelist /CROCUS_nlist/ & + crocus_opt, act_lev + + ! check if file is opened + if (present(f_in)) then + rewind(30) + read(f_in, NML=CROCUS_nlist, iostat=ierr) + else + ! check that file exists + inquire(file=filename, exist=f_exists) + if (f_exists .eqv. .false.) & + call hydro_stop (" FATAL ERROR: namelist.hrldas does not exist") + open(f_local, file=filename, form="FORMATTED", iostat=ierr) + read(f_local, NML=CROCUS_nlist, iostat=ierr) + close(f_local) + end if + + if ((ierr .ne. 0) .or. (crocus_opt .eq. 0)) & + return + if ((act_lev .gt. 50) .or. (act_lev .lt. 0)) then + call hydro_stop (" FATAL ERROR: Crocus act_lev out of range of 0-50 ") + end if + + opt%crocus_opt = crocus_opt + if (crocus_opt == 0) then + opt%act_lev = 0 + else + opt%act_lev = act_lev + end if + end subroutine read_crocus_namelist + end module config_base diff --git a/trunk/NDHMS/Routing/module_NWM_io.F b/trunk/NDHMS/Routing/module_NWM_io.F index 67eaba620..ffce2e60c 100644 --- a/trunk/NDHMS/Routing/module_NWM_io.F +++ b/trunk/NDHMS/Routing/module_NWM_io.F @@ -960,7 +960,6 @@ subroutine output_chrt_NWM(domainId) ! Get NetCDF variable id. iret = nf90_inq_varid(ftn,trim(fileMeta%varNames(iTmp)),varId) call nwmCheck(diagFlag,iret,'ERROR: Unable to find variable ID for var: '//trim(fileMeta%varNames(iTmp))) - ! Put data into NetCDF file if((nlst(1)%io_form_outputs .eq. 1) .or. (nlst(1)%io_form_outputs .eq. 2)) then iret = nf90_put_var(ftn,varId,varOutInt) @@ -1089,7 +1088,7 @@ end subroutine output_chrt_NWM subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,ixPar,jxPar,zNum,varReal,vegTyp,varInd) use module_rt_data, only: rt_domain - use config_base, only: nlst + use config_base, only: nlst, noah_lsm use Module_Date_utilities_rt, only: geth_newdate, geth_idts use module_NWM_io_dict use netcdf @@ -1126,7 +1125,7 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i character(len=1024) :: output_flnm ! Output file name integer :: iret ! NetCDF return status integer :: ftn ! NetCDF file handle - integer :: dimId(7) ! NetCDF dimension ID values + integer :: dimId(8) ! NetCDF dimension ID values integer :: varId ! NetCDF variable ID value integer :: timeId ! NetCDF time variable ID integer :: refTimeId ! NetCDF reference_time variable ID @@ -1249,8 +1248,15 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 1,1,1,1,1,1,1,1,1,1,& !61-70 1,1,1,1,1,1,1,1,1,1,& !71-80 1,1,1,1,1,1,1,1,1,1,& !81-90 - 1,1,1,1,1,1,1,1] !91-98 - else if(nlst(1)%io_config_outputs .eq. 1) then + 1,1,1,1,1,1,1,1,& !91-98 + 1,1,1,& !99-101 + 1,1,1,& !102-104 + 1,1,1,& !105-107 + 1,1,1,& !108-110 + 1,1,1,& !111-113 + 1,1,1] !114 + + else if(nlst(1)%io_config_outputs .eq. 1) then ! Analysis and Assimilation fileMeta%outFlag(:) = [0,0,0,0,0,0,0,0,0,0,& !1-10 0,0,0,0,0,0,1,0,0,0,& !11-20 @@ -1261,7 +1267,14 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 0,0,1,1,1,1,1,1,0,1,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 - 0,1,1,0,1,0,0,1] !91-98 + 0,1,1,0,1,0,0,1,& !91-98 + 0,0,0,& !99-101 + 0,0,0,& !102-104 + 0,0,0,& !105-107 + 0,0,0,& !108-110 + 0,0,0,& !111-113 + 0,0,0] !114 + else if(nlst(1)%io_config_outputs .eq. 2) then ! Short Range fileMeta%outFlag(:) = [0,0,0,0,0,0,0,0,0,0,& !1-10 @@ -1273,7 +1286,14 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 0,0,0,1,1,0,0,1,0,0,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 - 0,0,1,0,1,0,0,0] !91-98 + 0,0,1,0,1,0,0,0,& !91-98 + 0,0,0,& !99-101 + 0,0,0,& !102-104 + 0,0,0,& !105-107 + 0,0,0,& !108-110 + 0,0,0,& !111-113 + 0,0,0] !114 + else if(nlst(1)%io_config_outputs .eq. 3) then ! Medium Range fileMeta%outFlag(:) = [0,0,0,0,0,0,0,0,0,0,& !1-10 @@ -1285,7 +1305,14 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 0,0,1,1,1,0,1,1,0,1,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 - 1,1,1,0,1,0,0,0] !91-98 + 1,1,1,0,1,0,0,0,& !91-98 + 0,0,0,& !99-101 + 0,0,0,& !102-104 + 0,0,0,& !105-107 + 0,0,0,& !108-110 + 0,0,0,& !111-113 + 0,0,0] !114 + else if(nlst(1)%io_config_outputs .eq. 4) then ! Long Range fileMeta%outFlag(:) = [0,0,0,0,0,0,0,0,0,0,& !1-10 @@ -1297,7 +1324,14 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 0,0,0,0,1,0,0,0,0,1,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 - 1,0,1,1,0,0,0,0] !91-98 + 1,0,1,1,0,0,0,0,& !91-98 + 0,0,0,& !99-101 + 0,0,0,& !102-104 + 0,0,0,& !105-107 + 0,0,0,& !108-110 + 0,0,0,& !111-113 + 0,0,0] !114 + else if(nlst(1)%io_config_outputs .eq. 5) then ! Retrospective fileMeta%outFlag(:) = [0,0,0,0,0,0,1,0,0,0,& !1-10 @@ -1309,7 +1343,14 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 1,0,1,1,1,1,0,1,0,1,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 - 0,0,0,0,0,1,1,1] !91-98 + 0,0,0,0,0,1,1,1,& !91-98 + 0,0,0,& !99-101 + 0,0,0,& !102-104 + 0,0,0,& !105-107 + 1,1,0,& !108-110 + 1,0,0,& !111-113 + 1,1,1] !114 + else if(nlst(1)%io_config_outputs .eq. 6) then ! Diagnostics fileMeta%outFlag(:) = [0,0,0,0,0,0,0,0,0,0,& !1-10 @@ -1321,11 +1362,32 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i 1,0,1,1,1,1,1,1,0,1,& !61-70 0,0,0,0,0,0,0,0,0,0,& !71-80 0,0,0,0,0,0,0,0,0,1,& !81-90 - 1,1,1,1,1,0,0,1] !91-98 + 1,1,1,1,1,0,0,1,& !91-98 + 0,0,0,& !99-101 + 0,0,0,& !102-104 + 0,0,0,& !105-107 + 0,0,0,& !108-110 + 0,0,0,& !111-113 + 0,0,0] !114 else call nwmCheck(diagFlag,1,'ERROR: Invalid IOC flag provided by namelist file.') endif + ! ! If crocus is off, these should not be outputted + if (noah_lsm%crocus_opt == 0) then + fileMeta%outFlag(101) = 0 + fileMeta%outFlag(102) = 0 + fileMeta%outFlag(103) = 0 + fileMeta%outFlag(104) = 0 + fileMeta%outFlag(108) = 0 + fileMeta%outFlag(109) = 0 + fileMeta%outFlag(111) = 0 + fileMeta%outFlag(114) = 0 + fileMeta%outFlag(115) = 0 + fileMeta%outFlag(116) = 0 + fileMeta%numVars = numLdasVars_crocus_off ! 98 + end if + ! call the GetModelConfigType function modelConfigType = GetModelConfigType(nlst(1)%io_config_outputs) @@ -1395,6 +1457,9 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i call nwmCheck(diagFlag,iret,'ERROR: Unable to define snow_layers dimension') iret = nf90_def_dim(ftnNoahMP,'reference_time',1,dimId(6)) call nwmCheck(diagFlag,iret,'ERROR: Unable to define reference_time dimension') + if (noah_lsm%crocus_opt == 1) & + iret = nf90_def_dim(ftnNoahMP,'glacier_levels',fileMeta%act_lev,dimId(8)) + call nwmCheck(diagFlag,iret,'ERROR: Unable to define act_layers dimension') ! Only create vis_nir if we are outputting the two snow albedo variables. ! Otherwise these are unecessary dimensions. if ((fileMeta%outFlag(96) .eq. 1) .or. (fileMeta%outFlag(96) .eq. 1)) then @@ -1483,6 +1548,8 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_int,(/dimId(2),dimId(4),dimId(3),dimId(1)/),varId) else if(fileMeta%numLev(iTmp) .eq. fileMeta%numSnowLayers) then iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_int,(/dimId(2),dimId(5),dimId(3),dimId(1)/),varId) + else if(noah_lsm%crocus_opt == 1 .and. fileMeta%numLev(iTmp) .eq. fileMeta%act_lev) then + iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_int,(/dimId(2),dimId(8),dimId(3),dimId(1)/),varId) else if(fileMeta%numLev(iTmp) .eq. fileMeta%numSpectrumBands) then iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_int,(/dimId(2),dimId(7),dimId(3),dimId(1)/),varId) else if(fileMeta%numLev(iTmp) .eq. 1) then @@ -1493,6 +1560,8 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_float,(/dimId(2),dimId(4),dimId(3),dimId(1)/),varId) else if(fileMeta%numLev(iTmp) .eq. fileMeta%numSnowLayers) then iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_float,(/dimId(2),dimId(5),dimId(3),dimId(1)/),varId) + else if(noah_lsm%crocus_opt == 1 .and. fileMeta%numLev(iTmp) .eq. fileMeta%act_lev) then + iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_float,(/dimId(2),dimId(8),dimId(3),dimId(1)/),varId) else if(fileMeta%numLev(iTmp) .eq. fileMeta%numSpectrumBands) then iret = nf90_def_var(ftnNoahMP,trim(fileMeta%varNames(iTmp)),nf90_float,(/dimId(2),dimId(7),dimId(3),dimId(1)/),varId) else if(fileMeta%numLev(iTmp) .eq. 1) then @@ -1720,8 +1789,15 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i ! Write array out to NetCDF file. if(myId .eq. 0) then + ! write(*,*) 'trude foo1' + ! write(*,*) 'variable name : ', fileMeta%varNames(varInd) + ! write(*,*) 'varind :', varind + ! write(*,*) 'varid :', varid + ! write(*,*) 'ftnNoahMP :', ftnNoahMP + ! write(*,*) 'num lev :', fileMeta%numLev(varInd) iret = nf90_inq_varid(ftnNoahMP,trim(fileMeta%varNames(varInd)),varId) call nwmCheck(diagFlag,iret,'ERROR: Unable to find variable ID for var: '//trim(fileMeta%varNames(varInd))) +! write(*,*) 'trude foo2' if((nlst(1)%io_form_outputs .eq. 1) .or. (nlst(1)%io_form_outputs .eq. 2)) then if(fileMeta%numLev(varInd) .eq. 1) then iret = nf90_put_var(ftnNoahMP,varId,globalOutComp,(/1,1,1/),(/global_nx,global_ny,1/)) @@ -2958,7 +3034,6 @@ subroutine output_lakes_NWM(domainId,iGrid) ! Get NetCDF variable id. iret = nf90_inq_varid(ftn,trim(fileMeta%varNames(iTmp)),varId) call nwmCheck(diagFlag,iret,'ERROR: Unable to find variable ID for var: '//trim(fileMeta%varNames(iTmp))) - ! Put data into NetCDF file if((nlst(1)%io_form_outputs .eq. 1) .or. (nlst(1)%io_form_outputs .eq. 2)) then iret = nf90_put_var(ftn,varId,varOutInt) @@ -5022,7 +5097,6 @@ subroutine output_chanObs_NWM(domainId) ! Get NetCDF variable id. iret = nf90_inq_varid(ftn,trim(fileMeta%varNames(iTmp)),varId) call nwmCheck(diagFlag,iret,'ERROR: Unable to find variable ID for var: '//trim(fileMeta%varNames(iTmp))) - ! Put data into NetCDF file if((nlst(1)%io_form_outputs .eq. 1) .or. (nlst(1)%io_form_outputs .eq. 2)) then iret = nf90_put_var(ftn, varId, & @@ -5556,7 +5630,6 @@ subroutine output_gw_NWM(domainId,iGrid) ! Get NetCDF variable id. iret = nf90_inq_varid(ftn,trim(fileMeta%varNames(iTmp)),varId) call nwmCheck(diagFlag,iret,'ERROR: Unable to find variable ID for var: '//trim(fileMeta%varNames(iTmp))) - ! Put data into NetCDF file if((nlst(1)%io_form_outputs .eq. 1) .or. (nlst(1)%io_form_outputs .eq. 2)) then iret = nf90_put_var(ftn,varId,varOutInt) diff --git a/trunk/NDHMS/Routing/module_NWM_io_dict.F b/trunk/NDHMS/Routing/module_NWM_io_dict.F index d7c55279d..c3fcbf795 100644 --- a/trunk/NDHMS/Routing/module_NWM_io_dict.F +++ b/trunk/NDHMS/Routing/module_NWM_io_dict.F @@ -19,7 +19,11 @@ module module_NWM_io_dict ! Declare parameter values for module. integer, parameter :: numChVars = 11 -integer, parameter :: numLdasVars = 98 +integer, parameter :: numLdasVars = 116 +! Note: if more ldas variables are added the logic will need to be changed in +! module_NWM_io.F:output_NoahMP_NWM for when to close the restart file +integer, parameter :: numLdasVars_crocus_off = 98 + integer, parameter :: numRtDomainVars = 5 integer, parameter :: numLakeVars = 2 integer, parameter :: numChGrdVars = 1 @@ -122,6 +126,7 @@ module module_NWM_io_dict integer :: numVars = numLdasVars integer :: numSnowLayers = 3 integer :: numSoilLayers ! Fill from Namelist + integer :: act_lev integer :: numSpectrumBands = 2 character (len=512) :: modelOutputType = "land" character (len=64) :: modelConfigType @@ -423,6 +428,7 @@ module module_NWM_io_dict integer :: numVars = numLsmVars integer :: numSnowLayers = 3 integer :: numSoilLayers ! Fill from Namelist + integer :: act_lev character (len=512) :: modelOutputType = "land" character (len=64) :: modelConfigType @@ -763,7 +769,7 @@ subroutine initChrtDict(chrtOutDict,diagFlag,procId) chrtOutDict%addOffset(:) = [0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,& 0.0,0.0] ! Initialize all output flags to 0. Modify (if absolutely necessary) in the - ! output subroutine. + ! output subroutine. chrtOutDict%outFlag(:) = [0,0,0,0,0,0,0,0,0,0,0] chrtOutDict%timeZeroFlag(:) = [1,1,1,1,1,1,1,1,1,1,1] chrtOutDict%fillReal(:) = [-9999.0,-9999.0,-9999.0,-9999.0,-9999.0,-9999.0,& @@ -816,6 +822,8 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) ! LDASOUT FILES ldasOutDict%numSoilLayers = nlst(1)%nsoil + ldasOutDict%act_lev = nlst(1)%act_lev + ldasOutDict%modelNdv = 9.9692099683868690E36 ldasOutDict%modelNdv2 = -1.E33 @@ -1067,8 +1075,15 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) "STMASS","WOOD","STBLCP","FASTCP","NEE", & !81-85 "GPP","NPP","PSN","APAR","ACCET", & !86-90 "CANWAT","SOILICE","SOILSAT_TOP","SOILSAT","SNOWT_AVG", & !91-95 - "ALBSND","ALBSNI","QRAIN"] !96-98 - ldasOutDict%longName(:) = [character(len=128) :: & + "ALBSND","ALBSNI","QRAIN",& !96-98 + "glacier", "glacier_thickness" ,"PSNOWALB",& !99-101 + "PSNOWTHRUFAL" ,"PSNOWHEIGHT","PSNOWTOTSWE" ,& !102-104 + "PSNOWGRAN1","PSNOWGRAN2","PSNOWAGE",& !105-107 + "PSNOWTEMP","PSNOWDZ","PSNOWHIST",& !108-110 + "PSNOWLIQ","PSNOWHEAT","PSNOWRHO",& !111-113 + "PSNOWSWE", "FLOW_ICE", "FLOW_SNOW"] !114-116 + + ldasOutDict%longName(:) = [character(len=128) :: & "Dominant vegetation category",& !1 "Dominant soil category",& !2 "Green Vegetation Fraction",& !3 @@ -1166,7 +1181,26 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) "average snow temperature (by layer mass)",& !95 "snowpack albedo, direct",& !96 "snowpack albedo, diffuse",& !97 - "Rainfall rate on the ground"] !98 + "Rainfall rate on the ground",& !98 + "Glacier grid point",& !99 + "Glacier height",& !100 + "Snow albedo",& !101 + "Runoff from glacier",& !102 + "Total snow height",& !103 + "Total snow swe", & !104 + "Snow gran 1, optiacal diameter",& !105 + "Snow gran 2, sphericity",& !106 + "Snow age",& !107 + "Snow temperature",& !108 + "Snow thickness",& !109 + "Snow history",& !110 + "Liquid in snow",& !111 + "Snow heat",& !112 + "Snow density",& !113 + "Snow water equivalent", & !114 + "Accumulated glacier melt from ice", & !115 + "Accumulated glacier melt from snow"] !116 + ldasOutDict%units(:) = [character(len=64) :: & "category","category","-","-","-", & !1-5 "W m-2","-","W m-2","kg m-2 s-1","-", & !6-10 @@ -1187,7 +1221,14 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) "g m-2","g m-2","g m-2","g m-2","g m-2s-1 CO2", & !81-85 "g m-2s-1 C","g m-2s-1 C","umol CO2 m-2 s-1","W m-2","mm", & !86-90 "mm","1","1","1","K", & !91-95 - "-","-","mm s-1"] !96-98 + "-","-","mm s-1",& !96-98 + "-","m","-", & !99-101 + "kg/(m2 s)","m","kg m-2",& !102-104 + "m","-","days since snowfall",& !105-107 + "K","m","-",& !108-110 + "kg/m3","J/m2","m",& !111-113 + "kg m-2","kg/m2","kg/m2"] !114-116 + ldasOutDict%scaleFactor(:) = [1.0, 1.0, 0.01, 0.1, 0.1, & !1-5 0.1, 0.01, 0.1, 0.00001, 0.01, & !6-10 0.1, 0.1, 0.1, 0.1, 0.1, & !11-15 @@ -1207,7 +1248,14 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 0.01, 0.01, 0.01, 0.01, 0.01, & !81-85 0.01, 0.01, 0.01, 0.01, 0.01, & !86-90 0.01, 0.01, 0.001, 0.001, 0.1, & !91-95 - 0.01, 0.01, 0.00001] !96-98 + 0.01, 0.01, 0.00001, & !96-98 + 1.0, 1.0,1.0, & !99-101 + 1.0,1.0,0.01, & !102-104 + 0.01,0.01,0.0001, & !105-107 + 0.01,1.0,1.0, & !108-110 + 0.0001,0.000001,0.001, & !111-113 + 0.000001, 0.01, 0.01 ] !114-116 + ldasOutDict%addOffset(:) = [0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, & !1-10 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, & !11-20 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, & !21-30 @@ -1217,7 +1265,14 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, & !61-70 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, & !71-80 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, & !81-90 - 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0] !91-98 + 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, & !91-98 + 0.0,0.0,0.0, & !99-101 + 0.0,0.0,0.0, & !102-104 + 0.0,0.0,0.0, & !105-107 + 0.0,0.0,0.0, & !108-110 + 0.0,0.0,0.0, & !111-113 + 0.0,0.0,0.0] !114-116 + ! Note that output flags will be set in the the output routine, and will vary ! by the IOC flag specified in hydro.namelist. ldasOutDict%outFlag(:) = [0,0,0,0,0,0,0,0,0,0, & !1-10 @@ -1229,7 +1284,14 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 0,0,0,0,0,0,0,0,0,0, & !61-70 0,0,0,0,0,0,0,0,0,0, & !71-80 0,0,0,0,0,0,0,0,0,0, & !81-90 - 0,0,0,0,0,0,0,0] !91-98 + 0,0,0,0,0,0,0,0, & !91-98 + 0,0,0, & !99-101 + 0,0,0, & !102-104 + 0,0,0, & !105-107 + 0,0,0, & !108-110 + 0,0,0, & !111-103 + 0,0,0] !114-116 + ldasOutDict%timeZeroFlag(:) = [1,1,1,1,1,1,1,1,1,1, & !1-10 1,1,1,1,1,1,1,1,1,1, & !11-20 1,1,1,1,1,1,1,1,1,1, & !21-30 @@ -1239,7 +1301,14 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 1,1,1,1,1,1,1,1,1,1, & !61-70 1,1,1,1,1,1,1,1,1,1, & !71-80 1,1,1,1,1,1,1,1,1,1, & !81-90 - 1,1,1,1,1,1,1,1] !91-98 + 1,1,1,1,1,1,1,1, & !91-98 + 1,1,1, & !99-101 + 1,1,1, & !102-104 + 1,1,1, & !105-107 + 1,1,1, & !108-110 + 1,1,1, & !111-113 + 1,1,1] !114-116 + ldasOutDict%numLev(:) = [1,1,1,1,1,1,1,1,1,1, & !1-10 1,1,1,1,1,1,1,1,1,1, & !11-20 1,1,1,1,1,1,1,1,1,1, & !21-30 @@ -1249,7 +1318,15 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 4,3,4,1,1,1,1,1,1,1, & !61-70 1,1,1,1,1,1,1,1,1,1, & !71-80 1,1,1,1,1,1,1,1,1,1, & !81-90 - 1,1,1,1,1,2,2,1] !91-98 + 1,1,1,1,1,2,2,1, & !91-98 + 1,1,1, & !99-101 + 1,1,1, & !102-104 + 40,40,40, & !105-107 + 40,40,40, & !108-110 + 40,40,40, & !111-113 + 40,1,1] !114-116 + ldasOutDict%numLev(105:114) = ldasOutDict%act_lev ! Set crocus levels to number from namelist + ldasOutDict%missingReal(:) = [-9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !1-5 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !6-10 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !11-15 @@ -1269,7 +1346,14 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !81-85 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !86-90 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !91-95 - -9999.0,-9999.0, -999.0] !96-98 + -9999.0,-9999.0,-999.0, & !96-98 + -9999.0,-9999.0,-9999.0, & !99-101 + -9999.0,-9999.0,-9999.0, & !102-104 + -9999.0,-9999.0,-9999.0, & !105-107 + -9999.0,-9999.0,-9999.0, & !108-110 + -9999.0,-9999.0,-9999.0, & !111-113 + -9999.0,-9999.0,-9999.0 ] !114-116 + ldasOutDict%fillReal(:) = [-9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !1-5 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !6-10 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !11-15 @@ -1289,7 +1373,14 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !81-85 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !86-90 -9999.0,-9999.0,-9999.0,-9999.0,-9999.0, & !91-95 - -9999.0,-9999.0, -999.0] !96-98 + -9999.0,-9999.0,-999.0, & !96-98 + -9999.0,-9999.0,-9999.0, & !99-101 + -9999.0,-9999.0,-9999.0, & !102-104 + -9999.0,-9999.0,-9999.0, & !105-107 + -9999.0,-9999.0,-9999.0, & !108-110 + -9999.0,-9999.0,-9999.0, & !111-113 + -9999.0,-9999.0,-9999.0 ] !114-116 + ldasOutDict%validMinDbl(:) = [0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & !1-5 -1000.0d0, -1.0d0, -1500.0d0, 0.0d0, 0.0d0, & !6-10 -1500.0d0, -1500.0d0, -1500.0d0, -1500.0d0, -1500.0d0, & !11-15 @@ -1309,7 +1400,15 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & !81-85 0.0d0, 0.0d0, 0.0d0, 0.0d0, -1000.0d0, & !86-90 -5.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & !91-95 - 0.0d0, 0.0d0, 0.0d0] !96-98 + 0.0d0, 0.0d0, 0.0d0,& !96-98 + !! NBNB Check these values + 0.0d0,0.0d0,0.0d00, & !99-101 + 0.0d0,0.0d0,0.0d0, & !102-104 + -1.0D+3,0.0d0,0.0d0, & !105-107 + 0.0d0,0.0d0,0.0d0, & !108-110 + 0.0d0,-1.0d0+7,0.0d0, & !111-113 + 0.0d0,0.0d0,0.0d0 ] !114-116 + ldasOutDict%validMaxDbl(:) = [100.0d0, 100.0d0, 1.0d0, 20.0d0, 20.0d0, & !1-5 3000.0d0, 1.0d0, 1500.0d0, 100.0d0, 1.0d0, & !6-10 1500.0d0, 1500.0d0, 1500.0d0, 1500.0d0, 1500.0d0, & !11-15 @@ -1329,7 +1428,15 @@ subroutine initLdasDict(ldasOutDict,procId,diagFlag) 1000.0d0, 1000.0d0, 5000.0d0, 5000.0d0, 1000.0d0, & !81-85 1000.0d0, 1000.0d0, 1000.0d0, 1000.0d0, 1.0D+6, & !86-90 30000.0d0, 1.0d0, 1.0d0, 1.0d0, 400.0d0, & !91-95 - 1.0d0, 1.0d0, 100.0d0] !96-98 + 1.0d0, 1.0d0, 100.0d0,& !96-98 + ! NBNB Check these values + 1.0d0,10000.0d0,1.0d0, & !99-101 + 100.0d0, 1.0D+5, 1.0D+7, & !102-104 + 1.0D+3, 1.0D+3, 1.0D+6, & !105-107 + 300.0d0, 1.0D+4, 1.0D+4, & !108-110 + 1.0d0, 0.0d0, 1.0D+3, & !111-113 + 1.0D+9,1000.d0,1000.d0] !114-116 + ! Loop through and calculate missing/fill/min/max values that will be placed ! into the NetCDF attributes after scale_factor/add_offset are applied. do i=1,numLdasVars @@ -2160,6 +2267,7 @@ subroutine initLsmOutDict(lsmOutDict,procId,diagFlag) !LSMOUT files lsmOutDict%numSoilLayers = nlst(1)%nsoil + lsmOutDict%act_lev = nlst(1)%act_lev lsmOutDict%modelNdv = 9.9692099683868690E36 lsmOutDict%modelNdvInt = -2147483647 diff --git a/trunk/NDHMS/Routing/module_lsm_forcing.F b/trunk/NDHMS/Routing/module_lsm_forcing.F index 1827818de..5f2596dc5 100644 --- a/trunk/NDHMS/Routing/module_lsm_forcing.F +++ b/trunk/NDHMS/Routing/module_lsm_forcing.F @@ -565,10 +565,13 @@ subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) if (ierr /= 0) then ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... if (ierr /= 0) then + ierr = nf_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... + if (ierr /= 0) then #ifdef HYDRO_D - write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & + write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & trim(flnm) #endif + end if end if ierr_flg = ierr mmflag = 1 @@ -2980,12 +2983,22 @@ subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) call mpp_land_bcast_int1(ierr) #endif if (ierr /= 0) then - write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + ierr = nf_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(ierr) +#endif + if (ierr /= 0) then + write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & trim(flnm) #ifdef MPP_LAND - deallocate(buf2) + deallocate(buf2) #endif - return + return + end if end if ierr_flg = ierr mmflag = 1 diff --git a/trunk/NDHMS/template/NoahMP/namelist.hrldas b/trunk/NDHMS/template/NoahMP/namelist.hrldas index 551de2159..c760fe65b 100644 --- a/trunk/NDHMS/template/NoahMP/namelist.hrldas +++ b/trunk/NDHMS/template/NoahMP/namelist.hrldas @@ -76,3 +76,8 @@ rst_bi_out = 0 !0: use netcdf output restart file FORC_TYP = 1 / + +&CROCUS_nlist + crocus_opt = 0 ! 0 model is off, 1 model is on + act_lev = 40 ! 20-40 normal range, 1-50 acceptable +/ From 0d5e8d3c83c2399d6d57293ed641aca9cc8bd1f8 Mon Sep 17 00:00:00 2001 From: Soren Rasmussen Date: Wed, 23 Mar 2022 17:58:22 -0600 Subject: [PATCH 15/25] bugfix: added Crocus to CMake files --- trunk/NDHMS/Land_models/NoahMP/phys/CMakeLists.txt | 5 +++++ .../Land_models/NoahMP/phys/surfex/CMakeLists.txt | 13 +++++++++++++ 2 files changed, 18 insertions(+) create mode 100644 trunk/NDHMS/Land_models/NoahMP/phys/surfex/CMakeLists.txt diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/CMakeLists.txt b/trunk/NDHMS/Land_models/NoahMP/phys/CMakeLists.txt index 640ebc276..de3643a33 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/CMakeLists.txt +++ b/trunk/NDHMS/Land_models/NoahMP/phys/CMakeLists.txt @@ -1,8 +1,13 @@ cmake_minimum_required (VERSION 2.8) +add_subdirectory("surfex") + add_library(noahmp_phys STATIC module_sf_noahmpdrv.F module_sf_noahmp_glacier.F module_sf_noahmp_groundwater.F module_sf_noahmplsm.F + module_snowcro.F ) + +target_link_libraries(noahmp_phys crocus_surfex) diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/surfex/CMakeLists.txt b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/CMakeLists.txt new file mode 100644 index 000000000..50f2fe4ec --- /dev/null +++ b/trunk/NDHMS/Land_models/NoahMP/phys/surfex/CMakeLists.txt @@ -0,0 +1,13 @@ +cmake_minimum_required (VERSION 2.8) + +add_library(crocus_surfex STATIC + ini_csts.F + modd_csts.F + modd_snow_metamo.F + modd_snow_par.F + modd_surf_atm.F + mode_snow3l.F + mode_surf_coefs.F + mode_thermos.F + tridiag_ground_snowcro.F +) From 33a8507f1a0b05489077cb1825e1d40675e56987 Mon Sep 17 00:00:00 2001 From: David Mattern <41338082+jdmattern@users.noreply.github.com> Date: Wed, 6 Apr 2022 14:00:27 -0500 Subject: [PATCH 16/25] Alaska Glacier Dammed Lake Release RFC Assimilation (#581) * Alaska RFC GDL reservoir implementation and unit tests * Add water elevation test to AK RFC reservoir test * Add RFC forecast Alaska glacier sum inflow with assimilated forecast value Co-authored-by: Ryan Cabell Co-authored-by: David Mattern --- ...19-08-18_00.60min.SNOA2.RFCTimeSeries.ncdf | Bin 0 -> 47863 bytes ...reservoir_index_Standard_AnA_APRFC_GDLs.nc | Bin 0 -> 15036 bytes .../RFC_Forecasts/module_rfc_forecasts.F | 41 ++- .../module_rfc_forecasts_properties.F | 8 +- .../Routing/Reservoirs/reservoir_tests.F | 238 +++++++++++++----- trunk/NDHMS/Routing/module_GW_baseflow.F | 2 +- trunk/NDHMS/Routing/module_HYDRO_io.F | 4 +- trunk/NDHMS/Routing/module_HYDRO_utils.F | 1 + trunk/NDHMS/Routing/module_RT.F | 3 + 9 files changed, 223 insertions(+), 74 deletions(-) create mode 100644 tests/local/reservoir_testing_files/2019-08-18_00.60min.SNOA2.RFCTimeSeries.ncdf create mode 100644 tests/local/reservoir_testing_files/reservoir_index_Standard_AnA_APRFC_GDLs.nc diff --git a/tests/local/reservoir_testing_files/2019-08-18_00.60min.SNOA2.RFCTimeSeries.ncdf b/tests/local/reservoir_testing_files/2019-08-18_00.60min.SNOA2.RFCTimeSeries.ncdf new file mode 100644 index 0000000000000000000000000000000000000000..4e29f58c958b22524c0a4586fc840dba901c2279 GIT binary patch literal 47863 zcmeI*4R{kp{s-_$(?VNX-rtJ6qzEENOGB+%&O%FHY){HdTjWr&_9ca!Z30b-7C~MV z5f4PXL$4?*C@3l(ps1*bsHk|LqTq=qA}XG!ps0wb=*{fzg!F5_Q0^)JmwU1g)7_o@ z>`Q(-*_}*w!ra`foY?3t(P5F1LJz-M!;z=WoFr?(b@yMjdqi$lL0IfzTUbvc)85ir z_G2q^VqR-=yw(~=hY6d?X>H7>+0CT|=19a`rY7v7rHB;aLKF|r99iw1=&JU+T|UuH zF1kRbFqtO1s(o&+C(Sw4#J1@Tt07QjbFZ`e7C2@Z@pS|5GtLQ z6myo40kMl%bG<6J&*%1xzoewH#$_C`43;4iQd3ivjgYprX+5s1T|R$tg}2&OR^sy; zT%7{7;iQ=ULNt@MooR=U$uG9zSnR2(Ds@%Y+xp~ziB8D_L+`C$tT79Ku-V$H>@b_n z7GW*dV|#mb%G<>EP^VN54$&!6beb-wB8hA&FU%V;ytptkV_3FT?iN_(Zh~4{4rXcG(a)Tl zVvdC9qbC|M9=QFf*b$kz7wcngPLEmiY{cdyS^mu}52`K3Txyot2h0kut?@fNUjOk$lS``IC8d?FM28+y#P*c;)|+Q> zK+suKZvr*w@u{E1Vde%--&q`Kl`wr4V=7fZ?4p%O60!&tWanfTWDn2GE*_RwSR~Gq zu~MZ%zS~QDF24|+)7~aaN3+37Y@BSe2N=rSEn%k(L~4^MBQP7*Ow%?oYQ zl?C-yQ-dBajy30X**Iw3`tAlQxfus2CZBQ@LZ>E!;y_3KH!kX^%nRmRo(dJR= zE2y|oAN7Aae(T^Z({l<7v&Fksh0m5P#51Y{e>Q7_te7-PfZJ1aZxk2F{)lF2fd2EV4k4jlCHd6M4LDDO0Q>pv8SZU ztj)#CMd~tBkdx`~`Abx_(BUq3dHn7QSGB`i;iz_&3dvr zI<(ngYLL(8 zke>r$y49<5)p)G9s(PbZO_9shq^fPSR<(`e6-}eI5hsy)2k1(M3W8cu4SKAiu){ht zYQw?v>dL)#`o!^aWDS9W`kSc6TjA7E)mI$zR1UXJ}1S` z*~g?CImThAO)1cbC>v{$D96i9s8^fi_LWU2sUGi2EUPJXmlapJ{PF`_vHWCL>~ocQ zJ>@YDQjpaM^y)sQ9RQq8aT-eL*-!&CfJLeyoLg zY!~T6G-EC28WB&gT8YGSq+Fz;F=m3xKS5p!ds`?WEbwv_Dy=HPy4 z^(;d*Q%W^CNM&6ij;lp!(?{eK%54e#D$G6Vb7*Z$j>5%AagA`uDN|%w_ebkZD)e}T z&og~!(Xbp5@ng$h;>3M&g{~qtv#3DKlarl9&W)`u5g*9OZX#yc^l_qEPIeI=dd5!_ z9pq$BQGI#8>&5v7nE2qWw}^3ae_h2{WfK>RjWV}~_-gPQ_lgT;ZoHU(`=m!jk<9Hb z2K+GaNl`0v&l1gScRnY6lDTJ!f-Bp-EV|3w?&7u!QxA%JjE(J?zC$hz4W}yt#`!3tdbO{3z+4`zo4CJn+Xjki9q1qA#eWjV%9)w!SQ>ASq@r@ z2%{=#@2BQ%Gj#3IYgKJ@X=%hwLKQD|ljy7tN2W}#thT7yqHg*#ZxFtdSK`dO*x3GR zCqb1)>+);n2L3i1fA8x}7mG=!9*ZIBP{<9_As4Aw6nXt6l@4#I&s9CyRc-~sQR-5m zaTFybHZ~@YVN3#VJh>Agj`i)Hcq*|luK*5V)yev)d3gz$VV;0j5{!)+cMmnyh;lJP zIT8zXZ&k6#sdi1Oae2yW2l!o86TQ_kFx7$P=Z4BlPjygs-Nt(SLxx#d5W=j&`9%F# zeCYJ_GGo#HL~R;@`jk2}RcEgM9x)>kOCoWC2C3m{Ya|k?Q9@~6%l(sHE+gD1g<2t*1JdF9dwB~LBoMjC2HX0_Omu`om_|fzM;(J zaHgK0l#t|<{~Y=&4M(L{M#)ihsd=i}so=^X@KLjeIe)^xcW19jGd}PSGvn9z&s6$` z8$8yZsZ?G;pPkQNlsRIUvD~WHYOAB+5{I9ew-P`FcCL9)S6}LV)?Y){Xh9-mM1A zH*bLJAQXX61VRxAMIaP`Py|8|2t^%FWka`qs8)rP?>e+l#}N3Acfs$?qf=0) zracVRI1zjpDk>{psO!`8%{!`Dqaf=wZ_{sCHH^$(`_eN;=&VOPu7-x`7}->%p5$$s zrYhA!vS{_vU*)JthTtRjSx2s$tJIO7+Jg(~e5xUMtc#gyEUJESS&jkzEC1;7rP{!o z=4`75v-xulUSn+eeIXmpoARMm-3+J4`k_^Qa`c0XdR{-csOS5suQG#%^Ew92$jPDV znUBsktJ-^k z)tqVz*X_1ZfuqsabX&M?yN!`g-q+~f0y?s`aNUF(9e5hUr^9Ru*C(QN;JJ)q<53Nt zj=U{gH|e(Ut1qgIZ|;2hJlMkZou#Gz0?P#Y#Mr`h3vZMeCD%lsK1sH4bum*zyTG9p zo8NZGkmyrq3)gMFQSz&y>RQz$0Z*g3mC)Z%1VRxAMIaP`Py|jP0-2e)na-g8bo$HV zcw3TaEi1p}Vn&xAjHl_hZQYu-ZR@bXi|gtJ%jv;#Cqow3#SKYLP97rjhg4Kl$Ok@V z$mw}9zfR7tkjoyEdCw2of9%%^FEe&pUS-bGVe>7_qELXR_1*# z^Nz~ApJkrNSX^hzNKUqA{HMqL-@aZ&MUITsFd4f-8Mm=AW>?A>R>-_cndg&vwK8vp zoW5S>-zewj%4PFp-mU5X?Xmg4_WF*5j~;p?e3VT2GUdsXEmMX}X)>kClp>Q;rUaS# zS}9(RyU7$MQwN#a$P_D6luQva*@k`<^<&0YQQye)xlA9)^qx#_$@H2`FUa(?OlxI& zNTy{nEtcsvnQoS8R>lYI{4$lxR3uZDOy|nfD`QW)_A-TMZ0z${`o=!5%JiU2H_5US z8bT2WMWE>-P*jket$K#*t|@w~KZ&zF{d$GD1YIhu@QQlCS`O&cgVw>r`EGL#-NV61 zPJ7M1CcoLy0DsYS>}Dan6c{9o8E+t~Qje81+VxDs=lHYxl$Ypv%g@cDq5aJ2!E^16M`dh2SO;mj7@)6K_!y4l9>nS1D5jPy%dg4Za+d$k%aGQu51#UBO z1>m+2R|sw!an{!j0ll5L(E(vj>?H0IaJz^b18z5Qe*m|axUt~&5f|vqZ~6ViT?X4b zK%D&Tw0grK;*3W^g5+W1tgndz@+fh|0bx!YBkoFYHtPm}_k|L05yX{(iz2QJTr6?r z;Mx%90@s1K3UG16jR)6_xC!9miL<_r3+Ud&{V^cSiN3^L1ulWON^nl%s=%cX=K+^W zoEKagaTCF15H|^2HgVXV1*?T-tq26_jn)^`?0aPl*i7hSp_l9SJUu^~IQ=BMc5{i- z&$MedpE$fuEhJ7q@~*eHh&cWDyLNTN>F40JTSA_!^Cw5ca*pu;EoaJ0B0lhsCaM@#PtLhMckR-Vu|Yot_^X$!F3?+EO2qe z^#Rw7xU<2<6W149Z{qra>r31@;1Y=I56($k0=N|762YYsHvn83aY^7Zh?BpwR&U5A zZeTqnL>_U;;PQz(7u+b~QoxNS&iEg<98v0+&JQ_w{<|45NBlvTxg=<2`+*ELrh=a#GMGbM+!S-s2n+|RoaWlZpByJ|S*~HBPH0Jnj-TfuE2 zZXvkM#N7sN3vqu2w~e^JfZI;oB5*s2yB*vv;_d*qo4CJ%+e=&>xP8Pe2DhKMJHZ_w z?k;eLh+6{gFmZQ-J4)O=;EoY@FF4!p%nWSbSPCwJxMkp?h`SG5EOGaPYeU>}a2<$S z0WOZX2f%eB?m=+z#H|F^o4AL-^(F3MaG}|TBcSVz`ul0!p9IS{#xsG${SnxWleksj zQiyvLTq<#Y1D8hJYH%6EtpS%!+*)vX#61QspSZ`tjUsLxxY5Kt0d6dDPl6jq+*9C6 zh+7ZNMcmWi+{8Ttu8O#4!A&A=1GpOEo)+(vNIh(d^ts!n3xOK$64sJbh zZ-CoC+?(Jw5w{)OX5!ugw}rU3!EGaM2e|FT?F6@zxOc$qBJLmHb`$q5xV^;f0=JL2 z_rUEZ?w{Ze5cfW~L&WU{cbK>jz#S!S54dB*eF)BWp_zg8jlJL^i2Dd!6mcJeizV(8 zaG}|TBVg7W(*pgJS$}GbXB!gteXyGj#C-}bj<|n;>qgvX;Npqf53Vy zi2D+pleh!mQiwYUE|s{iz@-uQHMk7o4uQ)i?i+A<#C;1cpSbV9jUw(axY5LY4{j`R zN5G9E?gwxs#2p3aBJM|UZsL9dS4G^<;3g4w3|tLyzksVH?pJWrhztBAsO4u87x*7w zEjOFEFkAf{&n3Wajn2@Ag(pIO~kbUx0$%M;IxV^;1f!jx17jXNDI|JMS;<|!6L|iv;hlx}FJ!bH5l(-(?juGboXG;s- zdi`HaR!gv+U0W=B%Ley*;&Q-UOx#7_h7p$w zE}ytOaKnlFJ-89XT?}p{al^okA}$|X0dd2@6%scBToG|2!Hp(v6u3)>D*!i!xI%D$ zAg&19SmH*5yOg*~z+Fb%7;u*p_Xlv}h#L#;3gRvWS4`Yx;I1U@a&RTYjRRLo+!f%; zh${wHPTZB?T*Q@tt01lv+<4;3z)c{o9Gsgt7q~wXR{`!S;>LrkByIw@D&pMWJjDGG zoR_$(z)d8s65J%>s=!qf=K<#<&I`^@+(d9S#7zP>nYe0jq1lEbpzDpgoss=+4z3+R z;*RymX2gZT2AdOS2Ny{k*1w~Oi-7G#6W0t}3*wrCiy;93$F4Xzb&Ex@%V zE(Tm1;$p$IC9Wm7cEq&;*Pgi6;5rc323$wt+JfsuTsv@`iE9roj<^osx)9e9+!@4m z0@sze&fvNc7YD98ab3XmAnpus4&u6kizludxSqsy2X`iMJ;3!M&H=7Baq-~JBCaR6 zKE#~~?rh?Ef$K|LZ*cvHI}6-7#PtE!pSZKZB@ovaTq1G(zzrbo9B@g*^#|u9E&<#? z;u66n6E^_dxx^)bOCin)?mXfKf;*qMWN;S{cP_Y8;!?m3BJMnJza#E^a2FDH0k|~c zuzd_x3(Z;)(Dg=LUu3_Ji1qNRN!)!9*=vaNgR3R32HX_lCWE_{xU0cUCGHw<(}=4D zcO7w4z)dIaT5vOnn+k3wanr!fBJMhH*Aq7#+zrId05_Ysnc!|DZWg#X#9a^WCgN@Y zH6|Bw-DUz#N7t&4&wd{?ytoC1za6*i@+@=?sjl@5_boc#q?p|=qiCYS81#!#3JwV)j;2tFIesC*^ zTMq6a;#Porn79YPJwn`r;8qd065ON2Jp}G=#61iyG}~|lbiGl3KdpZ+8`}*ro~udR zAA#MhA#N48wZuIN?lI#22JUgN;R?g?&-gL{s+r@?I`?ip~;6Zb5*O~h>g_X2UxfqRj-jo@A)?s;&ViQ5G3 zW#V1{_X=?@f_s&?m%wcyZZo*ohZ-aZ6xEy$fzPal62MK-_!a_7L|^a32!)KDfQa?FRP|aUX#Dn7BRQJ|XTyaQlec3+_|m zJ_7eI;ywoV8F8P03(Ynh0khtiCUiTa{=ORPjTq1UB<}lQH=h&tDY!3)`xm$`iTe!P z0pj+9J4oE;;Jza63vgc(_a(SP#2o~|^m zCYCtt7t@kB>=)CDIP4eGnmFti(}p=)CHIP4eGo;d6m(}6hb7t@hA>=)CC zIP4eGnK=)C6IP4eWAP)P*#1n`8 jVtNvX{bJ4}4*SLQA`bh-^tPP7eCq2tj`i~Y>G8h-%F}KX literal 0 HcmV?d00001 diff --git a/tests/local/reservoir_testing_files/reservoir_index_Standard_AnA_APRFC_GDLs.nc b/tests/local/reservoir_testing_files/reservoir_index_Standard_AnA_APRFC_GDLs.nc new file mode 100644 index 0000000000000000000000000000000000000000..7f525b8e11cedf734e8e1aa7227083fc4826d3ac GIT binary patch literal 15036 zcmeHO3viUx6~3EnViMK>8FwWve{2<)u8-w&GL}kx^)smjskTEz{NqQb&chBehm5P#Jp9J?AVTWI<+RCQkPz zyXQaWo_p>+-#z!<-J6r8W1K~|r*%maP*PHaRkTr${C1hjo?$3qp6jRcLkwCr##x?V zJDt!&)hDKs+Qq*3aPl^!|0SB1AS@uU>F{n5=^{n`cuF1P!l4=?Z2FCel(&&8BmPh@KYM=AFe|;jfPV&ya<)j-R+hBSlghkN`d)Nl;R;(5mzr zOHzISdWn|OJ5Z&HVv8p`AvSjRLJNyXQz!&N!I_?*UTvTm(M|#grWg&EKHJcWoiI^C ze42z>(~t43)EVyZ1J{$oGy>w8==5S&cu3RMS9qX7~#5* zKkPB*)ff%r=GtR(E5V#?r&7O8Xsm$lKuH!yK#xTHJ~@077DvdZMXk%HfT2eW&8wTb z23-x;Tt=M{&}u@VfR?Xi_tVC^N4xvW?JnYvm`1SDkkTBG+8u>W!~^?jji7U*4Zv0Gt`Gv&3IuW|`GUp7+ZTJ( zm`=wPsl0vpzVsTf&S4UybE3Pn0mU{2dyT!Ma-|kq=MBcJGQck_5F!MNotpGf19_;{ z^aVn5fmc4y{&>#Us;gV{#@NBh^xa_xVORfokMp-=(4#8GIOSF@`+zm&?Q=@5IVh>} z2g~`IsToQu8MInUq15V+byu{GopxU;a=Qz~3Nm0hD#Rd|teQ1}GpK!o_tB0rmzrI* zOJ1323L!C;rk=fc{qQ~FcQ3U)6;$Q2C zdhd`tRY(5Mn>y6xNxi=ieV6E{WoYj}J?iZ`;8+6oM(#)bhFp|?@+j(kO7twzzY~4W zL_P0%q!)jYQ3L&*pmAIxy+6=6-`Vg>7xeRa4(g};9PNM65Bao@hyE1mTM@MpO@AN# zZT&R1zpw=L+Yx_hEAkyypuME=$R|IJG~@8-NieQuyO7sNFY_$+*O%;fxCiSyK81An z6X?&7BZ$wiXCEjBJHrUS;Y9OEFQ4ob92@8by-`PyI;ei>Tgc}U&L1Aaapm5L{gtf5 z@kh2HpZ6TjNB$kiXBpW^xj^5ft~ zX!j7w-z0kUK>jrF|EskaUz@1?>tt`A1MR-{IF9!e&D&`j_i5rcQ{3kbM*ZI(MS7w) z(vvjLfBFgX|2l&H{F~_eew2Se^Y+!d829J5p+6UhUObHaH^g7whw(X_+9$k#_5YZS z_7eAFeG17}(mFW53hUcHgK>SS4Ec`4Czc|A|3Sp32gONG@-v<0^T8((mu!mH9HIk> z<`Vsq{LG{HAI$UCkzNUEz9Ynpl-{E*> zQoBkQj^{^f(BJt~{}Ay%rggA@{PI7B`in?!G3f>9y!d7q)`#nmE`JjDuSc1Z{@g=Y zKWjb4`x7*ui)cO{rgdDsAIJU34^e+3;kju8+TBca3&qD4s-H|aJpVTCcZqaPY+r}{ zt)qE-iRNV|(T(IsSDMe=B>x-jBU=ftZnU58C7ch_`NDty;j@-+{jGGk@~uAK;)8zt z6~`bR11&EGV68UyYCb)NS2WX`NsqCL0ok}gq|*k%NeRg@lM-5LdW@#!Nmqs}$k&_4 ziFZJzH-nQ9r&MB#qzG3ujVN~VM$5%%ko4i+zFUq*6JGj&Qx?pcl4(y^7^kLuqDpRo zR2~SKq*Ne~{GtNLngpzR#H%I=^B(Kxye9`#`PdMQ=oR6S@3 z(K!F3bYh7%QKkWfXN0`-WS&(t0c37e==T~yQ>NJ%Uaht!VulU98ggwQb7ZDI(}-k^ zf8}IBG)}HcH)BkgUcm-GbA0>6s1byTGB17j7BK=Y-*k+quvG1!_0=%}SqwOrBOskd zmU&3{YD02grk?I~tFf5S0n4m!eZMsSX?gX*Q%&|%s7?Lm!PhhNQdvJWTJ~I zocY4}hEYoOoKQn-Od_L-7q?o?LTHkX$l(SLEw&yna?7+G!96#fZ`QPmaiU(f#t0B1 zlPtu>@Ci%duFtFUTSt1bG}$zBC6$MSJA$Fp-(K8 zk3B@cKNk1}r1ta{XBKo0iVpIzo5;({4+|J;7xCeo3vUXSe9RR8OnLpdXpoQH#ldzn zq7f$r@zOF7Q1j1QoZOn^sJc=3$w!>fXjtN;@>eek4crZ-GKL2qs}w^~(-;MuOho}i zfhj2VE_8qHSj&Lr|7H};-M+Uc?`^wbOM*`-E%Elf>F)RHT{vu(pB#AbPVlbzq;Q)& zVIj%*yUW*vNOw%0yrwxs`Q*2qg>ODB6;WQvOc_yL42OF26Vi|RT+N@m`)aJM9H_d10W^EYKt~t*$c0#tr$~#evRBVft_oh_&3D4swD=Btz zTBgOyZnX~kDn0P&Pj>1F7(q?|wa5?mSXwpGU=S=;-pW)h<%%;T7Ax;;?V&Aa9(yQ7 zn~}1}%y}$I&6NKf5efJ!4Nu7DlYhZ#3Lxozp9!o6+iYBGu`|3K(nVgkC3?NTy0%&i z)>h9j!tiO`tIvyQW=JD2HJL9DY2Gq}-qh;!K&{O9#*g$2``L6eQ+2%YMjh8R>bOkJ zfd-SJ`GZ! Date: Thu, 4 Jun 2020 14:41:47 -0400 Subject: [PATCH 17/25] Balance and ensure boundaries of RFC Forecasts Reservoirs water elevation --- ..._persistence_levelpool_hybrid_properties.F | 3 +- .../RFC_Forecasts/module_rfc_forecasts.F | 26 ++++- .../module_rfc_forecasts_properties.F | 15 ++- .../module_rfc_forecasts_state.F | 4 +- .../Routing/Reservoirs/reservoir_tests.F | 99 ++++++++++++++++++- 5 files changed, 134 insertions(+), 13 deletions(-) diff --git a/trunk/NDHMS/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F b/trunk/NDHMS/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F index 2dbc8471a..ac1ad2178 100644 --- a/trunk/NDHMS/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F +++ b/trunk/NDHMS/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid_properties.F @@ -20,7 +20,7 @@ module module_persistence_levelpool_hybrid_properties type, extends(reservoir_properties) :: hybrid_properties_interface real :: min_storage ! minimum storage (cubic meters) real :: max_storage ! maximum storage (cubic meters) - real :: lake_area ! area of reservoir (km^2) + real :: lake_area ! area of reservoir (meters^2) real :: orifice_elevation ! orifice elevation (meters AMSL) integer :: lake_number ! lake number integer :: reservoir_type ! reservoir type @@ -59,6 +59,7 @@ subroutine hybrid_properties_init(this, lake_area, lake_max_water_elevation, ori integer :: number_of_weights, number_of_lakes real, allocatable, dimension(:,:) :: temp_real_2D_array + ! Convert from km^2 to meters^2 this%lake_area = lake_area * 1.0E6 this%orifice_elevation = orifice_elevation diff --git a/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F b/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F index b5f0c5928..d78d056f8 100644 --- a/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F +++ b/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F @@ -130,7 +130,7 @@ subroutine rfc_forecasts_init(this, water_elevation, & // trim(ADJUSTL(lake_number_string)) // ".") else ! initialize rfc forecasts properties - call this%properties%init(lake_number, reservoir_type, reservoir_parameter_file) + call this%properties%init(lake_area, lake_max_water_elevation, lake_number, reservoir_type, reservoir_parameter_file) end if this%pointer_allocation_guard = .true. @@ -276,10 +276,11 @@ subroutine run_rfc_forecasts_reservoir(this, previous_timestep_inflow, inflow, & ! Update state water elevation this%state%water_elevation = water_elevation + this%state%levelpool_water_elevation = water_elevation ! Run levelpool reservoir call this%state%levelpool_ptr%run(previous_timestep_inflow, inflow, & - lateral_inflow, this%state%water_elevation, levelpool_outflow, routing_period, this%state%levelpool_reservoir_type, & + lateral_inflow, this%state%levelpool_water_elevation, levelpool_outflow, routing_period, this%state%levelpool_reservoir_type, & this%state%levelpool_assimilated_value, this%state%levelpool_assimilated_source_file) ! Check if Routing Period is greater than 1 hour, and if true, set forecast_found to false. @@ -310,7 +311,7 @@ subroutine run_rfc_forecasts_reservoir(this, previous_timestep_inflow, inflow, & ! If reservoir_type is 4 for CONUS RFC reservoirs if (this%properties%reservoir_type == 4) then - + ! Set outflow to corresponding discharge from array this%output%outflow = this%state%discharges(this%state%time_series_index) @@ -321,7 +322,18 @@ subroutine run_rfc_forecasts_reservoir(this, previous_timestep_inflow, inflow, & this%output%outflow = this%input%inflow + this%state%discharges(this%state%time_series_index) end if + ! Update water elevation + this%state%water_elevation = this%state%water_elevation + & + ((this%input%inflow - this%output%outflow) / this%properties%lake_area) * routing_period + + ! Ensure that the water elevation is within the minimum and maximum elevation + if (this%state%water_elevation < 0.0) then + this%state%water_elevation = 0.0 + else if (this%state%water_elevation > this%properties%max_water_elevation) then + this%state%water_elevation = this%properties%max_water_elevation + + end if ! Set dynamic_reservoir_type to RFC Forecasts Type this%state%dynamic_reservoir_type = this%properties%reservoir_type @@ -342,7 +354,7 @@ subroutine run_rfc_forecasts_reservoir(this, previous_timestep_inflow, inflow, & end do if (this%output%outflow < 0) then - + ! If reservoir_type is 4 for CONUS RFC reservoirs if (this%properties%reservoir_type == 4) then this%output%outflow = levelpool_outflow @@ -352,6 +364,9 @@ subroutine run_rfc_forecasts_reservoir(this, previous_timestep_inflow, inflow, & this%output%outflow = this%input%inflow end if + ! Update water elevation to levelpool water elevation + this%state%water_elevation = this%state%levelpool_water_elevation + ! Set dynamic_reservoir_type to levelpool type this%state%dynamic_reservoir_type = this%state%levelpool_reservoir_type @@ -374,6 +389,9 @@ subroutine run_rfc_forecasts_reservoir(this, previous_timestep_inflow, inflow, & this%output%outflow = this%input%inflow end if + ! Update water elevation to levelpool water elevation + this%state%water_elevation = this%state%levelpool_water_elevation + ! Set dynamic_reservoir_type to levelpool type this%state%dynamic_reservoir_type = this%state%levelpool_reservoir_type diff --git a/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F b/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F index d98ce6b2e..de82b451c 100644 --- a/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F +++ b/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_properties.F @@ -19,6 +19,8 @@ module module_rfc_forecasts_properties ! Extend/derive rfc forecasts properties from the abstract base ! type for reservoir properties. type, extends(reservoir_properties) :: rfc_forecasts_properties_interface + real :: lake_area ! area of reservoir (meters^2) + real :: max_water_elevation ! max water elevation (meters) integer :: lake_number ! lake number integer :: reservoir_type ! reservoir type character(len=5) :: rfc_gage_id @@ -45,14 +47,21 @@ module module_rfc_forecasts_properties contains ! RFC Forecasts Properties Constructor - subroutine rfc_forecasts_properties_init(this, lake_number, reservoir_type, reservoir_parameter_file) + subroutine rfc_forecasts_properties_init(this, lake_area, lake_max_water_elevation, lake_number, reservoir_type, reservoir_parameter_file) implicit none class(rfc_forecasts_properties_interface), intent(inout) :: this ! the type object being initialized - integer(kind=int64), intent(in) :: lake_number ! lake number + real, intent(in) :: lake_area ! area of lake (km^2) + real, intent(in) :: lake_max_water_elevation ! max water elevation (meters) + integer(kind=int64), intent(in) :: lake_number ! lake number integer, intent(in) :: reservoir_type ! reservoir type character(len=*), intent(in) :: reservoir_parameter_file integer :: ncid, var_id, lake_id_index - integer :: status ! status of reading NetCDF + integer :: status ! status of reading NetCDF + + ! Convert from km^2 to meters^2 + this%lake_area = lake_area * 1.0E6 + + this%max_water_elevation = lake_max_water_elevation this%lake_number = lake_number diff --git a/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F b/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F index bacb1829f..e71d6c1f0 100644 --- a/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F +++ b/trunk/NDHMS/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts_state.F @@ -14,7 +14,8 @@ module module_rfc_forecasts_state ! Extend/derive rfc forecasts state from the abstract base ! type for reservoir state. type, extends(reservoir_state) :: rfc_forecasts_state_interface - real :: water_elevation ! meters AMSL + real :: water_elevation ! meters AMSL + real :: levelpool_water_elevation ! meters AMSL real, allocatable, dimension(:) :: discharges logical, allocatable, dimension(:) :: synthetic_values integer :: time_series_update_time ! seconds @@ -52,6 +53,7 @@ subroutine rfc_forecasts_state_init(this, water_elevation, lake_area, lake_max_w ! Initialize the state water elevation in same manner as in module_RT.F this%water_elevation = orifice_elevation + ((lake_max_water_elevation - orifice_elevation) * initial_fractional_depth) + this%levelpool_water_elevation = this%water_elevation this%time_series_update_time = 0 this%current_time = 0 this%time_series_index = 1 diff --git a/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F b/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F index 20aba4b63..85b0f1ce6 100644 --- a/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F +++ b/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F @@ -27,7 +27,7 @@ program reservoir_unit_tests logical :: rv14 = .false. logical :: rv15 = .false. logical :: rv16 = .false. - + logical :: rv17 = .false. real, dimension(120) :: inflow_array @@ -79,8 +79,10 @@ program reservoir_unit_tests rv16 = test_ak_rfc_forecasts_time_series_with_lookback_and_offset() + rv17 = test_rfc_forecasts_over_max_water_elevation() + if (rv1 .and. rv2 .and. rv3 .and. rv4 .and. rv5 .and. rv6 .and. rv7 .and. rv8 .and. rv9 .and. & - rv10 .and. rv11 .and. rv12 .and. rv13 .and. rv14 .and. rv15 .and. rv16) then + rv10 .and. rv11 .and. rv12 .and. rv13 .and. rv14 .and. rv15 .and. rv16 .and. rv17) then print *, "========================================================================" print *, 'All Reservoir Tests Passed' print *, "========================================================================" @@ -811,6 +813,7 @@ function test_rfc_forecasts_time_series_output_with_lookback_and_offset() result print *, 'dynamic_reservoir_type: ', dynamic_reservoir_type if (outflow .ge. 3.6 - epsilon(3.6) .and. outflow .le. 3.6 + epsilon(3.6) .and. & + water_elevation .ge. 1331.43604 - epsilon(1331.43604) .and. water_elevation .le. 1331.43604 + epsilon(1331.43604) .and. & dynamic_reservoir_type == 4 .and. assimilated_value .ge. 3.6 - epsilon(3.6) & .and. assimilated_value .le. 3.6 + epsilon(3.6) .and. & assimilated_source_file == "2019-08-18_00.60min.CCHC1.RFCTimeSeries.ncdf") then @@ -1109,8 +1112,9 @@ function test_rfc_forecasts_with_offset_for_extended_AnA() result(rv) print *, "========================================================================" end if end function test_rfc_forecasts_with_offset_for_extended_AnA + ! This tests an Alaska RFC Forecasts Reservoir/Glacier functionality to pass inflow directly to - ! outflow whenever it does not find its corresponding time series file within a given + ! outflow whenever it does not find its corresponding time series file within a given ! lookback window. function test_ak_rfc_forecasts_pass_through_fallback() result(rv) implicit none @@ -1177,6 +1181,7 @@ function test_ak_rfc_forecasts_pass_through_fallback() result(rv) print *, "========================================================================" end if end function test_ak_rfc_forecasts_pass_through_fallback + ! This tests an Alaska RFC Forecast Reservoir/Glacier functionality to offset 3 hours in the future ! and look back up to 24 hours to find a time series file and output the appropriate ! discharge in the array that matches up with model time as would be done in a standard @@ -1202,7 +1207,7 @@ function test_ak_rfc_forecasts_time_series_with_lookback_and_offset() result(rv) timestep_count = 0 water_elevation = 0.0 rv = .false. - + lake_area = 0.0 weir_elevation = 0.0 weir_coefficient = 0.0 @@ -1246,4 +1251,90 @@ function test_ak_rfc_forecasts_time_series_with_lookback_and_offset() result(rv) print *, "========================================================================" end if end function test_ak_rfc_forecasts_time_series_with_lookback_and_offset + + ! This tests an RFC Forecast Reservoirs functionality to correct water elevation going + ! over max water elevation + function test_rfc_forecasts_over_max_water_elevation() result(rv) + implicit none + logical rv, rv1, rv2 ! test result + type (rfc_forecasts) :: rfc_forecasts_reservoir_data + real :: outflow, inflow + real :: water_elevation + real :: prev_time_inflow + real :: lake_area, weir_elevation, weir_coefficient + real :: weir_length, dam_length, orifice_elevation, orifice_coefficient + real :: orifice_area, max_depth, initial_fractional_depth + integer :: lake_number, reservoir_type + integer :: timestep_count + character*256 :: cwd_full + integer :: dynamic_reservoir_type + real :: assimilated_value + character(len=256) :: assimilated_source_file + + prev_time_inflow = 0.0 + timestep_count = 0 + water_elevation = 0.0 + rv = .false. + + lake_area = 2.096320037841796875e+02 + weir_elevation = 1.332074047851562455e+03 + weir_coefficient = 4.000000000000000222e-01 + weir_length = 1.000000000000000000e+01 + dam_length = 10.0 + orifice_elevation = 1.314473347981770758e+03 + orifice_coefficient = 1.000000000000000056e-01 + orifice_area = 1.0 + max_depth = 1.335180053710937500e+03 + initial_fractional_depth = 8.999999761581420898e-01 + lake_number = 17609317 + reservoir_type = 4 + + cwd_full = "../../../../tests/local/reservoir_testing_files/" + + call rfc_forecasts_reservoir_data%init(water_elevation, lake_area, weir_elevation, weir_coefficient, & + weir_length, dam_length, orifice_elevation, orifice_coefficient, orifice_area, max_depth, 0.9, lake_number, reservoir_type, & + "../../../../tests/local/reservoir_testing_files/reservoir_index_short_range.nc", "2019-08-18_09:00:00", cwd_full, 24) + + !water_elevation = 1331.18005 + + water_elevation = 1.335180053710937500e+03 + + do timestep_count = 1, 80 + + inflow = inflow_array(timestep_count) + call rfc_forecasts_reservoir_data%run(inflow, & + inflow, 0.0, water_elevation, outflow, 3600.0, dynamic_reservoir_type, & + assimilated_value, assimilated_source_file) + + prev_time_inflow = inflow + + print *, outflow + end do + + print *, 'dynamic_reservoir_type: ', dynamic_reservoir_type + + if (outflow .ge. 3.6 - epsilon(3.6) .and. outflow .le. 3.6 + epsilon(3.6) .and. & + water_elevation .ge. 1335.18005 - epsilon(1335.18005) .and. water_elevation .le. 1335.18005 + epsilon(1335.18005) .and. & + dynamic_reservoir_type == 4 .and. assimilated_value .ge. 3.6 - epsilon(3.6) & + .and. assimilated_value .le. 3.6 + epsilon(3.6) .and. & + assimilated_source_file == "2019-08-18_00.60min.CCHC1.RFCTimeSeries.ncdf") then + rv = .true. + print *, "========================================================================" + print *, 'RFC Forecasts Over Max Water Elevation Test Passed' + print *, "========================================================================" + else + print *, "========================================================================" + print *, 'RFC Forecasts Over Max Water Elevation Test Failed' + print *, 'Outflow should be 3.6' + print *, 'Water Elevation should be 1335.18005' + print *, 'dynamic_reservoir_type needs to be 4 for RFC forecast output' + print *, "========================================================================" + + end if + + end function test_rfc_forecasts_over_max_water_elevation + + + + end program From ddf7c1a565dcb4138c226560a497fc2429732399 Mon Sep 17 00:00:00 2001 From: John David Mattern Date: Fri, 5 Jun 2020 12:34:41 -0400 Subject: [PATCH 18/25] Added reservoir unit test for long-range AnA RFC-Forcast offset --- .../reservoir_index_Long_Range_AnA.nc | Bin 0 -> 89699 bytes .../Routing/Reservoirs/reservoir_tests.F | 79 ++++++++++++++++++ 2 files changed, 79 insertions(+) create mode 100755 tests/local/reservoir_testing_files/reservoir_index_Long_Range_AnA.nc diff --git a/tests/local/reservoir_testing_files/reservoir_index_Long_Range_AnA.nc b/tests/local/reservoir_testing_files/reservoir_index_Long_Range_AnA.nc new file mode 100755 index 0000000000000000000000000000000000000000..5772dd8ecc4af842d052b284cd19c317b4924896 GIT binary patch literal 89699 zcmeFZXINFq7A-o8AZ$R1l2t?m#6VCG(UzPMQ9ul2$ypEsm?NMf=9~lOEGpWH3B(-Q z1O_mn0*VQ<-hnpfo_Fp$_kH)r{qer9>7LG6bB-BSt+m&#RaI-}dbqf?RM1sG)1SON zWT5g(Z2srx-+#kH#V=KJyV)MzEc_SV-@|2~lv0(H;V-+i#^11lzkUmbH-B@Fzqx`G ze&tb$XwnO`f;|5V^L6%1Pfd$X9~mE=LA^Su*DpK&;oqp}^o;n_ls_!Tr9_V$9u<=m zAK9$x(XB@}%WjtA;-X@#|4nV#&9(5{7xL>+ zTj~p;-Q*&~?+#m{+0+7>IlF)c)%NXvWd;nOB@eBMM99iFS)`<-emSb}JV;@L+%IRm z`py1Tu*`ogNy(xKD$wFr&pG=z`unrp)MHI2_E%_f7temKzW$#5eZ%~n9erG(6y9VL zkp1Q5>)6kgpkH1Nptb5vaXQUpx$7KKRCw9>PzMqtu(yGYgU;QNeOViXpP3MfpNix5Bthptx z)})jc;lJVn!9xk-U-LlS_;vJ2sVT8xDG|xhO-lZ$v*VghLvt_qL?lKV zc)B#5AmFxa)4xFIZw7R17XCl^*gkJIx%vCMBIWOkzv;NXHDwVN0#~IdOo~77nb+Fy zR5zOrlz;tyv*wOr>rcyo?*F%Y^;r7vwEx+w(*Lzre^+hvcL(kNyK1G*O+DFseP*V_ zkIbN@sgD)OoBP-~Vq|n|YI^+eh@{_P)c^h<{HvdvuIT@_zXKhnZ*%kTbVBnjrU{h& z<~KC^^>6;4pWiMo79C5E&WKJQl^UNOHgarQbh-3zOkr8bW6)`fxpea>v1E1(o(Mbkrsi{c@e;8PH zF$nZ`_wUNvT}FJy$mo>e(bQTsX&s$i|3lrqi@`uQ=dLlS>CwX@GDc<)*<*1@+~;2< z`~B`|Wq$It|Lqg++?v`D!}d?7OC~qW`me z|K4W|_y36BRKu7C!%t1od8gu^v}nEzn?F-Z=cxUabtKQ&Kvy@{fv&#Ju3^8=m?lFs zow241CnI`fQ;7fVU-Oy$*G>9w^xr4*zxw|BJ+}$e{7u%}i_JWvS@=6r^GBvRu;p!? z8*q2-@AIo$nkwgCa~Cxi;r+LwIo5yb|Na>Mxbaf zoBo>d4wrwo|GusKOWz!)8Q094^^)Ii|H8*z`K|apfcl^D3$FgwH{H~l{+i=7>y>`1 z|D`{C?YE-kf9RX>t^SK%`M>D@?(ToZZ?04IKk(CT{8s$BA}Kc4*{pBA%{J>x?*7I% z59FHl&G^>;CH~)|p#LTQ-*8klA9%CkAO24d{L=&f^uRwo@J|o?(*ytXz&}0kPY?Xl z1ON2EKRxjOs~(V^bO$me@j`ZzAzC=-3%N-{AYU>8D%7drqeKJM&~ng)PKk-oMIW?r zNENaracECnN7{`s7p9Zs(3x_V5-V8ZDy%TEXLs6rq8)5YJn_e*28q2xs0d%A3|H#i zNnVqR5qUEPe)J5O1G~MI|G}GR(lLNvE-fxOMbh?+^vO@QWx!0k%@NjqM$95N%ki ze`u&UK=}}J9${acpzm3SdX$#9i!%C_lP>X?ua@jV<)jciVg4G{@qCgHFG`-Ep7CC> z4_*`V#-R=$N(|6Q-%llx_*~+LEnD10dUt!sIwqnEh6_cS$cMGSj5c5*Zl z9M2)~WTPaRb)}NhPU?sejFC;Bm**E^(quO{R5@U(<9^JTd=N7yMAy zPi~9Flb>UiV=Yz_yN3F8lsEBs3t98d$qkZS)bD1^2ZRp}i4YuS`$L{4N=^!Kk~zy$E_sdJOEg%`2jwE2*?oE43MjNi)pqhzp@o)|jC4JUpWA(q!y!o+lu>9igbPVK=| zsY{qH)e$qNL}T`;PGS!I7ftcR64FxUTX{+aYoyv@{S*ta*{QYIeyUM&P--R|AK9aL ziY`i=M&l&0r%(A|6hFIVQiH|yQ}*Jb;zSJ2|LC*)4AfZ|k7D4li}%BTIHMxBmx9ok8Ui;m7oFsCht=b`&lS@f8yF04;K zLNCfr(%Nv79s>{J2TYB|Ao3vMpWG}*uyZk@7%!SJVop~fo-t|yKT49E`y++8w9_gW zMR~Mznixkup7uqPx{FE9T`^_qK1^fmJnCmnRmB` zsv)*ZhhP=^bT4fOh(CBbNphI+*YLCdr?iP^WX@97v5ueYa{8{Hq=6f(=`QQ6U=2@M z_Y2}`rH6@z(|z#9*$!`=ui%rjC%#Y35IV+Sy9pi2^lojHf$(~QMv(wiBhFkU8H zOd!65=O$N11G8OPi&JY&MEgp?}QMXnHDC_PHT{qlFpINGu}n&E>FwE75dy{pWLDD zE^YT@*5CoLGRN>p1_b@9efN<4^)Y%E>JW5{3x=J8-HU;w28zc%O zjkDjONz$gQGu>EJ@OawFR>9&{h%j`$gh~eple2{|lRb*gvN`B-Rs~kKJYjKG7u{u@ zVLd$ty>7gQ>KBMSAcDg6V$?9P|F%!>@!DM2l5i{egCh}zO zV3w<%n8Rb3>ne)^*&-|=W+`JWcTE(pONL=KH7md94oO2z6a^lW2_Ep#K^0$b)&l&>w{rlL}2hUtbp`N*3(XWBF&(wXP z|2O9NE~|qd)1e?$>Mo?+l7$Spq|^)wGvuINdKnrsG(_tegP`qZiZ-QjXzSJ=vb=wH zASRgo)0MVv^f8~|2}`#mShdK6jhj7sa^k*^TQD5y1KpErDu^m z$`SKg)L~JJV_3rWGV;~Ty=I0gHZn(H>0Ioj{s8l~U3V5oi9POCj1w(NaFVr_5@T3x zD6a4`a(l*4RFrz6lCkf*DdUk_M?7}xiJ}ps#5kKhFs(L`d&}AziTTVLzPN>puj~Wq zva^tp`xCNdap?TB7K(CpP;$42N|`5G&(slGavsp3uEP5Q+LIf}8KI+GIgH)Ig=Mvq z=tSMjQAy}Bvjh(=jDqb<6JaMOL0`Gquy>ya2RR$z!gwCEd&*^qVR9oyFk?hg7b9mb zVrO*dn1ku`6gX)4@#eh;|2i9^hFc;;jrEi=P0xgs2&*;O?1d#a53b8>&6e5Rtf zjk@b)b+|EeBJMEuBjTURW#c8~x|ynCV0%ZrBmTYIQGB5OE9;ZZ`6+2Z zlJiL778VIw=KKj|$~rln(8i-42J%PIK4&b3O}+yokN4=9qXrXsZP6)56V^Fn&{Mt~ zw$%4J_Yig-_V|Ns2aiDrUpEuZIsM^tt{DBe&@q5H2Ig!+tGXnpD0LOFIVTY(uP@@N z9WmG1L5$6bLH4;^O!W99nM`>Kc_RB@<~eWV$fv_!#|yLMOOP)ghIzCvBc*b@v`YSy zWc9fjxSW3tY3trdHnZMB=G#TwUXLQ|C+=vDq4<;h1nW6TUdEW`&Mm~n96wxPp4+4f zQYH2GNIPbp5ahEtLh zaXL2%XLCJqfw9-G3&WLiIb1If!p-t6xW#&Ivxa+~Cvczsn>ezMU zbIBbj+&+)OlZB|yt-%Mz{lY0E6v1LYwV&d8#n*%7dX-7+M5vf~i6rI^{isg_pOmB=1G~L*cumFUO7Q2zKgJkHT_6`3LlqnmPJfjp_J}*Lg{=eiu#o+nNPKD@#~A$b8lm8YY_B`Wqt7g_ zkCJ?^_gKKX&Tt%Fm1ineQ(jMfVP2rvn&*yfd8^STNDq6w`l6Wjc0olrM&I*1wV>ZowF{=u zBrHRN{eu(q#3wu7_C6Fg7ZbcH~Wn6HD>7;hZoRx%8ifzPb#8%|0v2ahddEWeUg$bQZ9an zx>Fo9rg&iT#X?M--51klH%M|Wp2w`&_c52T=h1iJY$>sfeEIA%a16VMHIz$dTVnI< z#n{FeyV>4HpZz{TD5l)baDXT@3Kz#O3UQKgOO-Uy{**s1%sz>W7vpis#~qjHe|7do zT)*guhs-mx`W>#<^~Edd-_YKu)LDFHtZx^iU?$~*or{x%!lh3V#g+-8Wy?~un)6no zLb^jAHFEWS4H8Y-&H0?uhJ3n~7YzD^!1&U6nDkSERm-D%4%5MdqVqrN5UKzjA$8yO!|zzlp)6U zOTwgn$1#;TrZLvcOJO2sj)$1Vc0tPk%%{%zl&4tSay6Dvw_;8mR*|or(;(S+X(cva zl0_lgTZr3ssSkEA_io1Bcj*N7GjJH;DM`kCPc`>d{CU%V#f^PGHqV~jvPH%j^Tg>;oC|KU4H>>ea&D*GV%Q+=|p>%R>RPh+=7_y)Y;J2 zmb@3qj<(+9eP~li)`g4j5xDx6z>RpN`cCj_6)7Sa)AzCv{aeLg0BwWlKQ!N3#QEmH zr1&Ee$dfMLK=S2Mq);AlIYVURM`NTfpZ_ja~Lx(-xUk;6S0J}l=c<$y?x6Ys~Bsoue#Xi+exIaFUB6@~% zth^tKpL+?l{-w~E>w?zGjS~I-YUnulqr~8fo-pdqYnpAnzKQ5Ow+vRv8Nz&Sim+n5 z9;9CV^n&g z2v9zPL9Au)70zYQH=LMQV&muXzN+jmQW-P7e?CSMKT6q3OkuuU#>ne`1hbVnUSM4X zbN65Yb&L8JVV!abcD#}jn;B<|a=O^wKL|VMyKAn8*u(aI)_QPmClpb4m{d&MF~&ck z9Eg&+CvbLdgeX-u7U!AgE_Ic}K2Uy$hr~Woo`WakPf5>6HKgatig-)=`zvSgv44R0 zMENuIUrFCc-`P(;m|Nk1ltW)7T_jL8plsxq z4`V;hd$Rw{RgS@eZA+C#Nq3Sp$>!=A^eX6tKdzR-fpMJ*)P+ky6x^?dz=L*Ak{8>4 zq=5x;BB0<10*N0)zo4t;7^*uI%~@yF0()rW0@zLG@1FQ(SN#%g~%ap4r9;tn}-F&EcV-rC5*qeU^Yr4 z8+iX3i>(Dk*iHL>+7D4a%;P^&P=*uKoi4~nSwSkUv3=LCgLuf;)dhj#5iw6$d)?I- zyjD>YZ`poFeB)Jj@q@CA>QS_~<}O-Yi-8JBbwB`G510o{%Gv`?K!>v4yfPRN)1KVu z+H;ty4nimDyHRH`KuY9v1*`@{y%OV8#m>poj2lwHQ8N0QwAeM&i6;{GnX|MVVn@#I-_^o*I30Eu^HkNu0#$#pjQLg&zw+7{tX4I}ddA$uSlcLXS9QZ4 z#@VYHhy(Ky#6i`kI6~cV$|uRs49FCv#Fr88bH@`G2l$Ii#N1?Uqc~1^IPX6E?##kd z+6UPBi0|tydH)Z^N9J3&?h1aW?gp+03E6=j5FKP7Pg$ZCBNPWtg(`JA0|SMw+C%KF zpMkd5RbW8bh-7+QM|2tZ9_H5zVKvYOz12pd&vggbUoVA|+HNRrP!ul2xpK_ut`-R2 zfdc(0`(3|)0cxFu|9nq`US9^;u}Mh0u7*(quOfkcI8!YjIRpL0Y~l+@^RL%q5pyi2 zyllRYSgF{Uy{LB=k+egj7t^EmlQ<~gOND@sY{ z)bwzXajvu8oAZ0&K5dT}|FK#bUJe|LS85Z{K>J%_KV1KT&jZKf8)c|>fvkTSTBuLN zZO$R7sXs*P1;x<5VG7*^2GCcJLz@NBn9k2_Wqlcp{r!b0ZJpG&!i@Yf=Lc;TOoko( z`mpVwt}C1uOobcU9_lslBKNt`A9J+5FwkEW{tFB-)PEC(kq1*BdSf*r7I-4^hKYz$ zUxjG(!J^NG3rJX?CXyI$gnA6p$;T2inKacOBF54aGl-w5u7$ceVaQ`m3;hRUDRC>* zqp*6x2^8Ka#I^+sA^!Xmd#K;bIQz)=)BgGG1RPVZ!YQ^(NtbWb<1hc^@a?b~pLgn_ zlE;7F-<)%5A)H_J#Pb_5ctO9HR2Ly;70o4fI5GQ(Z{Ax#i?|=d5tMLpD z3+v##&=YQdsfqxOUHVb(Px7OFkVX}T(KncRiU+GBTq6mQ0sbQ9uVTb$Xo+|Y4WY*I zNjh~)IPN>XG(*Hsjm8*_YK~#dkiAd^d@lTG|i%?13J<|P!KO_&RzdAS!PZ`hTl`-l9-s8=}8oZ^w z<<4Au&~O*7!;1_ehlyT+0kC7cPoTfBzv%~uKxb6zRltQf zH|o5|eFHV%M{etDkNn}o#1P6uNx?UZ5q`51*XTMSx^;k(#kIq;H$z1!c?^5G&d_<#ErjfffyLr}!fH@8 zMwk6S56vU6z2%SIns)euWWQJ+4)k$cYzQaX+-UP4HjLAt%pL8 zk5JUg=U6=lt!}&G0oRjS-!_rcUScbBgG`|xl#ez`iqVc_z_w9PUl=br0?Q*|qH|C- zx&~c@#S$&s9vtu6Xz7YxjAci;PmnY6IIiwX?!06bZ0?%KdGbDhPV3-D|A9ej2+)ea z;GpXWW!^A8(--Xej!5Ph&KS{*8%uo3?M#uTWh~MeCqqkBjOLumSk^Z&XrcV1re}=X z-BCL=4bxd)F7b0n`L~NPpSF+PCSysEwOGMetCj?dhN)bCW1KDY*}+=(EV+)ooR>Lp zI|80VCZU*h99!}Pe-dB9x=t}hc~C4aYT1d)^t+;U1y{9$=s6^9%9ZABRI5v0gFDj3dtSkxVfxZP1!BoLphosSgqF@sH!HFy=q z(|;m$lkQ}SX?Hqc`cgy8Y^uRPSDbpKgZw)=n78x;<}dv!S+uk-meTJ`iV;@vSk~T= z7MqriMIq%K%(Lqb(B{lX9MIN7(b9q95Ou|*qoiYlmBe}9QXC&_B4@z$wo}?qaEABo zb9d6kCDw3RTOzIyclFM9T<3S;-2x@{YmR1NFgS5nK7R8nL3?v1}T#?hViq8gu#Ae zEXFZb4(nXfD+#mjs)~hoJ+bWWFtMDtRXRFiwN3!m-nA6#mIaFScSFRcWx--I@rAUz zbFOHIjxJU)=N=scabVd699$NSL(2lhVa7d1+n>ahP%foy9c|^becTlwF6p!qmubIx z_bzTS&uyIw++|-pV2-LGoWoh>ikfB5@R~kvhJ44nyJ`5)^W3D*F-kar_lE{{fcavNP; zNcgrp`4Jn|*uTY^(6K10Fh%+2G;x&m99tfQ3+$Uq6#?SP z^4_?u>xx1AJU`&^KV*)_L#N?6<(Cy9qL%)zmrIKetf#ReNOVfQ3dPJMeA8VGIbQRq zEaQAdijd=&MxOJgiYo%dib`*&u88I{uqIj$(}Pwe$1QqXUnFn4VxTahk8x!*OlULH zGeVaYHIlBxn^y)13&!Y9oNRzL`c`_vk+KuXh5oLL?X@CJc1iQ^m@qv}5v%8ggcTVgaYbJw=?zEf3SE&-e8#X`j2UKutjbZC!1iR;FopJ+ zE51r{R%nS_=E@tk3I*izNeg%^OZA3}6)W_ylI?Xo&W*%xs>?(ILdg(NF{o!ahf%h5>wQ&3g@^EaDljs!$yiLtm!J{>y@>rAg+?_du%_@ zGZhcXt9VS+!yvx#T&ayci^3;~;uUob!_>u_6_)Tfk3&n&k$$c$!q>`E_^y{C0#h9X zR$hR(XAh~BUnSDPE<)y>iCmUV8RS;#3VD4~(UNUt$}0D2F}VK;v}RkAbUiIebfUg+ zel+HDJ=I))1}s-b!}gvQ?DUg`{mKC0d~c-i&|eKt;=M?RT=v6<+;^oi1~KnYa^){Q z5Jp`*NljM|+4l@N@6jlk%<;;Ml`E0Mx^iioO>92-TvCC)lvqmtl`A=qr{77e4L*eR zY;T}#qkbqhkr(Qxh%MyXsNbWnBKGR%VP9|$9HOo`SX~@t+!K^f-8+vn!Q98id}lw5 z5ErPsMEOeaGvxBSzrzXn9gM4!jBKMD31PstBmeT?UfUwdyO>e#*>CGd*v z*OcFpKClnIu9Vt;2ZS7gxbF>_RgIDsA*&#_>Z?TIzKNV7sb!l0p+dbXb?R(u zgmi}%b^5DpMH{x;t#X7Rd54f(bRzFevTTzFt5y6AgtUh(xm}xu=tI3d{T#?$*mh++ zH_Gnh9^{@OfuiS7Rnd>KZ<}uLyMG=7$^BVZV8}BJraqVyvZ_WB#&!Yc8Y5S|N9?Kw zN%k69%o_d-k=eyaXTDL4pA}LCd)~jsh16j@@l!(r#7x%c{KZl%WQ--GrKDw~<)l?@ zx`@@}Ye;JucYO%QNX)l|@;2&rQ{I1n4-T;Xt;)p}`dnQVg=^%0k$ibSx_dtom8$~9eex>W9y8|CHtwP?pI_^Vc^9IG#*o4I z+(twA>K?&&>VC3*>DAm{5?T$_)rX+AIushKRYhy=Dbph9hWd*R54^G0JPMuI?n<&C zwg;*A>P`4#bq}GpHAuLu?j(Fzd%w1-!nf@n^bbvfU+8MN0c`uX^}^t`p%~IOMFbNQ z#=V8%ImG-nyXN+LJ(GScprtJ}&;GFKn2T~|e z=3a@;mdFh)#%$u|kn&kiLFgUKqr7nSNU?}~acD1iaxF3~s|efr<}YuXj|;5*GTYZ4T*P(SZjf%# zZ!EtDdi~&i>OnawSIgod^E5heEqk>s_viH$&xm`mT1LDfZ+zg1udAiS_s|yjL0{3X z7A+ofyz`Ljh+JnR^KFl|V z-;Mrj4k3W@Aja*rDL@Pj8z$yb9~Q>v-gcuz1nti_-y9dlImUJ=B6-a!q%cMr@gvr( zL3-Fd7`KxXBiYV+xER@tJ+9q7%n8lKl(1f?HD7?4YZ5W5sRq|JSV-Jb%FB36{^YBO zU%Q5DM3f8H^u@L{SFrtIlGwFIPwXZyVm*h*OL@J#=Un|!VoW)ASVI3(5A|@G{%0wd zK6HT3rh(!@I}co16DTgTt}E1ErG7(&8SXI7U1BSk=RWBH?bTtqcoJqNQ_DWAW4oSx z{ff5t?8_gVpa05SKid5X7#xL^ftHXCzX*BGrzxzhkw~dLgsMS`P~*Pa*3@f;--8yp zHf_4$=|V3&4zEj|pe=n3xM#_@$`rw}$-+GR46GRYolB zaRz^KTyp`LYXij?+BG=WpT#<|i5bVdlc<}*XNYO!In>W5UrOI)^j#UQiB;t5SR5aB!`)ILsKu)E%W7?2D}M)dDUUt@Aht`(RP--&Y92;LK$bR;Xz2iTE2FpkqY zDKU$6cu@AD>|LFWe#H8+J&-ggVhMuQ#bPk!VA?~NFO)IEBTP}i{c=&v8B3oy@?_SU z7GWpSIqt}yJd*M_VyEyprqO?T!~o1>>^#b|iFe|9Nj~MJ(L=?2?sr(&UKfkj^$?3A zlChNgBbKcz#Y+0GkGO{o5%aK-K3k~Yx^9rzL3!u8EbON2!L=RFf(jgA>|@+lbb|ae z=}d%`Xk4BlO6gM`VaPofKe2w(H_2tjThC{ntK744opCD2E31czP18B|&++b)_MUj! zUKP)Xe@^*ZMJn4}#X#2Ez*q-3E^n;n{t))tkLnowWG*Q~Psl&wo(_vLC~*z7<)e8r z%8?hL{>UD!$+cBj6qwf#Q%J>n?8OeAtTmOkTZ8INDKpye4n0M)VdE3>*?Vx@i>A-q#9DEcZikQEcm}AWO z=OaIqL>l4rdak9cKZ}dhMw%vVG({ta*)QkSka*favc<**dZTEoYPd{yuEgZ8W?QIM5p25 zLY?AP2I2y(}yc^Tm_L&{mRENe0J$5 zR$83H_TfD-h4U}oe0Dg?_!k-TD(kpMj33ASPdOHQHarhC!@W^ATuL<3{_Sxre$f7N zxEExjywSoaO2|hogCy!AT5&!?*{BFAPq;1@^$e{k@4i}!w!|1kMWdsU42(D4K&L2v zZ$62I1?AAAePKgC+l{Hh{z(rwMR8vf<9a-S@Op9r-i+HXsviD~HONRxgt0w5$^}Wp zry1E|q>(4aZ~Q5lWMnEPGwu}TPULe`#RCV-HZsNBjfv3ap3Ku+LtIAR^-(@zbJS%N zZhVBTMjgZsVs;v7Vqa7h_S1fV@s4ba#qlS};?$EcQN~)%J&6|=H`>E6W|X+HaTl&f zx#AAncZsW{&po3aB8$(24>tyg>L=mi(Z+6gO8ran+9*{~&$=2I@7)tad|S3% zmf@>WhV3`f57y8kx(ad}GfAFqfx^>RD6u_d*idxk{#3P&{0?~<19Qsy9c|HOQyC1R zO<~G$Rp;nfblGH&9K8wX&M}1brk0}D(;l#k?kw{7oM#{X2D7rI;lZ|dbU)$qG+7MT z6pMgOY9escWdwJe13Tj*2%~R!M^6;+`LfOTEJSa*hS;Wgv1osh82t=M9fx29+nJke zBr}-Lk$YP6Sj#Nh3N{_Z64t(ypMf>RtczwpQ@4Tls7+6$MIreX(zd4%JIHs^zKeWM zbQFq6hw1lzk0(yh_w1%bly;m4pBd`nLiB80{sIeIBd3p zOH71tV=V6&KCdvJZ;S>8Zq`5mZG(*GVK9B8XWWO%fYpd(d-&!=#B5&5_3EjJW4!nn zLnN@BYHW?P%@>d!a~9dpq%gtQUrcBIJjR?C^9lR?Wk z9EI00(c*oKqi7`d8?i8{gj6A)g-q%oQ>Z0m3j;(8lU&G|WFd@ms(P`}LO<3BZ3-<# zyP7fRz;^MrI+)j#z_KP>Sl2kghW@rD>(Hxakmy6-KMECuHP^W{`26EeA1{-m@UHQL zFXPN9HN)(CcQME$8G{Q$5p814F@XbOYd#{rFcHbjpGux-B7+y4Evx9eg8fz)8-ty!WjEV$`%LUt6BF@`w(o`cz?QBMadD8}QVE4Ebx_=L2rc8df8n_URO5Uh zz0wj|TX>(^!u<`L6EWOk1!Iy)+(mTSQiHDK-PpE_^M=)yv*^C1LDGX{{k*&QgK-a* z#=*ff7S7M7!DWk@@F2$9)Jpi!$Dg=B(qPKNm@~>$QAD$?$~lzLDqD5%OBzhkFA*aqii2zAN@&g zFwPC9o+sfn{m#&Kmi!{=66?CoytnCdm+gCu^)Rj;Rg@pouZC1>Dvx^d*Uu}_K;QSz z4e)_Fqo914jXT7>!J9D2(i1XUtsoztC?xS*gWlR8X-R5DoeD{HYZh8>Jp(Q3v^$kU zFFpqCIwiq?`1bL|=ny{}#)(ivkhL$N&vN>_DOJN3 z>UM55!ER#r#J9xWt(&pGld?DvzXXT27NVFn9gVjZ$6x56d@J`*cDgKg?L`-Ho$U%z z<<`-7z}OGB4i!~wKcf7E{28h4#SOfVS4JaspSDWl3)?>^BOwYhW}cjv<1@g^9#DFz z12vKc_p)h{`*E$xi1rpHwlL;B#dOVtHnOEAvj3fVdg5Pe8%hmE^Lbymw8;5xId@^ z?}=l_4Z&R=Lj`sBwprtT!bI-JT!Tl9`}E~ln8@*chY@agWtM^u3Fi>Z=anx!&Tp*o zyIFgI+95)w)*SMki=mLX3>uvqb@mlz+jT_eT2Ij> zF&So4JdneA#8Aewt?dBk#8lx@n*_I7XLxq*D|`}1!+(3Q2(0xJPxl6+fah-bc3DJq zHbEcWdq>pji1f}wFe)(=*|iE{GV>PDcU`TtSf8ki&5X5*^R|0xJL16hH~7S3xZc?l z71USOzQZG8o+LiUi$rO>r2MXSEVg}10_r+Is*cb0{4N&hd~V#438gMxq80c3x89)# z%`SWfp-!LgShP*@;(IFGLzkosQ~GtwDL)8UmQLH{~i_|aC( zdDhUnj)$%BeyT$hH9kJpLZ4XEfsjFhH8s>aO{<@0`8W=}Y(T96<_3(+9FVugd zPN6IJZ|!u1(#~~gncPyeB3JEdFVuGG3-#o4Xw5wz+T8cozN;Gy$vcvFC7F{fx}Jj- z{cqcc3cHhvW zcckkpk-|75>z86QW7=~+*#z#j%h}22hkNE?Hht%GjY9s;^H{jEQ0^74r^UoCt2f39 z=3Gr$OYD03Y^vXbEtI#Bwo@O^>+1k{5%U~MzJx#P=i?;l^iF=J>W`v~`;mP1@tvTZ zY2r5H-AUFFl{>A)z4|4%&vsS4DXQ6i#C=?kNrfizsAIg>$=-P1bq_vJ*GT%fQx%`P ze!$Of0r<}L4`RT%Vd-7gLWXO;f^+B!Y`1(>4V4r*=)5wHj3f-4;FWWBACJYkM!Jf7=vt1%(nR&3+E)5Lx8 z;v4lpSgTAb$M3Nd(K6KkjpW_(J3#qAoB8_r7aT&yqAs?HXgmLDcs4YB%Y2?$n z7Bz$VnanvS^*H95TZnnPhhRQ!3#ngBzLb1}xgYRe0ozk|VejiX*k_)LBHG?_On7{^ zyC|VtO58b8IsHG@RN~TW4_x1^XuFa7qAJa0h2N^PxZV1R^|!)0?o%v7{q6+OkZOv? z-QV#smG?pOSo~ytQVoZ(QGPeE%t#Lfy26;Ub4TZ_hByPjkZp=3cyK9hQ(UC7ns<8av~xY*>l) ztY@>u8f+nc7w3rD$Y*0u8t3yFXyw!iM8J+r4$@MIQ%pr#CO)LLc`x z3Lx!6>^nJ-ap_4}Rf&<5y zQ}@osH0m8G=ZsJgvxu9+@5ubU7ch53j3}UOiKQwwSo&ep2ycY`D8?@8iuQWo_!|S9 zVf^)6Yr0N;bMG45;&(CGz3Ei0gm$+Po%%Z8Tyu`o8TPd zULaj0UD`KPTuxUFGOo%wMg3U+@Sw%2-*>6Na~Pb zhE622cX49oxmPY`yA`S zdwy^Bcnx{pSCtQNugd`|?8;dT?f0e7C&^Bbhrt0QbU085qaG>3_`q@O<$JlNlsmt# zk#r$-CFvO$V?WPlPwt9hU43U=_`y_0!&9SFysksYzOM+Nq?T|)Wv`=Me%8qXQe z>!s%j;%bjrbRWv^PsSRnz7qRl7``Lc5ufQliTx^duq$K_CJVWP z0pj+SEGT6rLphWCc&sO*wY4fV51!;Ra26_Z_}=Xgj;r~8uMvNfrR#?==tgdF@Hi|p zPoev9WmsF^fh~2t+0NtMZhK;!GCRWKU<=`$>C0=U3L*zTqt@dV)VZdY_u(++GM@8~6tUPkOe{G#9WJ4DSjjwVGL_H}rz=+Q zdfZG~;RhkMP``t*cJg;Xc2T$g;9#ugUhyN$U(B}Nbv2wksEt#^owe?Q^VD6;timhv3J-D(=gSg>=zo$lJIGrBTIb zMN)3egbLeQjU$A%O$~HLC1DS94=gB0N1Jvq8`Vm5F4Dt3e$K3I-tadXen@O>&Y>51 zE!XzlX!o?4fRonN2%x?dpXpWNhl%LMD3Ms?CX&fBMmb_6b7hUv5!sACj=tkZWS{o`)KqmrQKOwWLce3ob)51E z#y&-Cd(J_eYy6I@q?W^ z@wxvl_dvEiWQBHz`U#^$k;3>;0Zd2lL64q;g>}yc$%w>ru%&D_x-G2B`Mx%>9v@5L zIhwyy(Q^+TbuWYOM{mqo9f5)L5AJymAw9c@P-4RQ-skYqj)Io^KM zMI&h|_Z)m--QPc!L45isapiA{sE!#6wZm4>WLs;@73dt+L(c{ew6z@qF6*NO-zyl* zwU#b?cc<&&H83BOgdU$B!rC?rJr4)tvLmmNPc4Q2+-Nv(Z@-hR8=P%r;c~bZ5nIdP z&G&Emed+;U=1_M^6$5M^A%Jq2ts!iG>_QZMlE$>d$isa^<`_qeIc$sU!)X|I_&X-q z%7~xiM~WoAPoBd0qE)u~Sj{@qIH$6KaW;NEf@|fyv7vc?l-ckNG<}BYO)JK>1 z@A>-?HbQM|XQAH9Nn~*^spb(YnDZSDeew$Kv6x=I1(n=`()CC%x_!16mSerq=Z;do>VoIej09%FUkNqaw%FZYoR;a<*A@~|U)MFj1`NzvSkJx>yfxL&oA z`FvM@1l#HKJIb+R))84To^?(594;K+x5cbpx|qYggv&gqU@7A?aGbS?_Cm(l{dq3- zj;+DI&m(Y%wH+Co#NU-Ui?UuJ;-%Lh_;4TDwa;U5|63MrjlF=X&zIrHcRil=T7;Uh zT<>OF=TmNIWbU8z#g~zgwNr(BmLC+kZ%g@$p-|8AhK^k+biZ6iTkd@^$kIgzJ5^ys z*_iU)@(`G2?Lb$qb9XED5Fva&#Fl#dEJLAaUk!J=BzW5CqhD4C0_^zyIpx7$hGE#3 zGK6GtZiaDGxQ`-|KEr8?&Z*@g+^9e;LGkatn<4qJS*B z-pJ0nigC1!FP?&l#g8zVK2vC$$vC-ofnpYO&t`iLW1cRbhecUQSj?EI{O(!B<2ozx z!UpO#5>sdwhn+lzJzq?*kL^>%@%(Km8+79}UQWyf#=4oMgj=-T&1#U`|KfqC)IBS< z7cbeawQG+$9z#8It3){CUGZGJr~Xq`CcfGw;(OLzNM|=lWJp~e`g7kV_pD_naSn*@ zT$8lEwuJsy1sER9M91DG=-N98_sff5(fb4}dk2c{q+UmBBz7eG-oB!WpAXlgxo{`e zhwtY1>m4HI^ymV=>>>nFZ#PjFp}fHTSS>puMp7a%??1L~JMR zW{vxf{)I!#Q%ub9-owQQNg~cM?nSO+T*)3O?k_IJjcmThcXSBueAUHW)=|mzulv0d z@qj*0nB!TtAAeuML)7*zMcvW1sQ=2nn7woHj@YeD;|KP^XVOoeKRK?s%X1!m=g4_b z;oO?qxMFC03&k#uYqU8JuG5F>v*ZROBT}(f7)*~%<{bGPbnY`0U5MS!_l>OkSipv| z#H&_fd#oLL(Psb67!LGtV%z20G88R5fqv8tW}YE^Ld4Mj(cYH;HdUo><9{o ze#VU|pysA&Lls)Hv`uI>leDoalmZ3H(n4E6l*I+yP?Q;!L6K2#T*n3Xg;fx72RFtQ z1r-z*Tn6xymj5}qIXAcYZ_}g{M!!k)x#zs+UC(=#yEHef8piUD;kK#GrV+Svz zCl2n{P0q8iXCU+JkeBE=$UF~U0es(U)xqOw?W)t+x`TDJe$|Wg66g(h{<9IXkKefz zzs0df_ZIrJb;x*nXVx@&_uw9SAJ4!(LEES3&u0fcY$tro%6o;rJNONKkDL#i@Fe{L znag`@qC=~yXypF=x;CrpDZSo6orc~{UGP3vkNU~%L%eI%r+x|b!*%tEvqPkx{VbhY zKb!`v-c18nSJ9{78}NG&S+loNPkf&&2YQy(_mj1L1ld*_b%EJ`r@^?|3Y~y zWN#n(I4!Q9!2VXhjh4d4GUzQw`-=LtbRV8G6kpYa9vGTIPeA`^$UOu3Ur)-T)w8W^ z-Rf)T?vswEjkAZ)J%{?U{dGR}7V2*gT~1Hq8R;jh-=Qz?{OC*QSn>N%ztk7guS3_< zztQ&x5AC4?_21&T{gd<%_Pay%d#FvrHfopKm)ft{P3aBA)S+Q2=^FM>$J`6q*}d%4 zx#4!|mU|9eh-dG;8a}5-@%^>l;P+c|Kb?g0`o#~;pws6#sXye;Xc)owd_A*0gUTPegt>5^F$z9>Yj*3_ zXB|gD$X`6?D;lw8A-)HS?^e#KV`FpE*o1~6>TT{zHK<>jTR`I-_p3hUH-!08KDRB6!f%e9hx?Rvct@lH@?#-a zxpq8$pRj;NVNO?}{06bioLfqlgFoxgKHZ+Rr?Z#cL0WL=60+icWMN(f-8{D|{dMke z^5_0Qw?S^n03R)Z-W`y?6ZAdE#r-({F2&!L9)|C0aSpo+e{;F#!*qIeLk@cqZO(QX3!*Xa}?h(t&^O zt8McX@By%8e{Gw$fy+_vfU-NV4LB3{6!;9-0n7k)0keSXf!l$%fRlk|fOWtNz$#!h zFa`Fe0yRJ_PzOu{rUNs8OM#idWx!g<&q6r|m_VeZc*| z1Hgm8L%_qpqrhXpQR~dEiB06|fpu1FQws0qcR6fDOP#;ALPF@CvXQ zcoldJcpZ2HcoTRFcpKOPYz5u{-UZ$R-Uqe;9|9i%9|NBNp8}r&+kwx4FMu7uPT))6 zD_|F}8~6tJ7T5!P2Ye6w24`cvm00V%5 zz#!l(;B4R=zyL^q5y%8gKo*b5FufC~UWPz;m+A>cxw6u1bu7`Ox&4vYZGfRR8sFbWtAi~%ZuvA{TBJWvTt044&H zfXP4=Pz_80rUErU9WV`;4qOV%1TF(E2WA6vfVsdGz?HyNz}3J!U_NjSa4m2humHFb zxCvMY+zi|TECT)l{1vzrxD8kg{0+DRSPI+){2jO(xCdActN`u>{sG(v+z&heJP14l zJPbSnJPJGpJPxb`o&cT%o&uf*o&}x*o(En8)&m=Wjlj#mCg2rdGw>SlI`9VYCa@KF z4|pH=0QeX1A@C9KF|Zx@9QXp*3495B4Sc`ilOYVhgxwb4r9fJwE=tkNwPOwOmu}YMH~W9}ORe8)K|~8`b*dyu;~3 zBI6lrKbDS-uQlk{J_?&h!gp)gY|c(o{KHvK+@{*Dx-N2-Y#D2#sj-N)8><(~KU_MV z{dl~?^&3yWIloQun`)2et0laq=2kra@pvMJcyl6Fzo{66twc&;vo&l9e_FQU^-Ji* zD@B~~WD@1I)K*h^O|^@7wDQ4u&FKmK*fLSQMCD@bw+0<=yqn91mM+(6sy|J&C({oR z)8W{Pjk`HpP4Pv$D0x5B^+fuWth|=Zcs4jsK8VtM^Btd91PVHkX^$j$O;2R$Ehkxom77xU5!NQ#Q2P)%xnX zmTbJXWOb93kLO#>i?yrXgJOAVJ#{^qaZ&4O)z$t5KhZdZyp|2Y(<-_Ak@lhGx3$_@ zlK(_=#N`r|jn^NMUr`EK9(%m_W95b3;g&76tDY-bd12Itu-L*iIV$_=U2^B*M65zq-Ap{cVY!+OIkuEn8~YmhiQ7TGAG~ zuGBWveP}LTwO+FI=4>~|*YejA9W6V5)VBZY{cFv^AYc9l-=P_}=@y52fxV8Ar`Ha;`R-Wr?>1egZ`Vw?9vWe&iaqD`w5a>AaL3~!6&$I?ydwRXFRSCsMWHzjklVo%ghqH^*2+EQM; zJ)pJYQri=CQMNSxqp24!S3HiU=9`F7i{D)To8t@H@ygb)5zoHh9W6h?U%c{Y#BwBj z90{B1Jn=ag&qs4}Ty3j0>POpOYs4JS2Jes7I*+H*TD(}l@y5Bed^TmLwZ=8JPr_ep zyXdPZh1}tmYJ08KCmvI5{36c7@u7}Y*lUe4Hr6BMCtj>A_1TuMXKF8HDp z?eWTZ`%$8H)N<;2Jime$D<4ZYCCA&fVi)>aJYg%DlG{txrq*2G@g!=8%cOKJ|J=75+3UWeV^rppP8^}z{-7~}0k!@|dC*|rz|;prYH zpA^2fA<|Rt4%B-tq}p}hoHlLRgcZAY=T{8HyJhu;h?Qec2&=ViM~9mDbT)8NM(wEs z{m;g8+v&i4eIUQb!TW^v_H=aHPps9jjgV{zwmF|Kt!Ahd$xD{J-m zzg%BcQD?Ik=*Lt}uBfW5tgh0JnpUT;s;-N&rkB@LmXDfLakf74F`Hm%O`F~4Yv-vO zxcno^Wb#Dx%h$5@XL3OzPi_Bvd6KfwhvNKhW3}_tDbhnxCX=T&)Gm^zA7b*9_9x7f zggzK2Zk(%~r^_Ne6lF4bYD<&%$m)Oobtf5(=*qH&W3G_%gpH}u{v_6$C=<<7hhun# z+A^^X4UrRe#8w{P4~dR@S9Vhs@g}!Q-^%2sNGpYVD2UiHYuie`v9Jl@ii_xpdD*dD#LN2;Mu$il>0{(HO!$W#6Z$}n-#mst@_A8@^W*yw zYmC+}>eSsDbl7n!g&g0d$DFY);=7mPW$BD9p|DhYF2&a#q_)Xcqf#Htd1_NZ0Jg{! zIRy*XqLelGa}pn2N_vp8ApYs3@aI&yAW>H7Z&+vzx(cXWNkeWMx)IU_DmimuKROmB zB|3G&LnqT@D4j_E?*73Uv&1UdlF6k`Bpb|NA(11fATC3-2k;ysh9tXu`~#+r_iAH@+#@7u!UW7`&7}fVQ<;l zLu-idRL9e{lLpSCPavzOMe|>~i6*0Z5^bOQ+biUPz{&Juhjm+MOxW?{XFKnqN5ZYY zoqEq+dJEP6AxZygWEO!;ePS{Y9{}ei=411}AjUKJMH?h)irv~n4vUQj;W}ss~lTdF-AXaN^MYsblO6&IB#+p-l0ID@Dp zveSqQkvPdYpUcNf4!3L)q|!s=rB)uA6)_hkr0gu*hx|Eh@z{UKx#-21 zW-i3uC2}F?$imX+VHo-6d@^;yzn6$DR`$Mim+WDlTu@qgI?1xUX<4Dj(r*W4ktu!U zGJ!0O;ga#P#4qDTmV6a8wUxDX6;-1v^rNdQ#*VEVU5QyztDiBxa`bq8c}<1BwxUj7 zSFM-MHiYL?IGMGTbrrR~!V|92o-5*pOw5f~I?=fzXKVd8a^J_vMIy^+Bo}44=<1GZ z%jkm;mopF~;;H1PirxUvxp<5tPKcu9IT{%m6h5+QI((W^&VodN2~TX3bI~zoGZB3k zW!n~RCi}ld2>2winS@=&n+bl{6EmT;HWQ02U)fF0d&{yT{tOW-Mr23OO|PJK-Fe7- zXHl=0rdLpHKYpxc4sij^m;cG3`YI*my#b!Ad9b#6C=({Lex>~yZ z!26WcYPpol$6GDFFrP~iwa#ks7ub}wa@w}pgOvFZez+m_C6NnJCZ7{=HmN*Lo@%i- z|8dT_ywgd~jmU%!&jDFKx|8yI5qX7O{tM?3g|B&dC2}P|(^5B#I#V)M194dxG?#28+_UluqclH|@9A^uoDxpQ5-5#o1(%gTP*9PtV& z`Ur54?3_Ap=6|~2Uh8m%_2(Dl`|~}v{4)6rdmK)o{0uv$ysjLV4-uWF3vnh^{?-r? zjqdQ;y6Q`EE+JNoID?B)_o=KedR_E+W4iC+ilA0+#RJdI&+#Whf7ITJUWu~)ehvqvx7qGi=iI56lRYSMt=RdJ=4Pr1 zro;%UugUn8)uigt<#qfI*Q%!>)zj+6PO6^4?_?`Rm)F)^KmO1n5zXP0T4UHNV(`y( z_6U6;hb^)inDW}0>M@$uU*?Ew$ktyMJa2z3SnyZwwexN~OTq~MF|RYkMVcr@?!-(Q zy+hRGa>mZa^wnQBru)t6wz|M!x6&=|MHo20UjFdRWh{+v^!)Qb(`w5{SCmbOKDQ}T zKerJpjHU520snNW89Ta+Ki(^=93$dmY2w*>M#p>`qk=jX>h^>0;SX}hQ_AMMt>db2;tlDvGMS0z{8a`e{ zktNE~#9B>{jAU)(vW%sP>$9#k6}1&L)2l0M%IaoLsdzPVCBxFhB~3^ET(8XLbvx~S z-jsu6X<}Y?pH@4rR!pL@NflM+N6!2V4|e5G*Q#lgM^)5d@XIEZkE@K{OyoEX+_YSoGBJ(ec^Ue%>hf5dr_rFD(ii|`}i zsLzw(U2kG@=RF(jh*5W!Us^eN+GM>v0{oHwnDUvm{F!YeUOmo%{7(UsaKh71FP}86 zf(!9eq*&X#yVl7UsLPsj%pX4r$KLQl*YlOHudLFKubx&@tNh(za`l*sNj!+!it-vf zN`|W$%6oUm^rJI7IrA3rS&7|g<)kh0vO{gqsvOmXv>9V^xaKm^y#OgsQZ^= zX~D4lx)n1fQGVuSwD6AKb)BA=Pcy%rPji01iAwq}q7APuqITO>(6k-*)7PJ6q@Qrx z-55)kLj0BGSV9seoLF@?bUtqaYlOXdl_tcHzRu` zXE=NF>yhl`o6Fhjka5kKz`lQM0xR1xfpxrSBD?>~iOkt;66?KhDtn+?4g1Pa!>k3h z>@~<5FQ}j!Y+f>Co25*H!4Me?gIO|~Op-!M22*BMl$&WZ++#jim! znR3)*RyKN}n37CpLr!*-G)Stb44FpbV01(H<)qpXvSZ4O>Smfv*+xSo9|j3zj!6=_ zQs!V|=3vDXCsnBfsm?P52Y!2SJdMA(QuBkZ_b^ z$Q-PYQr2Jz1FmE;D@V$X&N`!%m6e@kjAYi3Wiob+6PkmKx!XI?E}g01N`eZDWr0cnggjh@ZT^8`1c7@ zNaY|k2U2t3zhMqo9CnMz?###G0@Mm!E{n-pWcM0 z7QfYN4EezblzKtBf?i{RHvqYy2elyNJbt&=m|tArH3sw1779Sv>JC~=9=FwE^6@rz z0eloXVan?TwMv zd>crsv#>}S=0`2a4>k|Te7nC$a=WZWQlZUm$#j*vEt&p6i6t}O23caaS~4A8za`Te zvRE>0R=daODhgOKeKxPh=q>?SSX^8z75GbRMwbrmvB@*G4A@|3b)F&}Q?N+9ZnyHFp4}T%JN3@&Yv<23@lHARP4iJQzHXHb;p~D)JP-lml`$ zH|%+waOAS)+oVtcR$La4`CKhfh&HDO8djIpCVBnfI$UV86~K|liZ(lsC1^poRvY93 zK}7Ehpe^J;%$N%>fILf>yDs=Bc1a;ip$lnpxuAjR?ZR)YO2t;c1za3#HXH(eyF0tk z?{R16dr-3%Vg-0CIAD;m7W{sT$>J|^XJbAGG03(cl4uVi?e;>+;|&%{1zwNGY;#yV zX8b~2PznVLgHnOd5rp5Opkyxw>G20}DBwl|g%*>|<#(GyKA+n>%vMxlwAvg#$sY1} zvTYt50>KO2W*XLxX5#nPb%bO$nGydCJPItV5!R@x%~wg9+%Z3 zh4PVNo5LQE9DZJNyKyLS;Slr}N=5np5~HWs?lF5DK94!%D)Jz8!4hM@>kb+NZX33Y zLRS#$4VxBL6i82D&=|C$ZCJnuhCLKC+ATO(ToxQ`!Jsh|EDd7oLoHx|u+?J?8qr{xDOYsxLnwuT|8z- zU>N#lMGey%2N(BS0J*xHucY;eZURC?@M(wY?6*TbkI@G$hlN_*YCQ&L*_By-D~I4x&>RQde>G; z+j9;rLfg1;9qH22bb4_Lb^Pp<_H;$oCG@av26?8=Ajj(mbZ?to%!BfL;3+zvz3@$E zGA!;rc=W^V=$}8gqfb`9LuYI^u=&;JGwBN}>z8I>2b~T^l`gh?jEl8jl*g9*#l?25 zJD~geg*>(_kjFNb8(ELD^4PYbeD+4~bJ+vdMb$Q-Hef|3<$rYs>E0)0X|XT%w=ul&Bu%x$XWzAN?yM{l#&^=+Nk4^!6R+(Js_W zt})QYsRr_l?M0sAUX*S7f--e}RKe&YMeRC<@`|}d=t=X+R1Rn)wEurZ{d$WuVec0#E8YutDOX-G%`Sjx; zJ1rWY&2sayS^vUp_G(6FR`En<_GGWljP{hWXSeL6TkuW(dgp9<3E%!7cd!ea49o>a z134?5?3-n2%!R)1uk*2i?XIH{->jhF_oT7DK)~CMJ|CCHu67QgTJu-5<;=Izo!N7! z!@4=N^|zVy%buB(o^cs{_3cbD*q@`F2QQ4fE_b)Ap3IR0QUW%eY!1Q9K$xQ z-={mU(#y7#T*SVdxSRI8c0e~^^=_JZ_OH63eFw4O=0WVP69=&iKu_BFv(ATd$63GX zeg}2}^}seD2kobRl#%`|^w%A%qlvKlE@E2;{PxK4^vw1QI?r=JclmQuh#okL-V5A8 znV`2h4(JYkR86N~u0GyZ&*qQrMBeWPQ}vSmbX*TRxuE~zb*Hdl6P~0~9v(yU@K(k5 z%R8|_@U?QzaQfj!iT1R;n0GUk#_yOOV@9lmvz1AXWhO1CbM@RnZib%G@ad% zKash=N)cyyT;* z>wPq8fseZ1;G_0E=h7{EZ1neQdeC{_^rTOr(-7)OFI?D@29@=sQ()(Fv|aP^arEHJ z0Xq4m09B<2smBFDYJYQ(27eHsYS``kQGnit?DD=r8Z$71R`w{SGeHjohVLz=^oC;k zrM{RR_J-(5SBQGI2~o-4LiFa9A$sT45Ph&MM2lc&MtvW;DDV$jfN{I@Vgseu8z>X? zXAwi6`X%&JX+7z%W?lsS$!R8bD(3Sole*FESMDYY-l+Ks^XmCWf7Z>0&i$KirnLw5 z>*jvehTg{fsUL7M8@Tc!T6xSA`VQlA&aFB&d%!8|)Kco$7Inwd?U{Y!FT|izUT^_h zx^*L+Gjb#Sde-B3GatD%Z=fCbo=x5H_R#zb_v?x(+{|#hn=Jq@9rO=~$$#S6G+w`& zP6wTK*FIe--Zm;5@Uhv4@@?=9o?L1Jbm_WJw_|PrJ#u>mecEfEuG7^{IuZLsTCS5m zJbO5uw``ZLZNX%=X3+%p6mZq-2`p`0CHord^$fh#v~%uMw)x9Swis^!JzYP6jaV_B z-L|fdZC_i*B+T7&pBlmL2G*Zl!{)>H)R7TCYtw~{_Ob|_tf{A^AiO5Ll{X+GYX zD!!@R3*LqUVrw^n0$I`_7LiVTur&>C*3tmms0wMJ88=LzAO_tCLj%H z3%K6(Qbk4<-DTNBU3M%=`|R@!*8YnOcFYam(u-I_-(g)`hmxJNhw^}j-W);$%8qAk zpSh3h3-;;;0{t-m7Od;eii3E^AXB_gLpBS@Y_t3qBLZnK7)|1JgfQ1=%8qg&Y#Q8% z9ISAI7ve<*<^2+}`0)Zwrg&w9+}=zu#S0~2E?!O&rix1OW{W|I3S<^ubP-%nDPD}o zQcT&r2E31<2!oW2gB7wUz{7}I=A@J(OvzluluRm7$)sY+lh6GsVaQzZG75#c(QJgt z>_*%yNy$|RT`=Y-eq~azER#ywIf-|bM9eZ*=|aGcsB)B;Wm54Q)>U38A$JhH&s4I( z$*gR}RG2g?Bj~Y1*rY_oE#o~I5k{CBO}lJL2{KG(HMXq0^b-yv%dD8bGO3Ip z&jwy)63OvZ*VH+t)l^r>4K|)N2VHNVcr#hWO54RxF3f=xmosWdetF!~YII z*fJk(qp^`LUd9qJ2R;1VIK?l>OmkE>Oh!jPyiq9crIAc3*^svp#j;E)T?ms#g)Fg1 z{2ec$EOQ&{8kJmyO8A;nrdg=OFgPa~Gf0D3u|y#8`k&GxkU2R~ZrG9XzN6fQ=;j74 z=7I={oXCc1=E$UCStc6`N7s=Tvo0svUzt=o$Vt^68zv1(e`T&h${kcvCv%nImPsWl z*;HdvQr3dZjWN|Ys_02X7FIeKCZmHQcVAgJzQ$A3;=*QTRQ$@M5;H$rW#=e<`AG!t z@QOJpm&yMHIi<%lkjh(X9;D_$Y8|BZfz&>b+6PkmKx!XI?E|TOAhi#q_JPzsklF`Q z`#@?RNbLiueIT_Dr1pW-K9Jf6Qu{z^A4u&3seK@|52W^i)IN~f2U7b$Y9C1L1F3x= VwGX8Bfz&>b+6Pkmz>(hv{vY%?(y9Oe literal 0 HcmV?d00001 diff --git a/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F b/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F index 85b0f1ce6..934e49116 100644 --- a/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F +++ b/trunk/NDHMS/Routing/Reservoirs/reservoir_tests.F @@ -1335,6 +1335,85 @@ function test_rfc_forecasts_over_max_water_elevation() result(rv) end function test_rfc_forecasts_over_max_water_elevation + ! This tests an RFC Forecast Reservoirs functionality to offset 12 hours in the future + ! and look back up to 24 hours to find a time series file and output the appropriate + ! discharge in the array that matches up with model time as would be done in a long range + ! analysis and assimilation run. + function test_rfc_forecasts_with_offset_for_long_range_AnA() result(rv) + implicit none + logical rv, rv1, rv2 ! test result + type (rfc_forecasts) :: rfc_forecasts_reservoir_data + real :: outflow, inflow + real :: water_elevation + real :: prev_time_inflow + real :: lake_area, weir_elevation, weir_coefficient + real :: weir_length, dam_length, orifice_elevation, orifice_coefficient + real :: orifice_area, max_depth, initial_fractional_depth + integer :: lake_number, reservoir_type + integer :: timestep_count + character*256 :: cwd_full + integer :: dynamic_reservoir_type + real :: assimilated_value + character(len=256) :: assimilated_source_file + + prev_time_inflow = 0.0 + timestep_count = 0 + water_elevation = 0.0 + rv = .false. + + lake_area = 2.096320037841796875e+02 + weir_elevation = 1.332074047851562455e+03 + weir_coefficient = 4.000000000000000222e-01 + weir_length = 1.000000000000000000e+01 + dam_length = 10.0 + orifice_elevation = 1.314473347981770758e+03 + orifice_coefficient = 1.000000000000000056e-01 + orifice_area = 1.0 + max_depth = 1.335180053710937500e+03 + initial_fractional_depth = 8.999999761581420898e-01 + lake_number = 17609317 + reservoir_type = 4 + + cwd_full = "../../../../tests/local/reservoir_testing_files/" + + call rfc_forecasts_reservoir_data%init(water_elevation, lake_area, weir_elevation, weir_coefficient, & + weir_length, dam_length, orifice_elevation, orifice_coefficient, orifice_area, max_depth, 0.9, lake_number, reservoir_type, & + "../../../../tests/local/reservoir_testing_files/reservoir_index_Long_Range_AnA.nc", & + "2019-12-18_19:00:00", cwd_full, 24) + + water_elevation = 1331.18005 + + do timestep_count = 1, 19 + + inflow = inflow_array(timestep_count) + call rfc_forecasts_reservoir_data%run(inflow, & + inflow, 0.0, water_elevation, outflow, 3600.0, dynamic_reservoir_type, & + assimilated_value, assimilated_source_file) + + prev_time_inflow = inflow + + print *, outflow + end do + + print *, 'dynamic_reservoir_type: ', dynamic_reservoir_type + + if (outflow .ge. 7.8 - epsilon(7.8) .and. outflow .le. 7.8 + epsilon(7.8) & + .and. dynamic_reservoir_type == 4 .and. assimilated_value .ge. 7.8 - epsilon(7.8) & + .and. assimilated_value .le. 7.8 + epsilon(7.8) .and. & + assimilated_source_file == "2019-12-19_05.60min.CCHC1.RFCTimeSeries.ncdf") then + rv = .true. + print *, "========================================================================" + print *, 'RFC Forecasts Time Series Output For Long Range AnA Test Passed' + print *, "========================================================================" + else + print *, "========================================================================" + print *, 'RFC Forecasts Time Series Output For Long Range AnA Test Failed' + print *, 'Outflow should be 7.8' + print *, 'dynamic_reservoir_type needs to be 4 for RFC forecast output' + print *, "========================================================================" + + end if + end function test_rfc_forecasts_with_offset_for_long_range_AnA end program From 0c61d322c11bb3e8c3860cc590bbbf5deba677b5 Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Thu, 18 Nov 2021 10:10:51 -0700 Subject: [PATCH 19/25] Fix bug in forcing LAI read dims. Minor updates to VEGFRA for consistency, but these have not been tested. --- trunk/NDHMS/Routing/module_lsm_forcing.F | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/trunk/NDHMS/Routing/module_lsm_forcing.F b/trunk/NDHMS/Routing/module_lsm_forcing.F index 5f2596dc5..67c77a72b 100644 --- a/trunk/NDHMS/Routing/module_lsm_forcing.F +++ b/trunk/NDHMS/Routing/module_lsm_forcing.F @@ -79,7 +79,7 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) call get_2d_netcdf_ruc("VEGFRA", ncid, fpar, ix, jx,tlevel, .true., ierr) if(ierr == 0) then - if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100. + if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar*0.01 endif call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) @@ -2793,7 +2793,7 @@ subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,f endif call mpp_land_bcast_int1(ierr) if(ierr == 0) call decompose_data_real (buf2,fpar) - if(my_id .eq. io_id ) call get_2d_netcdf("LAI", ncid, buf2, units, ix, jx, .FALSE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf("LAI", ncid, buf2, units, global_nx, global_ny, .FALSE., ierr) call mpp_land_bcast_int1(ierr) if(ierr == 0) call decompose_data_real (buf2,lai) @@ -2882,8 +2882,10 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) call mpp_land_bcast_int1(ierr) if(ierr == 0) call decompose_data_real (buf2,lai) if(my_id .eq. io_id) then - call get_2d_netcdf_ruc("VEGFRA", ncid, fpar, ix, jx,tlevel, .true., ierr) - if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100. + call get_2d_netcdf_ruc("VEGFRA", ncid, buf2, global_nx, global_ny, tlevel, .true., ierr) + if(ierr == 0) then + if(maxval(buf2) .gt. 10 .and. maxval(buf2) .lt. 10000) buf2 = buf2 * 1.E-2 + endif endif call mpp_land_bcast_int1(ierr) if(ierr == 0) call decompose_data_real (buf2,fpar) @@ -2907,7 +2909,7 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) call get_2d_netcdf_ruc("VEGFRA", ncid, fpar, ix, jx,tlevel, .false., ierr) if(ierr == 0) then - if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100. + if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar * 0.01 endif call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .false., ierr) From 5cfc4d2f3f97ad4c5fe33e3620aa531fb8e0ea51 Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Wed, 4 May 2022 16:39:43 -0600 Subject: [PATCH 20/25] Move overland roughness assignment out of time cycling disaggregation routine (#553) * Add RT disaggregation to read2dlsm() * Added rt=.logical. to read2dlsm to call Aubrey's regrid_lowres_to_highres while LSM data are all on rank 0. Useful for OV_ROUGH2D and possibly others in the future. Co-authored-by: Ryan Cabell Co-authored-by: Soren Rasmussen --- .travis.yml.prev | 20 ------ trunk/NDHMS/Routing/Noah_distr_routing.F | 33 ++-------- trunk/NDHMS/Routing/module_HYDRO_io.F | 82 +++++++++++++++++++++--- trunk/NDHMS/Routing/module_RT.F | 4 +- 4 files changed, 79 insertions(+), 60 deletions(-) delete mode 100644 .travis.yml.prev diff --git a/.travis.yml.prev b/.travis.yml.prev deleted file mode 100644 index 0684ac00e..000000000 --- a/.travis.yml.prev +++ /dev/null @@ -1,20 +0,0 @@ -sudo: required -language: bash -services: - - docker - -before_install: - #Setup test directory on travis - - TEST_DIR_TRAVIS=$HOME/test_dir - - sudo mkdir $TEST_DIR_TRAVIS - - sudo chmod -R 777 $TEST_DIR_TRAVIS - - cp -r $TRAVIS_BUILD_DIR $TEST_DIR_TRAVIS/candidate - - git clone https://github.com/NCAR/wrf_hydro_nwm_public.git $TEST_DIR_TRAVIS/reference - - cd $TEST_DIR_TRAVIS/reference - - git checkout $TRAVIS_BRANCH - - sudo chmod -R 777 $TEST_DIR_TRAVIS - #Get docker images - - docker pull wrfhydro/dev:modeltesting - -script: - - docker run -e TRAVIS=1 -t -v $TEST_DIR_TRAVIS/candidate:/home/docker/candidate -v $TEST_DIR_TRAVIS/reference:/home/docker/reference wrfhydro/dev:modeltesting --config nwm_ana nwm_long_range gridded reach --domain_tag dev \ No newline at end of file diff --git a/trunk/NDHMS/Routing/Noah_distr_routing.F b/trunk/NDHMS/Routing/Noah_distr_routing.F index 04bec13b5..df0f04936 100644 --- a/trunk/NDHMS/Routing/Noah_distr_routing.F +++ b/trunk/NDHMS/Routing/Noah_distr_routing.F @@ -889,7 +889,7 @@ subroutine disaggregateDomain_drv(did) RT_DOMAIN(did)%NEXP, & rt_domain(did)%overland%properties%distance_to_neighbor, & RT_DOMAIN(did)%INFXSWGT, & - RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, & + RT_DOMAIN(did)%LKSATFAC, & rt_domain(did)%overland%streams_and_lakes%ch_netrt, & RT_DOMAIN(did)%SH2OWGT, & RT_DOMAIN(did)%subsurface%grid_transform%smcrefrt, & @@ -897,11 +897,9 @@ subroutine disaggregateDomain_drv(did) RT_DOMAIN(did)%subsurface%grid_transform%smcmaxrt, & RT_DOMAIN(did)%subsurface%grid_transform%smcwltrt, & rt_domain(did)%subsurface%grid_transform%smcrt, & - rt_domain(did)%overland%properties%roughness, & rt_domain(did)%overland%streams_and_lakes%lake_mask, & rt_domain(did)%subsurface%properties%lksatrt, & rt_domain(did)%subsurface%properties%nexprt, & - RT_DOMAIN(did)%OV_ROUGH2d, & RT_DOMAIN(did)%subsurface%properties%sldpth, & RT_DOMAIN(did)%soiltypRT, RT_DOMAIN(did)%soiltyp, & rt_domain(did)%ELRT, RT_DOMAIN(did)%iswater, & @@ -926,9 +924,9 @@ end subroutine disaggregateDomain_drv !=================================================================================================== subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & SICE, SMC, SH2OX, INFXSRT, area_lsm, SMCMAX1, SMCREF1, & - SMCWLT1, VEGTYP, LKSAT, NEXP, dist,INFXSWGT,OVROUGHRTFAC, & - LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & - SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT, NEXPRT, OV_ROUGH2d, & + SMCWLT1, VEGTYP, LKSAT, NEXP, dist, INFXSWGT, & + LKSATFAC, CH_NETRT, SH2OWGT, SMCREFRT, INFXSUBRT, SMCMAXRT, & + SMCWLTRT, SMCRT, LAKE_MSKRT, LKSATRT, NEXPRT, & SLDPTH, soiltypRT, soiltyp, elrt, iswater, impervfrac, imperv_adj) #ifdef MPP_LAND use module_mpp_land, only: left_id,down_id,right_id, & @@ -957,7 +955,6 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & real, intent(in), dimension(IX,JX) :: SMCWLT1 ! coarse grid wilting point real, intent(in), dimension(IX,JX) :: LKSAT ! coarse grid lateral ksat (m/s) real, intent(in), dimension(IX,JX) :: NEXP ! coarse grid n exponent - real, intent(in), dimension(ix,jx) :: OV_ROUGH2d ! overland roughness ! LSM states: real, intent(in), dimension(IX,JX,NSOIL) :: SMC ! total soil moisture (m3/m3) real, intent(in), dimension(IX,JX,NSOIL) :: SH2OX ! liquid soil moisture (m3/m3) @@ -967,7 +964,6 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & real, intent(in), dimension(IXRT,JXRT,9) :: dist ! routing grid cell distances (m) and area (m2) ! TODO: can we just pass in area since we don't need other distances? - real, intent(in), dimension(IXRT,JXRT) :: OVROUGHRTFAC ! overland roughness adj factor real, intent(in), dimension(IXRT,JXRT) :: LKSATFAC ! lateral ksat adj factor real, intent(in), dimension(IXRT,JXRT) :: elrt ! elevation grid (m) integer, intent(in), dimension(IXRT,JXRT) :: CH_NETRT ! channel network routing grid @@ -987,7 +983,6 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & real, intent(out), dimension(IXRT,JXRT,NSOIL) :: SMCWLTRT ! wilting point on routing grid real, intent(out), dimension(IXRT,JXRT) :: LKSATRT ! lateral ksat on the routing grid (m/s) real, intent(out), dimension(IXRT,JXRT) :: NEXPRT ! n exponent on the routing grid - real, intent(out), dimension(IXRT,JXRT) :: OVROUGHRT ! overland roughness on the routing grid ! States: real, intent(out), dimension(IX,JX,NSOIL) :: SICE ! soil ice content on coarse grid (m3/m3) real, intent(out), dimension(IXRT,JXRT,NSOIL) :: SMCRT @@ -1169,25 +1164,6 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & ! Now do simple grid remapping tasks - ! Overland roughness: - !DJG map ov roughness as function of land use provided in VEGPARM.TBL... - ! --- added extra check for VEGTYP for 'masked-out' locations... - ! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1 - IF (VEGTYP(I,J).LE.0) then - OVROUGHRT(IXXRT,JYYRT) = 0.1 !COWS mask test - ELSE - OVROUGHRT(IXXRT,JYYRT) = OV_ROUGH2d(i,j) - ! Modify based on impervious fraction - ! See Liong et al. 1989 for linear weighting of "smoothness" (1/roughness) - ! Assuming roughness of 0.02 for impervious and native cell roughness for pervious - if (imperv_adj .ne. 0) then - OVROUGHRT(IXXRT,JYYRT) = 1. / ((1./0.02)*impervfrac(IXXRT,JYYRT) + & ! impervious fraction - (1./OVROUGHRT(IXXRT,JYYRT))*(1.-impervfrac(IXXRT,JYYRT))) ! pervious fraction - endif - ! Apply user-supplied adjustment factor - OVROUGHRT(IXXRT,JYYRT) = OVROUGHRT(IXXRT,JYYRT)*OVROUGHRTFAC(IXXRT,JYYRT) - END IF - ! Lateral ksat !DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling ! --- factor that will be read in from hires terrain file @@ -1283,7 +1259,6 @@ subroutine disaggregateDomain(IX, JX, NSOIL, IXRT, JXRT, AGGFACTRT, & call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99) call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99) call MPP_LAND_COM_REAL(NEXPRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99) call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99) do i = 1, NSOIL call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99) diff --git a/trunk/NDHMS/Routing/module_HYDRO_io.F b/trunk/NDHMS/Routing/module_HYDRO_io.F index 86201a2f7..b4312a88e 100644 --- a/trunk/NDHMS/Routing/module_HYDRO_io.F +++ b/trunk/NDHMS/Routing/module_HYDRO_io.F @@ -11171,8 +11171,8 @@ subroutine hdtbl_out(did) call hdtbl_out_nc(did,ncid, count,count_flag,"LKSAT",rt_domain(did)%LKSAT,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"NEXP",rt_domain(did)%NEXP,"",ixd,jxd) end do - end subroutine hdtbl_out + subroutine hdtbl_in_nc(did) implicit none integer :: did @@ -11180,7 +11180,7 @@ subroutine hdtbl_in_nc(did) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCMAX1",rt_domain(did)%SMCMAX1,ierr) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCREF1",rt_domain(did)%SMCREF1,ierr) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCWLT1",rt_domain(did)%SMCWLT1,ierr) - call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D,ierr) + call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%overland%properties%roughness,ierr, rt=.true.) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"LKSAT",rt_domain(did)%LKSAT,ierr) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"NEXP",rt_domain(did)%NEXP,ierr) ! Letting this variable be optional and setting to global default value if not found @@ -11190,7 +11190,7 @@ subroutine hdtbl_in_nc(did) endif end subroutine hdtbl_in_nc -subroutine read2dlsm(did,file,varName,varOut,ierr) +subroutine read2dlsm(did,file,varName,varOut,ierr,rt) use module_mpp_land,only: mpp_land_bcast_int1 implicit none integer :: did, ncid , iret @@ -11198,29 +11198,91 @@ subroutine read2dlsm(did,file,varName,varOut,ierr) real,dimension(:,:) :: varOut character(len=256) :: units integer, intent(out) :: ierr -#ifdef MPP_LAND + logical, optional, intent(in) :: rt + logical :: regrid + real,allocatable,dimension(:,:) :: tmpArr + +#ifdef MPP_LAND if(my_id .eq. io_id) then +#endif allocate(tmpArr(global_nx,global_ny)) iret = nf90_open(trim(file), NF90_NOWRITE, ncid) call get_2d_netcdf(trim(varName), ncid, tmpArr, units, global_nx, global_ny, & .false., ierr) iret = nf90_close(ncid) +#ifdef MPP_LAND else allocate(tmpArr(1,1)) endif - call decompose_data_real (tmpArr,varOut) +#endif + + if (present(rt)) then + regrid = rt + else + regrid = .false. + endif + + if (regrid) then + call regrid_lowres_to_highres(did, tmpArr, varOut, rt_domain(did)%ixrt, rt_domain(did)%jxrt) + else + call decompose_data_real (tmpArr,varOut) + endif + +#ifdef MPP_LAND call mpp_land_bcast_int1(ierr) +#endif + deallocate(tmpArr) +end subroutine read2dlsm + +subroutine regrid_lowres_to_highres(did, lowres_grid, highres_grid, ixrt, jxrt) + + implicit none + integer :: did + integer :: ixrt, jxrt + real, dimension(global_nx, global_ny) :: lowres_grid + real, dimension(ixrt,jxrt) :: highres_grid + ! Local variables + integer :: i, j, irt, jrt, aggfacxrt, aggfacyrt + +#ifdef MPP_LAND + real,allocatable,dimension(:,:) :: tmpArr + if(my_id .eq. io_id) then + allocate(tmpArr(global_rt_nx, global_rt_ny)) +#endif + + do j = 1,global_ny ! Start coarse grid j loop + do i = 1,global_nx ! Start coarse grid i loop + + do aggfacyrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid j loop + do aggfacxrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid i loop + + irt = i * nlst(did)%AGGFACTRT - aggfacxrt ! Define fine grid i + jrt = j * nlst(did)%AGGFACTRT - aggfacyrt ! Define fine grid j +#ifdef MPP_LAND + ! if(left_id.ge.0) irt = irt + 1 + ! if(down_id.ge.0) jrt = jrt + 1 + tmpArr(irt,jrt) = lowres_grid(i,j) #else - iret = nf90_open(trim(file), NF90_NOWRITE, ncid) - call get_2d_netcdf(trim(varName), ncid, varOut, units, rt_domain(did)%ix, rt_domain(did)%jx, & - .false., ierr) - iret = nf90_close(ncid) + highres_grid(irt,jrt) = lowres_grid(i,j) #endif -end subroutine read2dlsm + end do + end do + + end do + end do + +#ifdef MPP_LAND + else + allocate(tmpArr(1,1)) + endif + call decompose_RT_real(tmpArr, highres_grid, global_rt_nx, global_rt_ny, ixrt, jxrt) + deallocate(tmpArr) +#endif +end subroutine regrid_lowres_to_highres subroutine read_channel_only (olddateIn, hgrid, indir, dtbl) !use module_HYDRO_io, only: read_rst_crt_reach_nc diff --git a/trunk/NDHMS/Routing/module_RT.F b/trunk/NDHMS/Routing/module_RT.F index aa16207fc..c21a7a0ad 100644 --- a/trunk/NDHMS/Routing/module_RT.F +++ b/trunk/NDHMS/Routing/module_RT.F @@ -660,6 +660,7 @@ subroutine LandRT_ini(did) use config_base, only: nlst, noah_lsm use module_RT_data, only: rt_domain use module_gw_gw2d_data, only: gw2d + use module_HYDRO_io, only: regrid_lowres_to_highres #ifdef HYDRO_D use module_HYDRO_io, only: output_lake_types #endif @@ -1215,7 +1216,7 @@ subroutine LandRT_ini(did) !Apply calibration scaling factors to sfc roughness and retention depth here... rt_domain(did)%overland%properties%retention_depth = rt_domain(did)%overland%properties%retention_depth * rt_domain(did)%RETDEPRTFAC - ! Removing roughness parameter update since it has not been populated yet... currently happens in Noah_dist_routing (AD) + rt_domain(did)%overland%properties%roughness = rt_domain(did)%overland%properties%roughness * rt_domain(did)%OVROUGHRTFAC !ADCHANGE: Moved this channel cell setting from OV_RTNG so it is outside !of overland routine (frequently called) and time loop. @@ -1244,6 +1245,7 @@ subroutine LandRT_ini(did) #ifdef MPP_LAND ! communicate the value to call MPP_LAND_COM_REAL(rt_domain(did)%overland%properties%retention_depth,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) + call MPP_LAND_COM_REAL(rt_domain(did)%overland%properties%roughness,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) call MPP_LAND_COM_REAL(rt_domain(did)%overland%properties%surface_slope_x,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) call MPP_LAND_COM_REAL(rt_domain(did)%overland%properties%surface_slope_y,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) do i = 1, 8 From ad6a2dea1c7e4d01262582b6a142fd5bf7eaa88d Mon Sep 17 00:00:00 2001 From: Aubrey Dugger Date: Tue, 9 Aug 2022 12:22:16 -0600 Subject: [PATCH 21/25] Add negative smc check and fix to SSTEP solver to prevent NaNs from Xinanjiang module. For consistency using 0.01mm minimum threshold to match current SOILWATER routine check - worth rethinking this value in the future. --- .../NoahMP/phys/module_sf_noahmplsm.F | 42 ++++++++++++++++--- 1 file changed, 37 insertions(+), 5 deletions(-) diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F index 8ac28df68..f11d94c10 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmplsm.F @@ -6919,11 +6919,15 @@ SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in REAL, PARAMETER :: A = 4.0 REAL :: imperv_eff !local impervious adjustment (fraction, 0-1) + REAL :: WMINUS !subsurface deficit [m] + REAL :: SUBDEF !accumulation of subsurface deficit [m] ! ---------------------------------------------------------------------- RUNSRF = 0.0 PDDUM = 0.0 RSAT = 0.0 + SUBDEF = 0.0 + WMINUS = 0.0 ! for the case when snowmelt water is too large @@ -7070,8 +7074,9 @@ SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in SICE ,ILOC ,JLOC ,ZWT , & !in SH2O ,SMC ,AI ,BI ,CI , & !inout RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout - WPLUS) !out + WPLUS, WMINUS) !out RSAT = RSAT + WPLUS + SUBDEF = SUBDEF + WMINUS QDRAIN_SAVE = QDRAIN_SAVE + QDRAIN RUNSRF_SAVE = RUNSRF_SAVE + RUNSRF END DO @@ -7081,6 +7086,7 @@ SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT ! m/s -> mm/s QDRAIN = QDRAIN * 1000. + RUNSUB = RUNSUB - SUBDEF * 1000./DT ! mm/s !WRF_HYDRO_DJG... !yw INFXSRT = RUNSRF * DT !mm/s -> mm @@ -7443,7 +7449,7 @@ SUBROUTINE SSTEP (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in SICE ,ILOC ,JLOC ,ZWT , & !in SH2O ,SMC ,AI ,BI ,CI , & !inout RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout - WPLUS ) !out + WPLUS, WMINUS ) !out ! ---------------------------------------------------------------------- ! calculate/update soil moisture content values @@ -7476,6 +7482,7 @@ SUBROUTINE SSTEP (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in !output REAL, INTENT(OUT) :: WPLUS !saturation excess water (m) + REAL, INTENT(OUT) :: WMINUS !deficit from negative smc correction (m) !local INTEGER :: K @@ -7483,9 +7490,11 @@ SUBROUTINE SSTEP (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in REAL, DIMENSION(1:NSOIL) :: CIIN REAL :: STOT REAL :: EPORE - REAL :: WMINUS + REAL :: WATMIN !minimum water content (m/m) + ! ---------------------------------------------------------------------- WPLUS = 0.0 + WMINUS = 0.0 DO K = 1,NSOIL RHSTT (K) = RHSTT(K) * DT @@ -7559,8 +7568,31 @@ SUBROUTINE SSTEP (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in WPLUS = MAX((SH2O(NSOIL)-EPORE), 0.0) * DZSNSO(NSOIL) SH2O(NSOIL) = MIN(EPORE,SH2O(NSOIL)) END IF - - SMC = SH2O + SICE + + ! Negative soil moisture check + IF ( ANY(SH2O < 0.0) ) THEN + write(*,*) "WARNING: Negative smc adjustment" + ! WATMIN: in soilwater check this is a fixed value of 0.01 mm; why not smcdry? + ! For this formulation, we convert 0.01mm to a soil water fraction per layer. + ! So WATMIN = (0.01/1000.)/DZSNSO to convert to units of m/m for each layer. + DO K = 1,NSOIL-1 + WATMIN = 0.00001/DZSNSO(K) ! fraction + ! Amount of water below residual soil water content + WMINUS = MAX ((WATMIN-SH2O(K))*DZSNSO(K), 0.0 ) ! m + ! Remove from lower layer and add to current layer + SH2O(K) = MAX(WATMIN, SH2O(K)) + SH2O(K+1) = SH2O(K+1) - WMINUS/DZSNSO(K+1) + END DO + ! Check bottom layer to see if deficit still exists + WATMIN = 0.00001/DZSNSO(NSOIL) ! fraction + WMINUS = MAX ((WATMIN-SH2O(NSOIL))*DZSNSO(NSOIL), 0.0 ) ! m + SH2O(NSOIL) = MAX(WATMIN, SH2O(NSOIL)) + IF (WMINUS .ne. 0) then + write(*,*) "WARNING: SMC deficit - this water will be removed from subsurface runoff (meters).", WMINUS + END IF + END IF + + SMC = SH2O + SICE END SUBROUTINE SSTEP From 8f0706d01e12f5a26dd908118307b05c38cb3284 Mon Sep 17 00:00:00 2001 From: Soren Rasmussen Date: Sun, 14 Aug 2022 11:09:30 -0600 Subject: [PATCH 22/25] bugfix issue 650: initialize stepwtd to one to avoid SIGFPE from using zero in mod function. --- .../Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F index 0b4873cf9..7ac5b1dcf 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F @@ -126,7 +126,7 @@ module module_NoahMP_hrldas_driver INTEGER :: IOPT_SOIL ! soil configuration option INTEGER :: IOPT_PEDO ! soil pedotransfer function option INTEGER :: IOPT_CROP ! crop model option (0->none; 1->Liu et al.) - INTEGER :: IOPT_IMPERV !imperviousness infiltration adjustment (0->none; 1->total; + INTEGER :: IOPT_IMPERV !imperviousness infiltration adjustment (0->none; 1->total; !2->Alley&Veenhuis; 9->old) REAL, ALLOCATABLE, DIMENSION(:,:,:) :: T_PHY ! 3D atmospheric temperature valid at mid-levels [K] REAL, ALLOCATABLE, DIMENSION(:,:,:) :: QV_CURR ! 3D water vapor mixing ratio [kg/kg_dry] @@ -320,7 +320,7 @@ module module_NoahMP_hrldas_driver REAL, ALLOCATABLE, DIMENSION(:,:) :: QSPRINGXY REAL, ALLOCATABLE, DIMENSION(:,:) :: QSLATXY REAL :: WTDDT = 30.0 ! frequency of groundwater call [minutes] - INTEGER :: STEPWTD ! step of groundwater call + INTEGER :: STEPWTD = 1 ! step of groundwater call !------------------------------------------------------------------------ ! Crocus From dcd5cda8387d6b1a6cb0c8ee2fb0c43335404e6c Mon Sep 17 00:00:00 2001 From: Soren Rasmussen Date: Fri, 2 Sep 2022 11:44:55 -0700 Subject: [PATCH 23/25] Bugfix Issue 648: when crocus_opt is off, ZP_SNOWDZ(1,1) is allocated and set to zero. This avoids unallocated memory being accessed and causing a SEGFAULT when optimization is turned off. (#649) --- .../NoahMP/phys/module_sf_noahmpdrv.F | 23 +++++++++++-------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F index d6c48a6bc..5bafb4b18 100644 --- a/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F +++ b/trunk/NDHMS/Land_models/NoahMP/phys/module_sf_noahmpdrv.F @@ -74,7 +74,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN CWPVT_2D,VCMX25_2D,MP_2D,HVT_2D,MFSNO_2D,RSURFEXP_2D, & AXAJ_2D,BXAJ_2D,XXAJ_2D, & IMPERV_2D, & - SSI_2D,SNOWRETFAC_2D,TAU0_2D,RSURFSNOW_2D,SCAMAX_2D, & + SSI_2D,SNOWRETFAC_2D,TAU0_2D,RSURFSNOW_2D,SCAMAX_2D, & #endif #ifdef WRF_HYDRO sfcheadrt,INFXSRT,soldrain, & @@ -137,7 +137,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN INTEGER, INTENT(IN ) :: IOPT_SOIL ! soil configuration option INTEGER, INTENT(IN ) :: IOPT_PEDO ! soil pedotransfer function option INTEGER, INTENT(IN ) :: IOPT_CROP ! crop model option (0->none; 1->Liu et al.) - INTEGER, INTENT(IN ) :: IOPT_IMPERV !imperviousness infiltration adjustment (0->none; 1->total; + INTEGER, INTENT(IN ) :: IOPT_IMPERV !imperviousness infiltration adjustment (0->none; 1->total; !9->old) INTEGER, INTENT(IN ) :: IZ0TLND ! option of Chen adjustment of Czil (not used) REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: T3D ! 3D atmospheric temperature valid at mid-levels [K] @@ -622,6 +622,9 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ! HSNOWMETAMO = 'C13' HSNOWRAD = 'B92' ! HSNOWRAD = 'TAR2' + else + allocate(ZP_SNOWDZ (1,1)) ! This is allocated to avoid SEGFAULT when crocus_opt=0 and + ZP_SNOWDZ = 0.0 ! optimization is off end if ! crocus_opt /= 0 ! ---------------------------------------------------------------------- @@ -829,7 +832,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN parameters%scamax = SCAMAX_2D(I,J) ! maximum fractional snow covered area (0.0-1.0) #endif CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,CROPTYPE,parameters,iopt_imperv) - + GRAIN = 0.0 ! mass of grain [g/m2] GDD = 0.0 ! growing degree days PGS = 0 ! crop growth stage @@ -1527,7 +1530,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, INTEGER, INTENT(IN) :: SOILCOLOR INTEGER, INTENT(IN) :: CROPTYPE INTEGER, INTENT(IN) :: iopt_imperv - + type (noahmp_parameters), intent(inout) :: parameters REAL :: REFDK @@ -1715,7 +1718,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%AXAJ = AXAJ_TABLE(SOILTYPE) parameters%BXAJ = BXAJ_TABLE(SOILTYPE) parameters%XXAJ = XXAJ_TABLE(SOILTYPE) - IF (parameters%URBAN_FLAG) THEN + IF (parameters%URBAN_FLAG) THEN parameters%IMPERV = IMPERV_URBAN_TABLE ELSE parameters%IMPERV = 0.0 @@ -1724,7 +1727,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, parameters%SNOW_RET_FAC = SNOW_RET_FAC_TABLE parameters%TAU0 = TAU0_TABLE parameters%RSURF_SNOW = RSURF_SNOW_TABLE - parameters%SCAMAX = SCAMAX_TABLE + parameters%SCAMAX = SCAMAX_TABLE #endif ! ---------------------------------------------------------------------- ! Transfer GENPARM parameters @@ -1738,10 +1741,10 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE, IF(parameters%URBAN_FLAG)THEN ! Hardcoding some urban parameters for soil if (iopt_imperv .eq. 9) then - parameters%SMCMAX = 0.45 - parameters%SMCREF = 0.42 - parameters%SMCWLT = 0.40 - parameters%SMCDRY = 0.40 + parameters%SMCMAX = 0.45 + parameters%SMCREF = 0.42 + parameters%SMCWLT = 0.40 + parameters%SMCDRY = 0.40 endif parameters%CSOIL = 3.E6 ENDIF From c547959f74bb73df22f621a34cfd637c05c58bac Mon Sep 17 00:00:00 2001 From: Soren Rasmussen Date: Fri, 2 Sep 2022 11:59:25 -0700 Subject: [PATCH 24/25] Transition a few remaining 'include mpif.h' statements to 'use mpi'. Using modules is better than including files and leads to better function variable types and debugging. (#643) --- trunk/NDHMS/IO/netcdf_layer.f90 | 16 +- .../Noah/IO_code/Noah_hrldas_driver.F | 231 +++++++++--------- .../IO_code/module_NoahMP_hrldas_driver.F | 2 +- trunk/NDHMS/MPP/module_mpp_GWBUCKET.F | 2 +- trunk/NDHMS/MPP/module_mpp_ReachLS.F | 4 +- trunk/NDHMS/Routing/module_RT.F | 15 +- 6 files changed, 133 insertions(+), 137 deletions(-) diff --git a/trunk/NDHMS/IO/netcdf_layer.f90 b/trunk/NDHMS/IO/netcdf_layer.f90 index 63cef60f1..850f2e826 100644 --- a/trunk/NDHMS/IO/netcdf_layer.f90 +++ b/trunk/NDHMS/IO/netcdf_layer.f90 @@ -1,8 +1,8 @@ module netcdf_layer_base use netcdf + use mpi implicit none - include "mpif.h" - + type, abstract :: NetCDF_layer_ procedure (nf90_open), pointer, nopass :: open_file ! => nf90_open procedure (nf90_def_dim), pointer, nopass :: def_dim !=> nf90_def_dim @@ -34,7 +34,7 @@ function create_file_signature(object, path, cmode, initialsize, chunksize, ncid integer, intent( out) :: ncid integer :: res end function create_file_signature - + end interface type, extends(NetCDF_layer_) :: NetCDF_serial_ @@ -59,11 +59,11 @@ function create_file_serial (object, path, cmode, initialsize, chunksize, ncid) integer, optional, intent(inout) :: chunksize integer, intent( out) :: ncid integer :: res - + res = nf90_create(path = path, cmode = cmode, ncid = ncid) - + end function create_file_serial - + function create_file_parallel(object, path, cmode, initialsize, chunksize, ncid) result(res) class(NetCDF_parallel_),intent(in) :: object character (len = *), intent(in ) :: path @@ -72,10 +72,10 @@ function create_file_parallel(object, path, cmode, initialsize, chunksize, ncid) integer, optional, intent(inout) :: chunksize integer, intent( out) :: ncid integer :: res - + res = nf90_create(path = path, cmode = cmode, ncid = ncid, & & comm = object%mpi_communicator, info = object%default_info) - + end function create_file_parallel end module netcdf_layer_base diff --git a/trunk/NDHMS/Land_models/Noah/IO_code/Noah_hrldas_driver.F b/trunk/NDHMS/Land_models/Noah/IO_code/Noah_hrldas_driver.F index 40014d055..832232740 100644 --- a/trunk/NDHMS/Land_models/Noah/IO_code/Noah_hrldas_driver.F +++ b/trunk/NDHMS/Land_models/Noah/IO_code/Noah_hrldas_driver.F @@ -2,20 +2,20 @@ ! Author(s)/Contact(s): ! Abstract: ! History Log: -! +! ! Usage: ! Parameters: ! Input Files: ! ! Output Files: ! -! +! ! Condition codes: ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code -! +! ! User controllable options: program Noah_hrldas_driver @@ -29,11 +29,10 @@ program Noah_hrldas_driver #ifdef MPP_LAND use module_mpp_land, only: MPP_LAND_PAR_INI, mpp_land_init, HYDRO_COMM_WORLD - IMPLICIT NONE - include "mpif.h" -#else - IMPLICIT NONE + use mpi #endif + IMPLICIT NONE + character(len=9), parameter :: version = "v20110427" integer :: LDASIN_VERSION @@ -95,8 +94,8 @@ program Noah_hrldas_driver integer :: forc_typ, snow_assim, HRLDAS_ini_typ real, allocatable, dimension(:,:) :: qsgw - integer :: gwsoilcpl - + integer :: gwsoilcpl + INTEGER, allocatable, DIMENSION(:,:) :: VEGTYP,SOLTYP REAL, allocatable, DIMENSION(:,:) :: TERRAIN, LATITUDE, LONGITUDE REAL, allocatable, DIMENSION(:,:) :: refdk2d, refkdt2d @@ -119,7 +118,7 @@ program Noah_hrldas_driver !KWM REAL, allocatable, DIMENSION(:,:) :: ETPNDX, SFCHEAD, INFXS1, PDDUM2, PCPDRP, SFCWATR2 REAL, allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX - REAL, allocatable, DIMENSION(:,:,:) :: ZSOILX + REAL, allocatable, DIMENSION(:,:,:) :: ZSOILX REAL, allocatable, DIMENSION(:,:,:) :: SMAV2D ! Min/Max values from the 12-monthly Green Vegetation Fraction: @@ -146,7 +145,7 @@ program Noah_hrldas_driver REAL :: ZLVL ! Height (m) above ground of atmospheric forcing variables REAL :: ZLVL_WIND! Height (m) above ground of atmospheric forcing variables for wind. INTEGER :: NSOIL ! Number of soil layers - REAL, ALLOCATABLE, DIMENSION(:) :: SLDPTH ! The THICKNESS (m) of each soil layer + REAL, ALLOCATABLE, DIMENSION(:) :: SLDPTH ! The THICKNESS (m) of each soil layer CHARACTER(LEN=256) :: LLANDUSE ! (=USGS, using USGS landuse classification) CHARACTER(LEN=256) :: LSOIL ! (=STAS, using FAO/STATSGO soil texture classification) @@ -155,7 +154,7 @@ program Noah_hrldas_driver REAL :: SFCPRS ! Pressure (Pa) at height ZLVL m above ground REAL :: PRCP ! Precip rate (kg m-2 s-1) (NOTE: this is a rate) REAL :: SFCTMP ! Air temperature (K) at height ZLVL m above ground - REAL :: Q2 ! Specific Humidity (kg kg-1) at height ZLVL m above ground + REAL :: Q2 ! Specific Humidity (kg kg-1) at height ZLVL m above ground REAL :: SFCSPD ! Wind speed (m s-1) at height ZLVL m above ground REAL :: PRCPRAIN ! Liquid-precipitation rate (KG M-2 S-1) (not used) REAL :: TH2 ! Air potential temperature (K) at height ZLVL m above ground @@ -181,27 +180,27 @@ program Noah_hrldas_driver REAL :: Z0 ! Time varying roughness length (m) as function of snow depth REAL :: CMCX ! Canopy moisture content (m) REAL :: T1X ! Ground/Canopy/Snowpack effective skin temperature (K) - REAL, allocatable, DIMENSION(:) :: STC1 ! Soil temp (K) + REAL, allocatable, DIMENSION(:) :: STC1 ! Soil temp (K) REAL, allocatable, DIMENSION(:) :: SMC1 ! Total soil moisture content (volumetric fraction) REAL, allocatable, DIMENSION(:) :: SH2O ! Unfrozen soil moisture content (volumetric fraction) ! NOTE: Frozen soil moisture = SMC - SH2O - REAL :: SNOWH ! Actual snow depth (m) - REAL :: SNEQV ! Liquid water-equivalent snow depth (m) - ! NOTE: snow density = SNEQV/SNOWH - REAL :: ALBEDO ! Surface albedo including snow effect (unitless fraction) - ! =snow-free albedo (ALB) when SNEQV=0, or - ! =FCT(MSNOALB,ALB,VEGTYP,SHDFAC,SHDMIN) when SNEQV>0 - REAL :: CH ! Surface exchange coefficient for heat and moisture - ! (m s-1); NOTE: CH is technically a conductance since - ! it has been multiplied by wind speed. - REAL :: CM ! Surface exchange coefficient for momentum (m s-1); NOTE: - ! CM is technically a conductance since it has been - ! multiplied by wind speed. + REAL :: SNOWH ! Actual snow depth (m) + REAL :: SNEQV ! Liquid water-equivalent snow depth (m) + ! NOTE: snow density = SNEQV/SNOWH + REAL :: ALBEDO ! Surface albedo including snow effect (unitless fraction) + ! =snow-free albedo (ALB) when SNEQV=0, or + ! =FCT(MSNOALB,ALB,VEGTYP,SHDFAC,SHDMIN) when SNEQV>0 + REAL :: CH ! Surface exchange coefficient for heat and moisture + ! (m s-1); NOTE: CH is technically a conductance since + ! it has been multiplied by wind speed. + REAL :: CM ! Surface exchange coefficient for momentum (m s-1); NOTE: + ! CM is technically a conductance since it has been + ! multiplied by wind speed. REAL :: SNOTIME1 ! INTENT(OUT) from SFLX: REAL :: ETT ! Total plant transpiration (W m-2) - REAL :: ETA ! Actual latent heat flux (W m-2: negative, if up from surface) + REAL :: ETA ! Actual latent heat flux (W m-2: negative, if up from surface) !KWM ??? Is the note about the sign of ETA right ???? !KWM REAL :: SHEAT ! Sensible heat flux (W m-2: negative, if upward from surface) REAL :: ETA_KINEMATIC ! Actual latent heat flux (kg m/s) @@ -218,17 +217,17 @@ program Noah_hrldas_driver REAL :: ETP ! Potential Evaporation (w m-2) REAL :: SSOIL ! Soil heat flux (W m-2: negative if downward from surface) REAL :: FLX1 ! Precip-snow sfc (W m-2) - REAL :: FLX2 ! Freezing rain latent heat flux (W m-2) + REAL :: FLX2 ! Freezing rain latent heat flux (W m-2) REAL :: FLX3 ! Phase-change heat flux from snowmelt (W m-2) REAL :: SNOMLT ! Snow melt (m) (water equivalent) REAL :: RUNOFF1 ! Surface runoff (m s-1), not infiltrating the surface REAL :: RUNOFF2 ! Subsurface runoff (m s-1), drainage out bottom of last - ! soil layer (baseflow). Note: RUNOFF2 is actually + ! soil layer (baseflow). Note: RUNOFF2 is actually ! the sum of RUNOFF2 and RUNOFF3 REAL :: RUNOFF3 ! Numerical trunctation in excess of porosity (SMCMAX) ! for a given soil layer at the end of a time step (m s-1). REAL :: RC ! Canopy resistance (s m-1) - REAL :: PC ! Plant coefficient (dimensionless fraction, 0.0-1.0) + REAL :: PC ! Plant coefficient (dimensionless fraction, 0.0-1.0) ! where PC*ETP = actual transpiration REAL :: RCS ! Incoming solar RC factor (dimensionless) REAL :: RCT ! Air temperature RC factor (dimensionless) @@ -238,7 +237,7 @@ program Noah_hrldas_driver ! between SMCWLT and SMCMAX) REAL :: SOILM ! Total soil column moisture content (frozen+unfrozen) (m) REAL :: Q1 ! Effective specific humidity at surface (kg kg-1), used for - ! diagnosing the specific humidity at 2 meter for + ! diagnosing the specific humidity at 2 meter for ! coupled model REAL, allocatable, dimension(:) :: SMAV ! Documentation? @@ -333,7 +332,7 @@ program Noah_hrldas_driver REAL, ALLOCATABLE, DIMENSION(:,:) :: TH2_URB2D REAL, ALLOCATABLE, DIMENSION(:,:) :: Q2_URB2D ! -!m REAL, ALLOCATABLE, DIMENSION(:,:) :: AKHS_URB2D +!m REAL, ALLOCATABLE, DIMENSION(:,:) :: AKHS_URB2D REAL, ALLOCATABLE, DIMENSION(:,:) :: AKMS_URB2D ! REAL, ALLOCATABLE, DIMENSION(:,:) :: UST_URB2D @@ -465,13 +464,13 @@ program Noah_hrldas_driver integer :: noah_timestep = -999 integer :: forcing_timestep = -999 character(len = 256):: GEO_STATIC_FLNM - + integer :: gwCycle, GWBASESWCRT namelist / NOAHLSM_OFFLINE/ INDIR, NSOIL, ZSOIL, FORCING_TIMESTEP, NOAH_TIMESTEP, & START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN, & RESTART_FREQUENCY_HOURS, OUTPUT_TIMESTEP, & - SPLIT_OUTPUT_COUNT, SFCDIF_OPTION, IZ0TLND, UPDATE_SNOW_FROM_FORCING, & + SPLIT_OUTPUT_COUNT, SFCDIF_OPTION, IZ0TLND, UPDATE_SNOW_FROM_FORCING, & KHOUR, KDAY, ZLVL, ZLVL_WIND, HRLDAS_CONSTANTS_FILE, OUTDIR, RESTART_FILENAME_REQUESTED, & external_fpar_filename_template, external_lai_filename_template, & subwindow_xstart, subwindow_xend, subwindow_ystart, subwindow_yend, & @@ -499,7 +498,7 @@ program Noah_hrldas_driver integer :: imode character(len=256) :: restart_flnm -#ifdef _PARALLEL_ +#ifdef _PARALLEL_ integer :: numtasks real, pointer, dimension(:,:) :: vegtyp_ptr integer :: send_tag @@ -539,7 +538,7 @@ program Noah_hrldas_driver zlvl_wind = 10.0 !KWM vegmin = -999. !KWM vegmax = -999. - + output_timestep = 0 restart_frequency_hours = 0 @@ -637,7 +636,7 @@ program Noah_hrldas_driver dt = real(noah_timestep) -#ifdef _PARALLEL_ +#ifdef _PARALLEL_ call MPI_INIT(ierr) if (ierr /= MPI_SUCCESS) stop "MPI_INIT" @@ -678,7 +677,7 @@ program Noah_hrldas_driver !......................... end of model configuration (later in a namelist) ..... -!KWM#ifdef _PARALLEL_ +!KWM#ifdef _PARALLEL_ !KWM !KWM nlandpts = count(vegtyp_ptr/=iswater) !KWM @@ -710,8 +709,8 @@ program Noah_hrldas_driver #ifdef _PARALLEL_ - ! Set up our parallal_xstart and parallel_xend values, the x-coordinate points over which - ! each particular process will span, such that the land points of the full domain are + ! Set up our parallal_xstart and parallel_xend values, the x-coordinate points over which + ! each particular process will span, such that the land points of the full domain are ! approximately evenly distributed among the processors. This will make the loop which calls ! SFLX for the I/J points a little more balanced, but could make the ! I/O a little less balanced. @@ -836,7 +835,7 @@ program Noah_hrldas_driver !KWM allocate( PCPDRP (PARALLEL_XSTART:PARALLEL_XEND,SUBWINDOW_YSTART:SUBWINDOW_YEND) ) !KWM allocate( SFCWATR2 (PARALLEL_XSTART:PARALLEL_XEND,SUBWINDOW_YSTART:SUBWINDOW_YEND) ) - allocate( SMC (PARALLEL_XSTART:PARALLEL_XEND,SUBWINDOW_YSTART:SUBWINDOW_YEND,NSOIL) ) + allocate( SMC (PARALLEL_XSTART:PARALLEL_XEND,SUBWINDOW_YSTART:SUBWINDOW_YEND,NSOIL) ) allocate( STC (PARALLEL_XSTART:PARALLEL_XEND,SUBWINDOW_YSTART:SUBWINDOW_YEND,NSOIL) ) allocate( SH2OX (PARALLEL_XSTART:PARALLEL_XEND,SUBWINDOW_YSTART:SUBWINDOW_YEND,NSOIL) ) allocate( ZSOILX(PARALLEL_XSTART:PARALLEL_XEND,SUBWINDOW_YSTART:SUBWINDOW_YEND,NSOIL) ) @@ -916,11 +915,11 @@ program Noah_hrldas_driver ALLOCATE(SF_AC_URB3D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) ALLOCATE(CM_AC_URB3D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) ALLOCATE(SFVENT_URB3D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) - ALLOCATE(LFVENT_URB3D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) - ALLOCATE(CMR_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) - ALLOCATE(CHR_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) - ALLOCATE(CMC_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) - ALLOCATE(CHC_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) + ALLOCATE(LFVENT_URB3D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) + ALLOCATE(CMR_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) + ALLOCATE(CHR_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) + ALLOCATE(CMC_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) + ALLOCATE(CHC_URB2D ( PARALLEL_XSTART:PARALLEL_XEND, SUBWINDOW_YSTART:SUBWINDOW_YEND ) ) CMR_URB2D = 0.1 CHR_URB2D = 0.1 CMC_URB2D = 0.1 @@ -952,16 +951,16 @@ program Noah_hrldas_driver PRCP1=0 PRCP_old=0 - RUNOFF1X=0.0 - RUNOFF2X=0.0 - RUNOFF3X=0.0 + RUNOFF1X=0.0 + RUNOFF2X=0.0 + RUNOFF3X=0.0 EDIRX=0.0 ETTX=0.0 !FC ETPNDX=-999.9 SNOEVPX=-999.9 SNODEP=-999.9 - SNODEP = 0 - WEASD = 0 + SNODEP = 0 + WEASD = 0 STC=-999.9 @@ -979,7 +978,7 @@ program Noah_hrldas_driver XLAI2D = 0. GVFMIN = -999. GVFMAX = -999. - + LAI = 0.0 !--------------------------------------------------------------------- @@ -1128,7 +1127,7 @@ program Noah_hrldas_driver inflnm = trim(indir)//"/"//& startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& startdate(15:16)//".LDASIN_DOMAIN"//hgrid - else + else inflnm = trim(indir)//"/"//& startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& ".LDASIN_DOMAIN"//hgrid @@ -1137,7 +1136,7 @@ program Noah_hrldas_driver parallel_xstart, parallel_xend, subwindow_ystart, subwindow_yend, & NSOIL, SLDPTH, OLDDATE, LDASIN_VERSION, SMC, STC, SH2OX, CMC, T1, & WEASD, SNODEP) - ! *** Read lai, fveg etc. + ! *** Read lai, fveg etc. CALL READVEG_HRLDAS(inflnm, & @@ -1240,12 +1239,12 @@ program Noah_hrldas_driver allocate(stc (ix,jx,nsoil)) allocate(sh2ox (ix,jx,nsoil)) smc = 0.0 - stc = 0.0 + stc = 0.0 sh2ox = 0.0 else greenfrac = 0.0 !yw call get_greenfrac(trim(GEO_STATIC_FLNM),greenfrac, ix, jx, olddate) - endif + endif sfcheadrt =0.0 infxsrt = 0.0 etpnd = 0.0 @@ -1260,7 +1259,7 @@ program Noah_hrldas_driver if(rank == 0) print*, "k, NTIME, dt = ",k,NTIME , dt !-------------------------------------------------------------------------------- -! Output for restart BEFORE the processing for this particular time has begun, +! Output for restart BEFORE the processing for this particular time has begun, ! so that upon restart, we're ready to go on this time step. !-------------------------------------------------------------------------------- @@ -1272,7 +1271,7 @@ program Noah_hrldas_driver call hrldas_drv_HYDRO(STC(:,:,1:NSOIL),SMC(:,:,1:NSOIL),SH2OX(:,:,1:NSOIL), & infxsrt,sfcheadrt,soldrain,ix,jx,NSOIL, & qsgw) - goto 1003 + goto 1003 endif if(rank .eq. 0) then @@ -1281,7 +1280,7 @@ program Noah_hrldas_driver ! Read the forcing data. !--------------------------------------------------------------------------------- -! For HRLDAS, we're assuming (for now) that each time period is in a +! For HRLDAS, we're assuming (for now) that each time period is in a ! separate file. So we can open a new one right now. inflnm = trim(indir)//"/"//& @@ -1343,7 +1342,7 @@ program Noah_hrldas_driver if ( ( K == 1 ) .and. ( .not. restart_flag ) ) then - ! Initial values of Q1, the Z0-level specific humidity, are taken from the ZLVL-level + ! Initial values of Q1, the Z0-level specific humidity, are taken from the ZLVL-level ! values. Subsequent Q1 values are remembered from the previous time step Q1 values ! as recomputed by SFLX. Q12D = Q2X/(1.0+Q2X) ! Convert mixing ratio to specific humidity @@ -1408,7 +1407,7 @@ program Noah_hrldas_driver ! CZIL ! SLOPE ! FRZFACT - ! + ! ! -- VEGETATION PARAMETERS: ! ! TOPT @@ -1511,7 +1510,7 @@ program Noah_hrldas_driver if ( ( k==1 ) .and. ( .not. restart_flag ) ) then ! ! First time step, initialize EMISS from reasonable background values. Subsequent - ! time steps will use the EMISS value calculcated in the previous time step. This + ! time steps will use the EMISS value calculcated in the previous time step. This ! means that EMISS has to go into the RESTART file. ! emiss(i,j) = real ( dble(emissmintbl(vegtypx))+dble(fraction)*(dble(emissmaxtbl(vegtypx))-dble(emissmintbl(vegtypx))) ) @@ -1586,14 +1585,14 @@ program Noah_hrldas_driver Q2=Q2SAT*0.99 ENDIF - CHKFF = CH * CPHEAT * RHO + CHKFF = CH * CPHEAT * RHO STC1(1:NSOIL)=STC(I,J,1:NSOIL) SMC1(1:NSOIL)=SMC(I,J,1:NSOIL) SH2O(1:NSOIL)=SH2OX(I,J,1:NSOIL) ZSOILX(I,J,1:NSOIL)=ZSOIL(1:NSOIL) -! *** diagnostics +! *** diagnostics SFCSPDX(I,J)=SFCSPD @@ -1619,7 +1618,7 @@ program Noah_hrldas_driver ( VEGTYP(I,J) == 32 ) .or. ( VEGTYP(I,J) == 33 ) ) THEN ! VEGTYPX = 5 ! HARD WIRED CATEGORY IS A PROBLEM. NEEDS CORRECTION VEGTYPX = 10 ! HARD WIRED CATEGORY IS A PROBLEM. NEEDS CORRECTION - SHDFAC = 0.8 + SHDFAC = 0.8 ALBBRD =0.2 T1X= ( T1(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) ENDIF @@ -1633,10 +1632,10 @@ program Noah_hrldas_driver - ! The following variables are available here, to subroutine - ! SFLX, and to its deeper subroutines via use-association with + ! The following variables are available here, to subroutine + ! SFLX, and to its deeper subroutines via use-association with ! module noahlsm_globals. - ! + ! ! ALB : Surface albedo (Fraction 0.0 to 1.0) ! Z0BRD : Roughness Length (m) ! SHDFAC: Green Vegetation Fraction @@ -1657,20 +1656,20 @@ program Noah_hrldas_driver ! PTU : Photo thermal unit (plant phenology for annuals/crops) ! ! BEXP : B parameter - ! SMCDRY: Dry soil moisture threshold where direct evap from top + ! SMCDRY: Dry soil moisture threshold where direct evap from top ! layer ends (volumetric) ! F1 : Soil thermal diffusivity/conductivity coef. ! SMCMAX: Porosity, i.e. saturated value of soil moisture (volumetric) ! -- Max soil moisture content (porosity) ! -- Saturation soil moisture content (from REDPRM) - ! SMCREF: Soil moisture threshold where transpiration begins to + ! SMCREF: Soil moisture threshold where transpiration begins to ! stress (volumetric) ! -- Reference soil moisture (field capacity) - ! -- Reference soil moisture (where soil water + ! -- Reference soil moisture (where soil water ! deficit stress sets in) ! PSISAT: Saturated soil matric potential ! DKSAT : Saturated soil conductivity - ! DWSAT : + ! DWSAT : ! SMCWLT: Wilting point soil moisture (volumetric) ! QUARTZ: Soil quartz content ! @@ -1684,7 +1683,7 @@ program Noah_hrldas_driver ! FRZFACT: Frozen ground parameter ! ZBOT : Depth (m) of lower boundary soil temperature ! CZIL : Calculate roughness length of heat - ! KDT + ! KDT ! ! Arguments to SFLX are: ! ---------------------------------------------------------------------- @@ -1735,7 +1734,7 @@ program Noah_hrldas_driver ! SNEQV : Liquid water-equivalent snow depth (m). NOTE: Snow density = SNEQV/SNOWH ! ALBEDO : Surface albedo including snow effect (Fraction) ! CH : Surface exchange coefficient for heat and moisture (m s-1) - ! NOTE: CH is technically a conductance since it has been + ! NOTE: CH is technically a conductance since it has been ! multiplied by wind speed. ! UNUSED ! CM : Surface exchange coefficient for momentum (m s-1) ! NOTE: CM is technically a conductance since it has been @@ -1891,7 +1890,7 @@ program Noah_hrldas_driver ! print*, 'SNOWH = ', SNOWH, 'i=',i, 'j=',j ! print*, 'SNEQV = ', SNEQV,'i=',i, 'j=',j - if(GWBASESWCRT .eq. 3) then + if(GWBASESWCRT .eq. 3) then REFDK_DATA = refdk2d(i,j) REFKDT_DATA = refkdt2d(i,j) endif @@ -1901,27 +1900,27 @@ program Noah_hrldas_driver LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, & !F COSZ,PRCPRAIN, SOLARDIRECT, & !F TH2,Q2SAT,DQSDT2, & !I - VEGTYPX,SOILTYP,SlOPETYP,SHDFAC,SHDMIN,SHDMAX, & !S - ALB,SNOALB,TBOT,Z0BRD,Z0,EMISSI, EMBRD, & !S - CMCX,T1X,STC1,SMC1,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM,& !H -! ---------------------------------------------------------------------- -! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN -! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA -! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. -! ---------------------------------------------------------------------- - ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O - EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O - BETA,ETP,SSOIL, & !O - FLX1,FLX2,FLX3, & !O - SNOMLT,SNCOVR, & !O - RUNOFF1,RUNOFF2,RUNOFF3, & !O - RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + VEGTYPX,SOILTYP,SlOPETYP,SHDFAC,SHDMIN,SHDMAX, & !S + ALB,SNOALB,TBOT,Z0BRD,Z0,EMISSI, EMBRD, & !S + CMCX,T1X,STC1,SMC1,SH2O,SNOWH,SNEQV,ALBEDO,CH,CM,& !H +! ---------------------------------------------------------------------- +! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN +! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA +! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ---------------------------------------------------------------------- + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O SOILW,SOILM,Q1,SMAV, & !D RDLAI2D, USEMONALB, SNOTIME1, RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & sfcheadrt(i,j),INFXSRT(i,j),ETPND1, & - gwsoilcpl, qsgw(i,j)) !P - + gwsoilcpl, qsgw(i,j)) !P + #if _DEBUG_PRINT_ ETPND(i,j) = ETPND(i,j) + etpnd1 @@ -2028,7 +2027,7 @@ program Noah_hrldas_driver ! Convert ETA and ETP from W M-2 to KG M-2 S-1 !KWM ETA = ETA/2.501E+6 - ETP = ETP/2.501E+6 + ETP = ETP/2.501E+6 QFX(I,J) = (EDIR+EC+ETT) + ESNOW ! in W m{-2} @@ -2073,7 +2072,7 @@ program Noah_hrldas_driver SMCWLT1(I,J)=SMCWLT ALBEDX(I,J)=ALBEDO ACRAIN(I,J)=ACRAIN(I,J)+PRCP*dt ! (mm/s to mm) - + ACSNOM(I,J)=ACSNOM(I,J)+snomlt*1.E3 ! Accumulated snow melt (convert m to mm). ! ESNOW2D: Accumulated snow sublimation (converted from W m{-2} to kg m{-2} s{-2} to mm) ESNOW2D(I,J)=ESNOW2D(I,J)+(ESNOW/2.83E6)*dt @@ -2114,7 +2113,7 @@ program Noah_hrldas_driver ! Call urban ! - UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) + UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) TA_URB = SFCTMP ! [K] QA_URB = Q2X(I,J) ! [kg/kg] UA_URB = SQRT(U(I,J)**2.+V(I,J)**2.) @@ -2166,7 +2165,7 @@ program Noah_hrldas_driver CHR_URB = CHR_URB2D(I,J) CMC_URB = CMC_URB2D(I,J) CHC_URB = CHC_URB2D(I,J) - + ! IF ( .FALSE. ) THEN @@ -2278,7 +2277,7 @@ program Noah_hrldas_driver 'LH_URB',LH_URB, 'ETA',ETA, 'ETAKIN(I,J)',ETAKIN(I,J), & 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),& 'TS_URB',TS_URB,'T1X',T1X,'T1(I,J)',T1(I,J), & - 'QS_URB',QS_URB,'Q1',Q1,'Q2X(I,J)',Q2X(I,J) + 'QS_URB',QS_URB,'Q1',Q1,'Q2X(I,J)',Q2X(I,J) endif @@ -2320,12 +2319,12 @@ program Noah_hrldas_driver Q2_URB2D(I,J) = Q2_URB UST_URB2D(I,J) = UST_URB ! - CMR_URB2D(I,J) = CMR_URB - CHR_URB2D(I,J) = CHR_URB - CMC_URB2D(I,J) = CMC_URB - CHC_URB2D(I,J) = CHC_URB + CMR_URB2D(I,J) = CMR_URB + CHR_URB2D(I,J) = CHR_URB + CMC_URB2D(I,J) = CMC_URB + CHC_URB2D(I,J) = CHC_URB - AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J)) + AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J)) else !KWM ????? do kroof = 1, num_roof_Layers !KWM ????? @@ -2390,8 +2389,8 @@ program Noah_hrldas_driver call add_to_output(ettx , "ETTX" , "Accumulated plant transpiration" , "mm" ) call add_to_output(albedx , "ALBEDX" , "Albedo -- What kind? (I.e., including what effects?)", "fraction") call add_to_output(weasd , "WEASD" , "Water equivalent snow depth" , "m" ) - call add_to_output(acrain , "ACRAIN" , "Accumulated precipitation" , "mm" ) - call add_to_output(acsnom , "ACSNOM" , "Accumulated snow melt" , "mm" ) + call add_to_output(acrain , "ACRAIN" , "Accumulated precipitation" , "mm" ) + call add_to_output(acsnom , "ACSNOM" , "Accumulated snow melt" , "mm" ) call add_to_output(esnow2d , "ESNOW" , "Accumulated evaporation of snow" , "mm" ) call add_to_output(drip2d , "DRIP" , "Accumulated canopy drip" , "mm" ) call add_to_output(dewfall , "DEWFALL" , "Accumulated dewfall" , "mm" ) @@ -2415,9 +2414,9 @@ program Noah_hrldas_driver call add_to_output(trl_urb3d , "TRL" , "Roof temperature" , "K" ) call add_to_output(tbl_urb3d , "TBL" , "Wall temperature" , "K" ) call add_to_output(tgl_urb3d , "TGL" , "Road temperature" , "K" ) - call add_to_output(tr_urb2d , "TR" , "Roof layer temperature" , "K" ) - call add_to_output(tb_urb2d , "TB" , "Wall layer temperature" , "K" ) - call add_to_output(tg_urb2d , "TG" , "Road layer temperature" , "K" ) + call add_to_output(tr_urb2d , "TR" , "Roof layer temperature" , "K" ) + call add_to_output(tb_urb2d , "TB" , "Wall layer temperature" , "K" ) + call add_to_output(tg_urb2d , "TG" , "Road layer temperature" , "K" ) call add_to_output(tc_urb2d , "TC" , "Urban canopy temperature" , "K" ) endif #endif @@ -2437,18 +2436,18 @@ program Noah_hrldas_driver !yw endif !------------------------------------------------------------------------ -! Update the time +! Update the time !------------------------------------------------------------------------ - + call geth_newdate(newdate, olddate, nint(dt)) olddate = newdate !------------------------------------------------------------------------ -! End of Time Loop (do K) +! End of Time Loop (do K) !------------------------------------------------------------------------ #ifdef _PARALLEL_ - ! Just for sanity's sake, make sure all processors have caught up + ! Just for sanity's sake, make sure all processors have caught up ! before continuing to the next time step. call mpi_barrier(HYDRO_COMM_WORLD, ierr) if (ierr /= MPI_SUCCESS) stop "Problem with MPI_BARRIER" @@ -2479,17 +2478,17 @@ program Noah_hrldas_driver .and. (restart_frequency_hours <= 0) ) yw_rst_out = 99 if ((k >= 0) .and. ((restart_frequency_hours .gt. 0) .and. (mod(k, int(restart_frequency_hours*3600./nint(dt))) == 0) & - .or. yw_rst_out .eq. 99) ) then + .or. yw_rst_out .eq. 99) ) then yw_rst_out = -999 if (rank == 0) print*, 'Write restart at '//olddate(1:13) call prepare_restart_file(trim(outdir), version, iz0tlnd, sfcdif_option, & - sf_urban_physics, igrid, llanduse, olddate, startdate, & + sf_urban_physics, igrid, llanduse, olddate, startdate, & ixfull, jxfull, ixpar, jxpar, xstartpar, ystartpar, & nsoil, dx, dy, truelat1, truelat2, mapproj, lat1, lon1, cen_lon, & iswater, vegtyp) - ! Since the restart files are not really for user consumption, the units and description are + ! Since the restart files are not really for user consumption, the units and description are ! a little superfluous. I've made them optional arguments. If not present, they both default to "-". call add_to_restart ( stc, "SOIL_T" ) @@ -2644,12 +2643,12 @@ SUBROUTINE calc_declin ( nowdate, latitude, longitude, cosz, hrang, declin ) DECLIN=0. !-----OBECL : OBLIQUITY = 23.5 DEGREE. - + OBECL=23.5*DEGRAD SINOB=SIN(OBECL) - + !-----CALCULATE LONGITUDE OF THE SUN FROM VERNAL EQUINOX: - + IF(JULIAN.GE.80.)SXLONG=DPD*(JULIAN-80.)*DEGRAD IF(JULIAN.LT.80.)SXLONG=DPD*(JULIAN+285.)*DEGRAD ARG=SINOB*SIN(SXLONG) diff --git a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F index 7ac5b1dcf..3d97ab219 100644 --- a/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F +++ b/trunk/NDHMS/Land_models/NoahMP/IO_code/module_NoahMP_hrldas_driver.F @@ -40,7 +40,7 @@ module module_NoahMP_hrldas_driver IMPLICIT NONE !#ifdef MPP_LAND -! include "mpif.h" +! use mpi !#endif #ifdef WRF_HYDRO diff --git a/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F b/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F index 1a79e6577..0b121dcf8 100644 --- a/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F +++ b/trunk/NDHMS/MPP/module_mpp_GWBUCKET.F @@ -25,11 +25,11 @@ MODULE MODULE_mpp_GWBUCKET use module_mpp_land, only: io_id, my_id, mpp_status, mpp_land_max_int1, numprocs, & mpp_land_bcast_real, sum_real8, mpp_land_sync use iso_fortran_env, only: int64 + use mpi implicit none - include "mpif.h" integer,allocatable,dimension(:) :: sizeInd ! size of Basins for each tile integer :: maxSizeInd diff --git a/trunk/NDHMS/MPP/module_mpp_ReachLS.F b/trunk/NDHMS/MPP/module_mpp_ReachLS.F index 119d3c10f..ef027c1c3 100644 --- a/trunk/NDHMS/MPP/module_mpp_ReachLS.F +++ b/trunk/NDHMS/MPP/module_mpp_ReachLS.F @@ -23,6 +23,7 @@ MODULE MODULE_mpp_ReachLS use module_mpp_land, only: io_id, my_id, mpp_status, mpp_land_max_int1, mpp_land_sync, HYDRO_COMM_WORLD use hashtable + use mpi implicit none @@ -65,7 +66,6 @@ MODULE MODULE_mpp_ReachLS - include "mpif.h" integer,allocatable,dimension(:) :: sDataRec ! sending data size integer,allocatable,dimension(:) :: rDataRec ! receiving data size @@ -1517,5 +1517,3 @@ subroutine TONODE2RSL8 (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end subroutine TONODE2RSL8 END MODULE MODULE_mpp_ReachLS - - diff --git a/trunk/NDHMS/Routing/module_RT.F b/trunk/NDHMS/Routing/module_RT.F index c21a7a0ad..fa3ef00c0 100644 --- a/trunk/NDHMS/Routing/module_RT.F +++ b/trunk/NDHMS/Routing/module_RT.F @@ -42,15 +42,15 @@ MODULE module_Routing use module_hydro_stop, only: HYDRO_stop use hashtable use iso_fortran_env, only: int64 - - IMPLICIT NONE - #ifdef OUTPUT_CHAN_CONN #ifdef MPP_LAND - include "mpif.h" !! JLM: thought I could pick this up from module_mpp_land... but seems not + use mpi #endif #endif + IMPLICIT NONE + + integer, parameter :: r8 = selected_real_kind(8) real*8, parameter :: zeroDbl=0.0000000000000000000_r8 integer, parameter :: r4 = selected_real_kind(4) @@ -1010,10 +1010,10 @@ subroutine LandRT_ini(did) endif ! end if block for UDMP_OPT !------------------------------------------- - ! Z.Cui: Changed new_start_i to 0, otherwise, it crashes with + ! Z.Cui: Changed new_start_i to 0, otherwise, it crashes with ! an out-of-bounds error when the '-check all' is enabled ! for the ifort compiler. - ! The reason is that CH_LNKRT and CH_LNKRT_SL is defined as + ! The reason is that CH_LNKRT and CH_LNKRT_SL is defined as ! 1:IXRT and 1:JXRT. Now new_start_i is changed to start from 1. !------------------------------------------- new_start_i = 1; new_start_j = 1 @@ -1039,7 +1039,7 @@ subroutine LandRT_ini(did) type(hash_t) :: hash_table integer(kind=int64) :: val,ii,jj logical :: found - + call hash_table%set_all_idx(rt_domain(did)%LLINKID, rt_domain(did)%LNLINKSL) do jj = new_start_j, new_end_j do ii = new_start_i, new_end_i @@ -1725,4 +1725,3 @@ subroutine deriveFromNode(did) end subroutine deriveFromNode END MODULE module_Routing - From 8adbcee79798d3e1f88d5fc4c2e8c4f0856f987a Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Fri, 2 Sep 2022 13:04:50 -0600 Subject: [PATCH 25/25] Bump numpy from 1.17.1 to 1.22.0 in /tests/local (#642) Bumps [numpy](https://github.com/numpy/numpy) from 1.17.1 to 1.22.0. - [Release notes](https://github.com/numpy/numpy/releases) - [Changelog](https://github.com/numpy/numpy/blob/main/doc/HOWTO_RELEASE.rst) - [Commits](https://github.com/numpy/numpy/compare/v1.17.1...v1.22.0) --- updated-dependencies: - dependency-name: numpy dependency-type: direct:production ... Signed-off-by: dependabot[bot] Co-authored-by: Ryan Cabell --- tests/local/requirements.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/local/requirements.txt b/tests/local/requirements.txt index ee628f990..187955a49 100644 --- a/tests/local/requirements.txt +++ b/tests/local/requirements.txt @@ -16,7 +16,7 @@ jsonpickle==1.2 locket==0.2.0 more-itertools==7.2.0 netCDF4==1.4.1 -numpy==1.17.1 +numpy==1.22.0 pandas==0.23.4 partd==1.0.0 pathlib==1.0.1