From 07a6bf2d72e1bb4efb001280e4179a07bb58bee9 Mon Sep 17 00:00:00 2001 From: Jan Mandel Date: Tue, 5 Dec 2017 16:10:02 -0700 Subject: [PATCH] WRFV3.9.1.1 --- wrfv2_fire/README | 14 +- wrfv2_fire/dyn_em/module_diffusion_em.F | 2 +- wrfv2_fire/external/.gitignore | 17 + wrfv2_fire/hydro/CPL/WRF_cpl/Makefile | 34 + wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl | 9 + .../hydro/CPL/WRF_cpl/module_wrf_HYDRO.F | 415 + .../CPL/WRF_cpl/module_wrf_HYDRO_downscale.F | 439 + wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F | 57 + wrfv2_fire/hydro/Data_Rec/Makefile | 28 + .../hydro/Data_Rec/gw_field_include.inc | 34 + .../hydro/Data_Rec/module_GW_baseflow_data.F | 9 + wrfv2_fire/hydro/Data_Rec/module_RT_data.F | 30 + .../hydro/Data_Rec/module_gw_gw2d_data.F | 30 + wrfv2_fire/hydro/Data_Rec/module_namelist.F | 410 + wrfv2_fire/hydro/Data_Rec/namelist.inc | 65 + wrfv2_fire/hydro/Data_Rec/rt_include.inc | 218 + wrfv2_fire/hydro/HYDRO_drv/Makefile | 29 + wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F | 1665 +++ wrfv2_fire/hydro/MPP/CPL_WRF.F | 225 + wrfv2_fire/hydro/MPP/Makefile | 39 + wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F | 236 + wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F | 1089 ++ wrfv2_fire/hydro/MPP/mpp_land.F | 2346 ++++ wrfv2_fire/hydro/README.hydro | 123 + wrfv2_fire/hydro/Rapid_routing/.gitignore | 24 + wrfv2_fire/hydro/Rapid_routing/LICENSE | 24 + wrfv2_fire/hydro/Rapid_routing/README | 9 + .../hydro/Rapid_routing/hrldas_RAPID_drv.F90 | 18 + .../Rapid_routing/hrldas_RAPID_wrapper.F90 | 210 + wrfv2_fire/hydro/Rapid_routing/makefile | 245 + wrfv2_fire/hydro/Rapid_routing/makefile.cpl | 197 + wrfv2_fire/hydro/Rapid_routing/makefile.orig | 229 + .../hydro/Rapid_routing/rapid_arrays.F90 | 709 ++ .../Rapid_routing/rapid_close_Qfor_file.F90 | 40 + .../Rapid_routing/rapid_close_Qhum_file.F90 | 40 + .../Rapid_routing/rapid_close_Qobs_file.F90 | 40 + .../Rapid_routing/rapid_close_Qout_file.F90 | 42 + .../Rapid_routing/rapid_close_Vlat_file.F90 | 42 + .../Rapid_routing/rapid_create_Qout_file.F90 | 65 + .../hydro/Rapid_routing/rapid_create_obj.F90 | 219 + .../hydro/Rapid_routing/rapid_destro_obj.F90 | 147 + .../hydro/Rapid_routing/rapid_final.F90 | 192 + .../hydro/Rapid_routing/rapid_get_Qdam.F90 | 129 + .../hydro/Rapid_routing/rapid_hsh_mat.F90 | 236 + wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 | 397 + wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 | 299 + wrfv2_fire/hydro/Rapid_routing/rapid_namelist | 109 + .../hydro/Rapid_routing/rapid_net_mat.F90 | 331 + .../hydro/Rapid_routing/rapid_net_mat_brk.F90 | 286 + .../hydro/Rapid_routing/rapid_obs_mat.F90 | 106 + .../Rapid_routing/rapid_open_Qfor_file.F90 | 43 + .../Rapid_routing/rapid_open_Qhum_file.F90 | 43 + .../Rapid_routing/rapid_open_Qobs_file.F90 | 43 + .../Rapid_routing/rapid_open_Qout_file.F90 | 50 + .../Rapid_routing/rapid_open_Vlat_file.F90 | 49 + .../hydro/Rapid_routing/rapid_phiroutine.F90 | 277 + .../Rapid_routing/rapid_read_Qfor_file.F90 | 74 + .../Rapid_routing/rapid_read_Qhum_file.F90 | 75 + .../Rapid_routing/rapid_read_Qobs_file.F90 | 75 + .../Rapid_routing/rapid_read_Vlat_file.F90 | 79 + .../Rapid_routing/rapid_read_namelist.F90 | 38 + .../hydro/Rapid_routing/rapid_routing.F90 | 268 + .../Rapid_routing/rapid_routing_param.F90 | 100 + .../hydro/Rapid_routing/rapid_script.sh | 11 + .../hydro/Rapid_routing/rapid_set_Qext0.F90 | 103 + wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 | 538 + .../Rapid_routing/rapid_write_Qout_file.F90 | 82 + wrfv2_fire/hydro/Routing/Makefile | 99 + wrfv2_fire/hydro/Routing/Noah_distr_routing.F | 3007 +++++ wrfv2_fire/hydro/Routing/module_GW_baseflow.F | 528 + wrfv2_fire/hydro/Routing/module_HYDRO_io.F | 9923 +++++++++++++++++ wrfv2_fire/hydro/Routing/module_HYDRO_utils.F | 417 + wrfv2_fire/hydro/Routing/module_RT.F | 1290 +++ wrfv2_fire/hydro/Routing/module_UDMAP.F | 569 + .../hydro/Routing/module_channel_routing.F | 2277 ++++ .../hydro/Routing/module_date_utilities_rt.F | 1032 ++ wrfv2_fire/hydro/Routing/module_gw_gw2d.F | 2159 ++++ wrfv2_fire/hydro/Routing/module_lsm_forcing.F | 3291 ++++++ .../Routing/module_noah_chan_param_init_rt.F | 114 + wrfv2_fire/hydro/Routing/rtFunction.F | 222 + wrfv2_fire/hydro/Run/HYDRO.TBL | 51 + wrfv2_fire/hydro/Run/hydro.namelist | 102 + wrfv2_fire/hydro/arc/Makefile.Noah | 30 + wrfv2_fire/hydro/arc/Makefile.NoahMP | 30 + wrfv2_fire/hydro/arc/Makefile.mpp | 17 + wrfv2_fire/hydro/arc/Makefile.seq | 36 + wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r | 43 + wrfv2_fire/hydro/arc/macros.mpp.gfort | 46 + wrfv2_fire/hydro/arc/macros.mpp.ifort | 96 + wrfv2_fire/hydro/arc/macros.mpp.ifort.luna | 96 + wrfv2_fire/hydro/arc/macros.mpp.linux | 67 + wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r | 43 + wrfv2_fire/hydro/arc/macros.seq.gfort | 47 + wrfv2_fire/hydro/arc/macros.seq.ifort | 60 + wrfv2_fire/hydro/arc/macros.seq.linux | 61 + wrfv2_fire/hydro/configure | 113 + wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL | 50 + .../hydro/template/HYDRO/hydro.namelist | 142 + wrfv2_fire/hydro/wrf_hydro_config | 28 + wrfv2_fire/inc/.gitignore | 14 + wrfv2_fire/inc/version_decl | 2 +- wrfv2_fire/test/em_real/.gitignore | 27 + 102 files changed, 40022 insertions(+), 3 deletions(-) create mode 100644 wrfv2_fire/external/.gitignore create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F create mode 100644 wrfv2_fire/hydro/Data_Rec/Makefile create mode 100644 wrfv2_fire/hydro/Data_Rec/gw_field_include.inc create mode 100644 wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_RT_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_namelist.F create mode 100644 wrfv2_fire/hydro/Data_Rec/namelist.inc create mode 100644 wrfv2_fire/hydro/Data_Rec/rt_include.inc create mode 100644 wrfv2_fire/hydro/HYDRO_drv/Makefile create mode 100644 wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F create mode 100644 wrfv2_fire/hydro/MPP/CPL_WRF.F create mode 100644 wrfv2_fire/hydro/MPP/Makefile create mode 100644 wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F create mode 100644 wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F create mode 100644 wrfv2_fire/hydro/MPP/mpp_land.F create mode 100644 wrfv2_fire/hydro/README.hydro create mode 100644 wrfv2_fire/hydro/Rapid_routing/.gitignore create mode 100644 wrfv2_fire/hydro/Rapid_routing/LICENSE create mode 100644 wrfv2_fire/hydro/Rapid_routing/README create mode 100644 wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/makefile create mode 100644 wrfv2_fire/hydro/Rapid_routing/makefile.cpl create mode 100644 wrfv2_fire/hydro/Rapid_routing/makefile.orig create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_final.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_namelist create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_script.sh create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Routing/Makefile create mode 100644 wrfv2_fire/hydro/Routing/Noah_distr_routing.F create mode 100644 wrfv2_fire/hydro/Routing/module_GW_baseflow.F create mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_io.F create mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_utils.F create mode 100644 wrfv2_fire/hydro/Routing/module_RT.F create mode 100644 wrfv2_fire/hydro/Routing/module_UDMAP.F create mode 100644 wrfv2_fire/hydro/Routing/module_channel_routing.F create mode 100644 wrfv2_fire/hydro/Routing/module_date_utilities_rt.F create mode 100644 wrfv2_fire/hydro/Routing/module_gw_gw2d.F create mode 100644 wrfv2_fire/hydro/Routing/module_lsm_forcing.F create mode 100644 wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F create mode 100644 wrfv2_fire/hydro/Routing/rtFunction.F create mode 100644 wrfv2_fire/hydro/Run/HYDRO.TBL create mode 100644 wrfv2_fire/hydro/Run/hydro.namelist create mode 100644 wrfv2_fire/hydro/arc/Makefile.Noah create mode 100644 wrfv2_fire/hydro/arc/Makefile.NoahMP create mode 100644 wrfv2_fire/hydro/arc/Makefile.mpp create mode 100644 wrfv2_fire/hydro/arc/Makefile.seq create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.gfort create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.ifort create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.ifort.luna create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.linux create mode 100644 wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r create mode 100644 wrfv2_fire/hydro/arc/macros.seq.gfort create mode 100644 wrfv2_fire/hydro/arc/macros.seq.ifort create mode 100644 wrfv2_fire/hydro/arc/macros.seq.linux create mode 100755 wrfv2_fire/hydro/configure create mode 100644 wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL create mode 100644 wrfv2_fire/hydro/template/HYDRO/hydro.namelist create mode 100755 wrfv2_fire/hydro/wrf_hydro_config create mode 100644 wrfv2_fire/inc/.gitignore create mode 100644 wrfv2_fire/test/em_real/.gitignore diff --git a/wrfv2_fire/README b/wrfv2_fire/README index c4f56eb0..95af8ae9 100644 --- a/wrfv2_fire/README +++ b/wrfv2_fire/README @@ -1,4 +1,4 @@ -WRF Model Version 3.9.1 (August 17, 2017) +WRF Model Version 3.9.1.1 (August 28, 2017) http://wrf-model.org/users/users.php ------------------------ @@ -27,6 +27,15 @@ infringement actions. This is the main directory for the WRF Version 3 source code release. ====================================== +V3.9.1.1 Release Notes (8/28/17): +------------------- + +- Version 3.9.1.1 has only limited bug fixes compared to version 3.9.1. + For more information on WRF V3.9.1.1 release, visit WRF User's home pages + http://www2.mmm.ucar.edu/wrf/users/, and + http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide. + + V3.9.1 Release Notes (8/17/17): ------------------- @@ -260,6 +269,9 @@ WRF update history: - V3.7.1: Aug 14, 2015 - V3.8: April 8, 2016 - V3.8.1: Aug 12, 2016 +- V3.9: Apr 17, 2017 +- V3.9.1: Aug 17, 2017 +- V3.9.1.1: Aug 28, 2017 ====================================== diff --git a/wrfv2_fire/dyn_em/module_diffusion_em.F b/wrfv2_fire/dyn_em/module_diffusion_em.F index 05083102..eacd5d2d 100644 --- a/wrfv2_fire/dyn_em/module_diffusion_em.F +++ b/wrfv2_fire/dyn_em/module_diffusion_em.F @@ -2904,7 +2904,7 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, config_flags, & zx_at_v(i, kts, j) = 0.125 * (zx(i, kts, j) + zx(i + 1, kts, j) + & zx(i, kts, j - 1) + zx(i + 1, kts, j - 1) + zx(i, kts + 1, j) + & zx(i + 1, kts + 1, j) + zx(i, kts + 1, j - 1) + zx(i + 1, kts + 1, j - 1)) - zy_at_v(i, kts, j) = 0.5 * (zy(i, k, j) + zy(i, k + 1 , j)) + zy_at_v(i, kts, j) = 0.5 * (zy(i, kts, j) + zy(i, kts + 1 , j)) ENDDO ENDDO ! diff --git a/wrfv2_fire/external/.gitignore b/wrfv2_fire/external/.gitignore new file mode 100644 index 00000000..86611601 --- /dev/null +++ b/wrfv2_fire/external/.gitignore @@ -0,0 +1,17 @@ +# This is the top-level .gitignore file for the "external" directory for the # +# WRF Model # +# # +# Filenames and wildcards added below will not be tracked by git anywhere in # +# this directory or any of its subdirectories. Note that these rules will be # +# supplemented by rules in the top-level .gitignore file # +# # +# Ignored file types should include executables, build-time temporary files, # +# and other files which should not ever be added to the code repository. # +# # +# USE CAUTION WHEN ADDING WILDCARDS, as some builds use different filename # +# conventions than others # +############################################################################## +*.f + +# Exceptions to top-level .gitignore: many external/ source code files use .f90 extension +!*.f90 diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile new file mode 100644 index 00000000..a37fbe0d --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile @@ -0,0 +1,34 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + + + +include ../../macros + +MODFLAG = -I./ -I ../../MPP -I ../../mod + +WRF_ROOT = ../../.. +OBJS = \ + module_wrf_HYDRO.o \ + wrf_drv_HYDRO.o +all: $(OBJS) + +.F.o: + @echo "" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).f + $(RMD) $(*).f + @echo "" + ar -r ../../lib/libHYDRO.a $(@) + +# +# Dependencies: +# +module_wrf_HYDRO.o: ../../Data_Rec/module_RT_data.o ../../Data_Rec/module_namelist.o ../../HYDRO_drv/module_HYDRO_drv.o + +wrf_drv_HYDRO.o: module_wrf_HYDRO.o + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl new file mode 100644 index 00000000..64550bdb --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl @@ -0,0 +1,9 @@ +# Makefile + +all: + (cd ../../; make -f Makefile.comm BASIC) + (make) + +clean: + (make clean) + (cd ../../; make -f Makefile.comm clean) diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F new file mode 100644 index 00000000..4e2fe3a1 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F @@ -0,0 +1,415 @@ +! Program Name: +! 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_WRF_HYDRO + +#ifdef MPP_LAND + 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 + use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate +#endif + use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe + + use module_rt_data, only: rt_domain + use module_gw_gw2d_data, only: gw2d + use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate + use module_namelist, only: nlst_rt + USE module_domain, ONLY : domain, domain_clock_get + USE module_configure, ONLY : grid_config_rec_type + !yw USE module_configure, only : config_flags + USE module_configure, only: model_config_rec + + + implicit none + + !yw added for check soil moisture and soiltype + integer :: checkSOIL_flag + +#ifndef MPP_LAND + character(len=19) :: cpl_outdate +#endif +! +! added to consider the adaptive time step from WRF model. + real :: dtrt_ter0 , dtrt_ch0 + integer :: mm0 + + + + +CONTAINS + +!wrf_cpl_HYDRO will not call the off-line lsm +!ywGW subroutine wrf_cpl_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte) + subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) + + implicit none + TYPE ( domain ), INTENT(INOUT) :: grid +!ywGW TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags + integer its, ite, jts, jte, ij + real :: HYDRO_dt + + + integer k, ix,jx, mm, nn + + integer :: did + + integer ntime + + integer :: i,j + + +!output flux and state variable + + did = 1 + + + ix = ite - its + 1 + jx = jte - jts + 1 + + if(HYDRO_dt .le. 0) then + write(6,*) "WARNING: HYDRO_dt <= 0 from land input. set it to be 1 seconds." + HYDRO_dt = 1 + endif + + ntime = 1 + + + nlst_rt(did)%dt = HYDRO_dt + + + if(.not. RT_DOMAIN(did)%initialized) then + + + !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers + !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels + nlst_rt(did)%nsoil = grid%num_soil_layers + + +#ifdef MPP_LAND + call mpp_land_bcast_int1 (nlst_rt(did)%nsoil) +#endif + allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil)) + if(grid%zs(1) < 0) then + nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil) + else + nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil) + endif + + CALL domain_clock_get( grid, current_timestr=cpl_outdate) + nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) + nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) + + +#ifdef MPP_LAND + call CPL_LAND_INIT(its,ite,jts,jte) +#endif + +#ifdef HYDRO_D + write(6,*) "sf_surface_physics is ", grid%sf_surface_physics +#endif + + if(grid%sf_surface_physics .eq. 5) then + ! clm4 + call HYDRO_ini(ntime,did=did,ix0=1,jx0=1) + else + call HYDRO_ini(ntime,did,ix0=ix,jx0=jx,vegtyp=grid%IVGTYP(its:ite,jts:jte),soltyp=grid%isltyp(its:ite,jts:jte)) + endif + + + + if(nlst_rt(did)%sys_cpl .ne. 2) then + call hydro_stop("In module_wrf_HYDRO.F wrf_cpl_HYDRO() - "// & + "sys_cpl should be 2. Check hydro.namelist file.") + endif + + + nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) + nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) + + nlst_rt(did)%dt = HYDRO_dt + if(nlst_rt(did)%dtrt_ter .ge. HYDRO_dt) then + nlst_rt(did)%dtrt_ter = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/nlst_rt(did)%dtrt_ter + if(mm*nlst_rt(did)%dtrt_ter.lt. HYDRO_dt) nlst_rt(did)%dtrt_ter = HYDRO_dt/mm + mm0 = mm + endif + + dtrt_ter0 = nlst_rt(did)%dtrt_ter + + if(nlst_rt(did)%dtrt_ch .ge. HYDRO_dt) then + nlst_rt(did)%dtrt_ch = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/nlst_rt(did)%dtrt_ch + if(mm*nlst_rt(did)%dtrt_ch.lt. HYDRO_dt) nlst_rt(did)%dtrt_ch = HYDRO_dt/mm + mm0 = mm + endif + + dtrt_ch0 = nlst_rt(did)%dtrt_ch + endif + + if((mm0*nlst_rt(did)%dtrt_ter) .ne. HYDRO_dt) then ! WRF model time step changed. + if(dtrt_ter0 .ge. HYDRO_dt) then + nlst_rt(did)%dtrt_ter = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/dtrt_ter0 + if(mm*dtrt_ter0 .lt. HYDRO_dt) nlst_rt(did)%dtrt_ter = HYDRO_dt/mm + mm0 = mm + endif + endif + + if((mm0*nlst_rt(did)%dtrt_ch) .ne. HYDRO_dt) then ! WRF model time step changed. + if(dtrt_ch0 .ge. HYDRO_dt) then + nlst_rt(did)%dtrt_ch = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/dtrt_ch0 + if(mm*dtrt_ch0 .lt. HYDRO_dt) nlst_rt(did)%dtrt_ch = HYDRO_dt/mm + mm0 = mm + endif + endif + +#ifdef HYDRO_D + write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt +#endif + + if(nlst_rt(did)%rtFlag .eq. 0) return + + + nn = nlst_rt(did)%nsoil + + ! get the data from WRF + + + + if((.not. RT_DOMAIN(did)%initialized) .and. (nlst_rt(did)%rst_typ .eq. 1) ) then +#ifdef HYDRO_D + write(6,*) "restart initial data from offline file" +#endif + else + do k = 1, nlst_rt(did)%nsoil + RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) + RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) + RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) + end do + rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte) + rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte) + endif + + call HYDRO_exe(did) + + +! add for update the WRF state variable. + do k = 1, nlst_rt(did)%nsoil + ! grid%TSLB(its:ite,k,jts:jte) = RT_DOMAIN(did)%STC(:,:,k) + grid%smois(its:ite,k,jts:jte) = RT_DOMAIN(did)%smc(:,:,k) + grid%sh2o(its:ite,k,jts:jte) = RT_DOMAIN(did)%sh2ox(:,:,k) + end do + +! update WRF variable after running routing model. + grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%sfcheadrt + +! provide groundwater soil flux to WRF for fully coupled simulations (FERSCH 09/2014) + if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then +!Wei Yu: comment the following two lines. Not ready for WRF3.7 release +!yw grid%qsgw(its:ite,jts:jte) = gw2d(did)%qsgw +!yw config_flags%gwsoilcpl = nlst_rt(did)%gwsoilcpl + end if + +!yw not sure for the following +! grid%xice(its:ite,jts:jte) = rt_domain(did)%sice + + RT_DOMAIN(did)%initialized = .true. + end subroutine wrf_cpl_HYDRO + + + + + +!program drive rtland +! This subroutine will be used if the 4-layer Noah lsm is not used. + subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) +! input: z1,v1,kk1,z,ix,jx,kk +! output: vout +! interpolate based on soil layer: z1 and z +! z : soil layer of output variable. +! z1: array of soil layers of input variable. + implicit none + integer:: i,j,k + integer:: kk1, ix,jx,kk, vegtyp(ix,jx) + real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk) + + + do j = 1, jx + do i = 1, ix + do k = 1, kk + call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) + end do + end do + end do + end subroutine wrf2lsm + +! This subroutine will be used if the 4-layer Noah lsm is not used. + subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) +! input: z1,v1,kk1,z,ix,jx,kk +! output: vout +! interpolate based on soil layer: z1 and z +! z : soil layer of output variable. +! z1: array of soil layers of input variable. + implicit none + integer:: i,j,k + integer:: kk1, ix,jx,kk, vegtyp(ix,jx) + real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx) + + + do j = 1, jx + do i = 1, ix + do k = 1, kk + call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) + end do + end do + end do + end subroutine lsm2wrf + + subroutine interpLayer(inZ,inV,inK,outZ,outV) + implicit none + integer:: k, k1, k2 + integer :: inK + real:: inV(inK),inZ(inK) + real:: outV, outZ, w1, w2 + + if(outZ .le. inZ(1)) then + w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1)) + w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1)) + outV = inV(1)*w1-inV(2)*w2 + return + elseif(outZ .ge. inZ(inK)) then + w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) + w2 = (outZ-inZ(inK)) /(inZ(inK)-inZ(inK-1)) + outV = inV(inK)*w1 -inV(inK-1)* w2 + return + else + do k = 2, inK + if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then + k1 = k-1 + k2 = k + w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1)) + w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1)) + outV = inV(k2)*w1 + inV(k1)*w2 + return + end if + end do + endif + end subroutine interpLayer + + subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx) + implicit none + integer did, leng + parameter(leng=100) + integer :: i,j, nn, ix,jx + integer, dimension(ix,jx) :: soltyp, vegtyp + real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc + + + where(soltyp == 14) VEGTYP = 16 + where(VEGTYP == 16 ) soltyp = 14 + + RT_DOMAIN(did)%VEGTYP = vegtyp + +! input OV_ROUGH from OVROUGH.TBL +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + +#ifndef NCEP_WCOSS + open(71,file="HYDRO.TBL", form="formatted") +!read OV_ROUGH first + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(71) + +#else + open(13, form="formatted") +!read OV_ROUGH first + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(13) +#endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) + call mpp_land_bcast_real(leng,xdum1) + call mpp_land_bcast_real(leng,MAXSMC) + call mpp_land_bcast_real(leng,refsmc) + call mpp_land_bcast_real(leng,wltsmc) +#endif + + rt_domain(did)%lksat = 0.0 + do j = 1, RT_DOMAIN(did)%jx + do i = 1, RT_DOMAIN(did)%ix + rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + IF(rt_domain(did)%VEGTYP(i,j) == 1 ) 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)) + ENDIF + end do + end do + + + end subroutine lsm_wrf_input + + subroutine checkSoil(did) + implicit none + integer :: did + where(rt_domain(did)%smc(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 + where(rt_domain(did)%sh2ox(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 + where(rt_domain(did)%smc(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 + where(rt_domain(did)%sh2ox(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 + end subroutine checkSoil + +end module module_wrf_HYDRO diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F new file mode 100644 index 00000000..cf747fe8 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F @@ -0,0 +1,439 @@ +! Program Name: +! 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_WRF_HYDRO + +#ifdef MPP_LAND + 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 +#endif + use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe + + use module_rt_data, only: rt_domain + use module_CPL_LAND, only: cpl_outdate + use module_namelist, only: nlst_rt + USE module_domain, ONLY : domain, domain_clock_get + + implicit none + + !yw added for check soil moisture and soiltype + integer :: checkSOIL_flag + +! +! added to consider the adaptive time step from WRF model. + real :: dtrt0 + integer :: mm0, itime + + + + +CONTAINS + +!wrf_cpl_HYDRO_finescale will not call the off-line lsm + subroutine wrf_cpl_HYDRO_finescale(HYDRO_dt,grid,its,ite,jts,jte) + use module_NoahMP_hrldas_driver, only: noah_timestep , land_driver_ini + implicit none + TYPE ( domain ), INTENT(INOUT) :: grid + integer its, ite, jts, jte, ij + real :: HYDRO_dt + + + integer k, ix,jx, mm + + integer :: did + + integer ntime + + integer :: i,j + + +!output flux and state variable + + did = 1 + ix = ite - its + 1 + jx = jte - jts + 1 + + if(HYDRO_dt .le. 0) then + write(6,*) "Warning: HYDRO_dt <= 0 from land input. set it to be 1 seconds." + HYDRO_dt = 1 + endif + + ntime = 1 + + + nlst_rt(did)%dt = HYDRO_dt + + itime = itime + 1 + if(.not. RT_DOMAIN(did)%initialized) then + itime = 1 + + nlst_rt(did)%nsoil = grid%num_soil_layers + +#ifdef MPP_LAND + call mpp_land_bcast_int1 (nlst_rt(did)%nsoil) +#endif + allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil)) + if(grid%zs(1) < 0) then + nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil) + else + nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil) + endif + + CALL domain_clock_get( grid, current_timestr=cpl_outdate) + nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) + nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) + +!yw continue + + call land_driver_ini(nn,its,ite,jts,jte) + +#ifdef HYDRO_D + write(6,*) "sf_surface_physics is ", grid%sf_surface_physics +#endif + nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) + nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) + + nlst_rt(did)%dt = HYDRO_dt + noah_timestep = nlst_rt(did)%dt + + if(nlst_rt(did)%dtrt .lt. HYDRO_dt) then + nlst_rt(did)%dtrt = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/nlst_rt(did)%dtrt + if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm + mm0 = mm + endif + + dtrt0 = nlst_rt(did)%dtrt + endif + + if((mm0*nlst_rt(did)%dtrt) .ne. HYDRO_dt) then ! WRF model time step changed. + if(dtrt0 .lt. HYDRO_dt) then + nlst_rt(did)%dtrt = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/dtrt0 + if(mm*dtrt0 .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm + mm0 = mm + endif + endif + +#ifdef HYDRO_D + write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt +#endif + +! get forcing data from WRF + call wrf2l_finemesh(grid,its,ite,jts,jte) + + call HYDRO_land_finemesh_exe(itime) + + call l_finemesh2wrf(grid) + + RT_DOMAIN(did)%initialized = .true. + + end subroutine wrf_cpl_HYDRO_finescale + +! get the forcing data from WRF +subroutine wrf2l_finemesh(,its,ite,jts,jte, T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL0,QV_CURR0,LAI0,VEGFRA0, & + emiss0, albedo0 ) + use module_NoahMP_hrldas_driver, only: P8W, T_PHY, U_PHY, V_PHY, QV_CURR, RAINBL_tmp, LAI, VEGFRA, finemesh,finemesh_factor, & + emiss,albedo + + implicit none + real, domain(:,:),INTENT(IN) :: T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL0,QV_CURR0,LAI0,VEGFRA0, & + emiss0, albedo0, TSK0,HFX0, QFX0,LH0,GRDFLX0,SMSTAV0,SMSTOT0,SFCRUNOFF0, UDRUNOFF0, SNOWC0, SMOIS0, SH2O0, & + TSLB0, SNOW0,SNOWH0,CANWAT0,ACSNOM0,ACSNOW0,QSFC0,ISNOWXY0,TVXY0,TGXY0,CANICEXY0,CANLIQXY0,EAHXY0,TAHXY0,CMXY0, & + CHXY0,FWETXY0,SNEQVOXY0,ALBOLDXY0,QSNOWXY0,WSLAKEXY0,ZWTXY0,WAXY0,WTXY0,TSNOXY0,ZSNSOXY0,SNICEXY0,SNLIQXY0, & + LFMASSXY0,RTMASSXY0,STMASSXY0,WOODXY0,STBLCPXY0,FASTCPXY0,XLAIXY0,XSAIXY0,TAUSSXY0,SMOISEQ0,SMCWTDXY0,DEEPRECHXY0, & + RECHXY0, & + + integer, intent(in):: its,ite,jts,jte + call wrf2finegrid(T_PHY0(its:ite,jts:jte), T_PHY(:,1,:),ite-its+1,jte-jts+1,finemesh_factor) + call wrf2finegrid(U_PHY0(its:ite,jts:jte), U_PHY(:,1,:),ite-its+1,jte-jts+1,finemesh_factor) + call wrf2finegrid(V_PHY0(its:ite,jts:jte), V_PHY(:,1,:),ite-its+1,jte-jts+1,finemesh_factor) + call wrf2finegrid(p_hyd_w0(its:ite,jts:jte), P8W(:,1,:),ite-its+1,jte-jts+1,finemesh_factor) + call wrf2finegrid(RAINBL0(its:ite,jts:jte), RAINBL_tmp,ite-its+1,jte-jts+1,finemesh_factor) + call wrf2finegrid(QV_CURR0(its:ite,jts:jte), QV_CURR(:,1,:),ite-its+1,jte-jts+1,finemesh_factor) +! update some varialbes. + if(finemesh .ne. 1) then ! update the LAI and VEGFRA for each time step. Note: this is from the WRF grid. + call wrf2finegrid(albedo0(its:ite,jts:jte), albedo) + call wrf2finegrid(emiss0(its:ite,jts:jte), emiss) + call wrf2finegrid(LAI0(its:ite,jts:jte), LAI) + call wrf2finegrid(VEGFRA0(its:ite,jts:jte), VEGFRA) + endif +end subroutine wrf2l_finemesh + +subroutine l_finemesh2wrf(T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL0,QV_CURR0,LAI0,VEGFRA0,its,ite,jts,jte) + use module_NoahMP_hrldas_driver, only: P8W, T_PHY, U_PHY, V_PHY, QV_CURR, RAINBL_tmp, LAI, VEGFRA, finemesh,finemesh_factor + implicit none +!variable for output only + real,dimension(:,:), intent(out):: T2MVXY0,T2MBXY0,Q2MVXY0,Q2MBXY0,TRADXY0,NEEXY0,GPPXY0,NPPXY0,FVEGXY0,RUNSFXY0, & + RUNSBXY0,ECANXY0,EDIRXY0,ETRANXY0,FSAXY0,& + FIRAXY0,APARXY0,PSNXY0,SAVXY0,SAGXY0,RSSUNXY0,RSSHAXY0,BGAPXY0,WGAPXY0,TGVXY0,TGBXY0,CHVXY0,CHBXY0,SHGXY0,SHCXY0,SHBXY0, & + EVGXY0,EVBXY0,GHVXY0,GHBXY0,IRGXY0,IRCXY0,IRBXY0,TRXY0,EVCXY0,CHLEAFXY0,CHUCXY0,CHV2XY0,CHB2XY0 + + call finegrid2wrf(T2MVXY,T2MVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(T2MBXY,tt0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(FVEGXY,FVEGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(Q2MVXY,Q2MVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(Q2MBXY,Q2MBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + if(finemesh .ne. 1) then + call finegrid2wrf(TRADXY,TRADXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(NEEXY,NEEXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(GPPXY,GPPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(NPPXY,NPPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(RUNSFXY,RUNSFXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(RUNSBXY,RUNSBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(ECANXY,ECANXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(EDIRXY,EDIRXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(ETRANXY,ETRANXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(FSAXY,FSAXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(FIRAXY,FIRAXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(APARXY,APARXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(PSNXY,PSNXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(SAVXY,SAVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(SAGXY,SAGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(RSSUNXY,RSSUNXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(RSSHAXY,RSSHAXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(BGAPXY,BGAPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(WGAPXY,WGAPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(TGVXY,TGVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + + call finegrid2wrf(TGBXY,TGBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(CHVXY,CHVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(CHBXY,CHBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(SHGXY,SHGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(SHCXY,SHCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(SHBXY,SHBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(EVGXY,EVGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(EVBXY,EVBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(GHVXY,GHVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(GHBXY,GHBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(IRGXY,IRGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(IRCXY,IRCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(IRBXY,IRBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(TRXY,TRXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(EVCXY,EVCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(CHLEAFXY,CHLEAFXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(CHUCXY,CHUCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(CHV2XY,CHV2XY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + call finegrid2wrf(CHB2XY,CHB2XY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor) + endif +end subroutine l_finemesh2wrf + +subroutine wrf2finegrid(wrfGrid,fineGrid,ix,jx,AGGFACTRT) + implicit none + real, dimension(:,:), intent(in)::wrfGrid + real, dimension(:,:), intent(out)::fineGrid + integer:: i,j,ii,jj,ix,jx, AGGFACTRT + do j = 1, jx + do i = 1, ix + do ii =AGGFACTRT-1,0,-1 + do jj =AGGFACTRT-1,0,-1 + IXXRT=I*AGGFACTRT-ii + JYYRT=J*AGGFACTRT-jj + fineGrid(ixxrt,jyyrt) = wrfGrid(i,j) + enddo + enddo + enddo ! end do loop for ix + enddo ! end do loop for jx +end subroutine wrf2finegrid + +subroutine finegrid2wrf(fineGrid,wrfGrid,ix,jx,AGGFACTRT) + implicit none + real, dimension(:,:), intent(out)::wrfGrid + real, dimension(:,:), intent(in)::fineGrid + integer:: i,j,ii,jj,ix,jx, AGGFACTRT + do j = 1, jx + do i = 1, ix + wrfGrid(k,j) = 0.0 + do ii =AGGFACTRT-1,0,-1 + do jj =AGGFACTRT-1,0,-1 + IXXRT=I*AGGFACTRT-ii + JYYRT=J*AGGFACTRT-jj + wrfGrid(i,j) = wrfGrid(i,j) + fineGrid(ixxrt,jyyrt) + enddo + enddo + wrfGrid(i,j) = wrfGrid(i,j) / (AGGFACTRT*AGGFACTRT) + enddo ! end do loop for ix + enddo ! end do loop for jx +end subroutine finegrid2wrf + + + +!program drive rtland +! This subroutine will be used if the 4-layer Noah lsm is not used. + subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) +! input: z1,v1,kk1,z,ix,jx,kk +! output: vout +! interpolate based on soil layer: z1 and z +! z : soil layer of output variable. +! z1: array of soil layers of input variable. + implicit none + integer:: i,j,k + integer:: kk1, ix,jx,kk, vegtyp(ix,jx) + real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk) + + + do j = 1, jx + do i = 1, ix + do k = 1, kk + call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) + end do + end do + end do + end subroutine wrf2lsm + +! This subroutine will be used if the 4-layer Noah lsm is not used. + subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) +! input: z1,v1,kk1,z,ix,jx,kk +! output: vout +! interpolate based on soil layer: z1 and z +! z : soil layer of output variable. +! z1: array of soil layers of input variable. + implicit none + integer:: i,j,k + integer:: kk1, ix,jx,kk, vegtyp(ix,jx) + real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx) + + + do j = 1, jx + do i = 1, ix + do k = 1, kk + call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) + end do + end do + end do + end subroutine lsm2wrf + + subroutine interpLayer(inZ,inV,inK,outZ,outV) + implicit none + integer:: k, k1, k2 + integer :: inK + real:: inV(inK),inZ(inK) + real:: outV, outZ, w1, w2 + + if(outZ .le. inZ(1)) then + w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1)) + w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1)) + outV = inV(1)*w1-inV(2)*w2 + return + elseif(outZ .ge. inZ(inK)) then + w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) + w2 = (outZ-inZ(inK)) /(inZ(inK)-inZ(inK-1)) + outV = inV(inK)*w1 -inV(inK-1)* w2 + return + else + do k = 2, inK + if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then + k1 = k-1 + k2 = k + w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1)) + w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1)) + outV = inV(k2)*w1 + inV(k1)*w2 + return + end if + end do + endif + end subroutine interpLayer + + subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx) + implicit none + integer did, leng + parameter(leng=100) + integer :: i,j, nn, ix,jx + integer, dimension(ix,jx) :: soltyp, vegtyp + real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc + + + where(soltyp == 14) VEGTYP = 16 + where(VEGTYP == 16 ) soltyp = 14 + + RT_DOMAIN(did)%VEGTYP = vegtyp + +! input OV_ROUGH from OVROUGH.TBL +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + +#ifndef NCEP_WCOSS + open(71,file="HYDRO.TBL", form="formatted") +!read OV_ROUGH first + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(71) +#else + + open(13, form="formatted") +!read OV_ROUGH first + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(13) +#endif + +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) + call mpp_land_bcast_real(leng,xdum1) + call mpp_land_bcast_real(leng,MAXSMC) + call mpp_land_bcast_real(leng,refsmc) + call mpp_land_bcast_real(leng,wltsmc) +#endif + + rt_domain(did)%lksat = 0.0 + do j = 1, RT_DOMAIN(did)%jx + do i = 1, RT_DOMAIN(did)%ix + rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + IF(rt_domain(did)%VEGTYP(i,j) == 1 ) 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)) + ENDIF + end do + end do + + end subroutine lsm_wrf_input + +end module module_wrf_HYDRO diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F new file mode 100644 index 00000000..f8cc01e4 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F @@ -0,0 +1,57 @@ +! Program Name: +! 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: + +!2345678 +!ywGW subroutine wrf_drv_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte) + subroutine wrf_drv_HYDRO(HYDRO_dt,grid, its,ite,jts,jte) + use module_wrf_HYDRO, only: wrf_cpl_HYDRO + USE module_domain, ONLY : domain + USE module_configure, ONLY : grid_config_rec_type + implicit none + integer:: its,ite,jts,jte + real :: HYDRO_dt + TYPE ( domain ), INTENT(INOUT) :: grid +!ywGW TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags + TYPE ( grid_config_rec_type ) :: config_flags +! return + + if(grid%num_nests .lt. 1) then + +!ywGW call wrf_cpl_HYDRO(HYDRO_dt, grid, config_flags, its,ite,jts,jte) + call wrf_cpl_HYDRO(HYDRO_dt, grid, its,ite,jts,jte) + + endif + end subroutine wrf_drv_HYDRO + + + subroutine wrf_drv_HYDRO_ini(grid,its,ite,jts,jte) + use module_wrf_HYDRO, only: wrf_cpl_HYDRO + USE module_domain, ONLY : domain + implicit none + integer:: its,ite,jts,jte + TYPE ( domain ), INTENT(INOUT) :: grid + + if(grid%num_nests .lt. 1) then +! call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte) + endif + + end subroutine wrf_drv_HYDRO_ini + diff --git a/wrfv2_fire/hydro/Data_Rec/Makefile b/wrfv2_fire/hydro/Data_Rec/Makefile new file mode 100644 index 00000000..49ac4e92 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/Makefile @@ -0,0 +1,28 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = \ + module_namelist.o \ + module_RT_data.o \ + module_gw_gw2d_data.o + +all: $(OBJS) + +.F.o: + @echo "" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I../mod $(*).f + $(RMD) $(*).f + @echo "" + ar -r ../lib/libHYDRO.a $(@) + cp *.mod ../mod + +# Dependencies: +# + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc b/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc new file mode 100644 index 00000000..ff9f3007 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc @@ -0,0 +1,34 @@ + + type gw_field + integer :: ix, jx + integer :: allo_status = -99 + + real :: dx, dt + + integer, allocatable, dimension(:,:) :: ltype ! land-sfc type + real, allocatable, dimension(:,:) :: & + elev, & ! elev/bathymetry of sfc rel to sl (m) + bot, & ! elev. aquifer bottom rel to sl (m) + hycond, & ! hydraulic conductivity (m/s per m/m) + poros, & ! porosity (m3/m3) + compres, & ! compressibility (1/Pa) + ho ! head at start of timestep (m) + + real, allocatable, dimension(:,:) :: & + h, & ! head, after ghmcompute (m) + convgw, & ! convergence due to gw flow (m/s) + excess ! surface exceeding groundwater (mm) + + real, allocatable, dimension(:,:) :: & + qdarcyRT, & ! approximated flux between soil and groundwater for coupled simulations on routing grid + qsgwrt, & ! flux between soil and groundwater for coupled simulations on routing grid + qsgw, & ! flux between soil and groundwater for coupled simulations on lsm grid + qgw_chanrt ! flux between groundwater and channel + + real :: ebot, eocn + integer ::istep = 0 + + real :: its, ite, jts, jte + + end type gw_field + diff --git a/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F b/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F new file mode 100644 index 00000000..4b171683 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F @@ -0,0 +1,9 @@ +Module module_GW_baseflow_data + IMPLICIT NONE + INTEGER, PARAMETER :: max_domain=5 + +#include "gw_field_include.inc" + type (gw_field) :: gw2d(max_domain) + save gw2d + +end module module_GW_baseflow_data diff --git a/wrfv2_fire/hydro/Data_Rec/module_RT_data.F b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F new file mode 100644 index 00000000..196dd68d --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F @@ -0,0 +1,30 @@ +! Program Name: +! 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_RT_data + IMPLICIT NONE + INTEGER, PARAMETER :: max_domain=5 + +! define Routing data +#include "rt_include.inc" + TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN + save RT_DOMAIN + integer :: cur_did +end module module_RT_data diff --git a/wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F b/wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F new file mode 100644 index 00000000..20792b7c --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F @@ -0,0 +1,30 @@ +! Program Name: +! 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_gw_gw2d_data + IMPLICIT NONE + INTEGER, PARAMETER :: max_domain=5 + +#include "gw_field_include.inc" + type (gw_field) :: gw2d(max_domain) + save gw2d + +end module module_gw_gw2d_data diff --git a/wrfv2_fire/hydro/Data_Rec/module_namelist.F b/wrfv2_fire/hydro/Data_Rec/module_namelist.F new file mode 100644 index 00000000..66c6b212 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/module_namelist.F @@ -0,0 +1,410 @@ +! Program Name: +! 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_namelist + +#ifdef MPP_LAND + USE module_mpp_land +#endif + + IMPLICIT NONE + INTEGER, PARAMETER :: max_domain=5 + +#include "namelist.inc" + TYPE(namelist_rt_field) , dimension(max_domain) :: nlst_rt + save nlst_rt + +CONTAINS + + subroutine read_rt_nlst(nlst) + implicit none + + TYPE(namelist_rt_field) nlst + + integer ierr + integer:: RT_OPTION, CHANRTSWCRT, channel_option, & + SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & + GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & + sys_cpl, rst_typ, rst_bi_in, rst_bi_out, & + gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, gwsoilcpl, & + UDMP_OPT + real:: DTRT_TER,DTRT_CH,dxrt, gwChanCondConstIn, gwChanCondConstOut, gwIhShift + character(len=256) :: route_topo_f="" + character(len=256) :: route_chan_f="" + character(len=256) :: route_link_f="" + character(len=256) :: route_lake_f="" + character(len=256) :: route_direction_f="" + character(len=256) :: route_order_f="" + character(len=256) :: gwbasmskfil ="" + character(len=256) :: gwstrmfil ="" + character(len=256) :: geo_finegrid_flnm ="" + character(len=256) :: udmap_file ="" + character(len=256) :: GWBUCKPARM_file = "" + integer :: SOLVEG_INITSWC + real out_dt, rst_dt + character(len=256) :: RESTART_FILE = "" + logical :: GwPreDiag, GwSpinUp + integer :: split_output_count, order_to_write + integer :: igrid, iocflag + character(len=256) :: geo_static_flnm = "" + integer :: DEEPGWSPIN + + integer :: i + + + integer ::CHRTOUT_DOMAIN ! Netcdf point timeseries output at all channel points + integer ::CHRTOUT_GRID ! Netcdf grid of channel streamflow values + integer ::LSMOUT_DOMAIN ! Netcdf grid of variables passed between LSM and routing components + integer ::RTOUT_DOMAIN ! Netcdf grid of terrain routing variables on routing grid + integer :: output_gw + integer :: outlake + + +!!! add the following two dummy variables + integer :: NSOIL + real :: ZSOIL8(8) + + logical :: dir_e +#ifdef WRF_HYDRO_NUDGING + character(len=256) :: nudgingParamFile + character(len=256) :: netwkReExFile + logical :: readTimesliceParallel + logical :: temporalPersistence + character(len=256) :: nudgingLastObsFile +#endif + + namelist /HYDRO_nlist/ NSOIL, ZSOIL8,& + RESTART_FILE,SPLIT_OUTPUT_COUNT,IGRID,& + geo_static_flnm, & + out_dt, rst_dt, & + DEEPGWSPIN, SOLVEG_INITSWC, & + RT_OPTION, CHANRTSWCRT, channel_option, & + SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt_ter,dtrt_ch,dxrt,& + GwSpinCycles, GwPreCycles, GwSpinUp, GwPreDiag, GwPreDiagInterval, gwIhShift, & + GWBASESWCRT, gwChanCondSw, gwChanCondConstIn, gwChanCondConstOut , & + route_topo_f,route_chan_f,route_link_f,route_lake_f, & + route_direction_f,route_order_f,gwbasmskfil, geo_finegrid_flnm,& + gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, & + order_to_write , rst_typ, rst_bi_in, rst_bi_out, gwsoilcpl, & + CHRTOUT_DOMAIN,CHRTOUT_GRID,LSMOUT_DOMAIN,RTOUT_DOMAIN, output_gw, outlake, udmap_file, & + UDMP_OPT, GWBUCKPARM_file, iocflag + + UDMP_OPT = 0 + rst_bi_in = 0 + rst_bi_out = 0 + iocflag = 0 + + +#ifdef WRF_HYDRO_NUDGING + namelist /NUDGING_nlist/ nudgingParamFile, netwkReExFile, & + readTimesliceParallel, temporalPersistence, & + nudgingLastObsFile + ! Default values... + nudgingParamFile = "DOMAIN/nudgingParams.nc" + netwkReExFile = "DOMAIN/netwkReExFile.nc" + readTimesliceParallel = .true. + temporalPersistence = .true. + nudgingLastObsFile = "" +#endif + + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif +#ifndef NCEP_WCOSS + open(12, file="hydro.namelist", form="FORMATTED") +#else + open(12, form="FORMATTED") +#endif + read(12, HYDRO_nlist, iostat=ierr) + if(ierr .ne. 0) call hydro_stop("HYDRO_nlst namelist error in read_rt_nlst") + +#ifdef WRF_HYDRO_NUDGING + read(12, NUDGING_nlist, iostat=ierr) + if(ierr .ne. 0) call hydro_stop("NUDGING_nlst namelist error in read_rt_nlst") +#endif + close(12) + +#ifdef MPP_LAND + endif +#endif + +#ifdef HYDRO_REALTIME + if ( iocflag .eq. 4 ) RTOUT_DOMAIN = 0 + if ( (iocflag .gt. 0) .and. (CHRTOUT_DOMAIN .eq.1) .and. (channel_option .ne. 3) ) CHRTOUT_DOMAIN = 2 +#endif + +#ifdef MPP_LAND +! call mpp_land_bcast_real1(DT) + call mpp_land_bcast_int1(SPLIT_OUTPUT_COUNT) + call mpp_land_bcast_int1(IGRID) + call mpp_land_bcast_int1(iocflag) + call mpp_land_bcast_real1(out_dt) + call mpp_land_bcast_real1(rst_dt) + call mpp_land_bcast_int1(DEEPGWSPIN) + call mpp_land_bcast_int1(SOLVEG_INITSWC) +#endif + + +#ifdef MPP_LAND + call mpp_land_bcast_int1(nlst%NSOIL) + do i = 1, nlst%NSOIL + call mpp_land_bcast_real1(nlst%ZSOIL8(i)) + end do +#ifdef HYDRO_D + write(6,*) "nlst%NSOIL = ", nlst%NSOIL + write(6,*) "nlst%ZSOIL8 = ",nlst%ZSOIL8 +#endif +#endif + +! nlst%DT = DT + nlst%RESTART_FILE = RESTART_FILE + nlst%SPLIT_OUTPUT_COUNT = SPLIT_OUTPUT_COUNT + nlst%IGRID = IGRID + nlst%iocflag = iocflag + nlst%geo_static_flnm = geo_static_flnm + nlst%out_dt = out_dt + nlst%rst_dt = rst_dt + nlst%DEEPGWSPIN = DEEPGWSPIN + nlst%SOLVEG_INITSWC = SOLVEG_INITSWC + +#ifdef MPP_LAND + call mpp_land_bcast_char(256,nlst%RESTART_FILE) +#endif + + write(nlst%hgrid,'(I1)') igrid + + + if(RESTART_FILE .eq. "") rst_typ = 0 + + if(rst_bi_out .eq. 1) then +! This part works for intel not pgi +! inquire(directory='restart', exist=dir_e) + inquire(file='restart/.', exist=dir_e) + if(.not. dir_e) then + call system('mkdir restart') + endif + endif + + +#ifdef MPP_LAND + !bcast namelist variable. + call mpp_land_bcast_int1(rt_option) + call mpp_land_bcast_int1(CHANRTSWCRT) + call mpp_land_bcast_int1(channel_option) + call mpp_land_bcast_int1(SUBRTSWCRT) + call mpp_land_bcast_int1(OVRTSWCRT) + call mpp_land_bcast_int1(AGGFACTRT) + call mpp_land_bcast_real1(DTRT_TER) + call mpp_land_bcast_real1(DTRT_CH) + call mpp_land_bcast_real1(DXRT) + call mpp_land_bcast_real1(gwChanCondConstIn) + call mpp_land_bcast_real1(gwChanCondConstOut) + call mpp_land_bcast_real1(gwIhShift) + call mpp_land_bcast_int1(GWBASESWCRT) + call mpp_land_bcast_int1(GWSOILCPL) + call mpp_land_bcast_int1(gwChanCondSw) + call mpp_land_bcast_int1(GwSpinCycles) + call mpp_land_bcast_int1(GwPreCycles) + call mpp_land_bcast_log1(GwPreDiag) + call mpp_land_bcast_log1(GwSpinUp) + call mpp_land_bcast_int1(GwPreDiagInterval) + call mpp_land_bcast_int1(GW_RESTART) + call mpp_land_bcast_int1(RSTRT_SWC ) + call mpp_land_bcast_int1(TERADJ_SOLAR) + call mpp_land_bcast_int1(sys_cpl) + call mpp_land_bcast_int1(rst_typ) + call mpp_land_bcast_int1(rst_bi_in) + call mpp_land_bcast_int1(rst_bi_out) + call mpp_land_bcast_int1(order_to_write) + call mpp_land_bcast_int1(CHRTOUT_DOMAIN) + call mpp_land_bcast_int1(output_gw) + call mpp_land_bcast_int1(outlake) + call mpp_land_bcast_int1(CHRTOUT_GRID) + call mpp_land_bcast_int1(LSMOUT_DOMAIN) + call mpp_land_bcast_int1(RTOUT_DOMAIN) + call mpp_land_bcast_int1(UDMP_OPT) +#ifdef WRF_HYDRO_NUDGING + call mpp_land_bcast_char(256, nudgingParamFile ) + call mpp_land_bcast_char(256, netwkReExFile ) + call mpp_land_bcast_char(256, nudgingLastObsFile) + call mpp_land_bcast_log1(readTimesliceParallel) + call mpp_land_bcast_log1(temporalPersistence) +#endif +#endif /* MPP_LAND */ + + + +! run Rapid + if(channel_option .eq. 4) then + CHANRTSWCRT = 0 + OVRTSWCRT = 0 + SUBRTSWCRT = 0 + endif + + nlst%CHRTOUT_DOMAIN = CHRTOUT_DOMAIN + nlst%output_gw = output_gw + nlst%outlake = outlake + nlst%CHRTOUT_GRID = CHRTOUT_GRID + nlst%LSMOUT_DOMAIN = LSMOUT_DOMAIN + nlst%RTOUT_DOMAIN = RTOUT_DOMAIN + nlst%RT_OPTION = RT_OPTION + nlst%CHANRTSWCRT = CHANRTSWCRT + nlst%GW_RESTART = GW_RESTART + nlst%RSTRT_SWC = RSTRT_SWC + nlst%channel_option = channel_option + nlst%DTRT_TER = DTRT_TER + nlst%DTRT_CH = DTRT_CH + nlst%DTCT = DTRT_CH ! small time step for grid based channel routing + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + if(nlst%DT .lt. DTRT_CH) then + print*, "nlst%DT, DTRT_CH = ",nlst%DT, DTRT_CH + print*, "reset DTRT_CH=nlst%DT " + DTRT_CH=nlst%DT + endif + if(nlst%DT .lt. DTRT_TER) then + print*, "nlst%DT, DTRT_TER = ",nlst%DT, DTRT_TER + print*, "reset DTRT_TER=nlst%DT " + DTRT_TER=nlst%DT + endif + if(nlst%DT/DTRT_TER .ne. real(int(nlst%DT) / int(DTRT_TER)) ) then + print*, "nlst%DT, DTRT_TER = ",nlst%DT, DTRT_TER + call hydro_stop("module_namelist: DT not a multiple of DTRT_TER") + endif + if(nlst%DT/DTRT_CH .ne. real(int(nlst%DT) / int(DTRT_CH)) ) then + print*, "nlst%DT, DTRT_CH = ",nlst%DT, DTRT_CH + call hydro_stop("module_namelist: DT not a multiple of DTRT_CH") + endif +#ifdef MPP_LAND + endif +#endif + + nlst%SUBRTSWCRT = SUBRTSWCRT + nlst%OVRTSWCRT = OVRTSWCRT + nlst%dxrt0 = dxrt + nlst%AGGFACTRT = AGGFACTRT + nlst%GWBASESWCRT = GWBASESWCRT + nlst%GWSOILCPL= GWSOILCPL + nlst%gwChanCondSw = gwChanCondSw + nlst%gwChanCondConstIn = gwChanCondConstIn + nlst%gwChanCondConstOut = gwChanCondConstOut + nlst%gwIhShift = gwIhShift + nlst%GwSpinCycles = GwSpinCycles + nlst%GwPreCycles = GwPreCycles + nlst%GwPreDiag = GwPreDiag + nlst%GwSpinUp = GwSpinUp + nlst%GwPreDiagInterval = GwPreDiagInterval + nlst%TERADJ_SOLAR = TERADJ_SOLAR + nlst%sys_cpl = sys_cpl + nlst%rst_typ = rst_typ + nlst%rst_bi_in = rst_bi_in + nlst%rst_bi_out = rst_bi_out + nlst%order_to_write = order_to_write +! files + nlst%route_topo_f = route_topo_f + nlst%route_chan_f = route_chan_f + nlst%route_link_f = route_link_f + nlst%route_lake_f =route_lake_f + nlst%route_direction_f = route_direction_f + nlst%route_order_f = route_order_f + nlst%gwbasmskfil = gwbasmskfil + nlst%gwstrmfil = gwstrmfil + nlst%geo_finegrid_flnm = geo_finegrid_flnm + nlst%udmap_file = udmap_file + nlst%UDMP_OPT = UDMP_OPT + nlst%GWBUCKPARM_file = GWBUCKPARM_file +#ifdef WRF_HYDRO_NUDGING + nlst%nudgingParamFile = nudgingParamFile + nlst%netWkReExFile = netWkReExFile + nlst%readTimesliceParallel = readTimesliceParallel + nlst%temporalPersistence = temporalPersistence + nlst%nudgingLastObsFile = nudgingLastObsFile +#endif + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif +#ifdef HYDRO_D + write(6,*) "output of the namelist file " + write(6,*) "nlst%udmap_file ", trim(nlst%udmap_file) + write(6,*) "nlst%UDMP_OPT ", nlst%UDMP_OPT + write(6,*) " nlst%RT_OPTION ", RT_OPTION + write(6,*) " nlst%CHANRTSWCRT ", CHANRTSWCRT + write(6,*) " nlst%GW_RESTART ", GW_RESTART + write(6,*) " nlst%RSTRT_SWC ", RSTRT_SWC + write(6,*) " nlst%channel_option ", channel_option + write(6,*) " nlst%DTRT_TER ", DTRT_TER + write(6,*) " nlst%DTRT_CH ", DTRT_CH + write(6,*) " nlst%SUBRTSWCRT ", SUBRTSWCRT + write(6,*) " nlst%OVRTSWCRT ", OVRTSWCRT + write(6,*) " nlst%dxrt0 ", dxrt + write(6,*) " nlst%AGGFACTRT ", AGGFACTRT + write(6,*) " nlst%GWBASESWCRT ", GWBASESWCRT + write(6,*) " nlst%GWSOILCPL ", GWSOILCPL + write(6,*) " nlst%gwChanCondSw ", gwChanCondSw + write(6,*) " nlst%gwChanCondConstIn ", gwChanCondConstIn + write(6,*) " nlst%gwChanCondConstOut ", gwChanCondConstOut + write(6,*) " nlst%gwIhShift ", gwIhShift + write(6,*) " nlst%GwSpinCycles ", GwSpinCycles + write(6,*) " nlst%GwPreDiag ", GwPreDiag + write(6,*) " nlst%GwPreDiagInterval ", GwPreDiagInterval + write(6,*) " nlst%TERADJ_SOLAR ", TERADJ_SOLAR + write(6,*) " nlst%sys_cpl ", sys_cpl + write(6,*) " nlst%rst_typ ", rst_typ + write(6,*) " nlst%order_to_write ", order_to_write + write(6,*) " nlst%route_topo_f ", route_topo_f + write(6,*) " nlst%route_chan_f ", route_chan_f + write(6,*) " nlst%route_link_f ", route_link_f + write(6,*) " nlst%route_lake_f ",route_lake_f + write(6,*) " nlst%route_direction_f ", route_direction_f + write(6,*) " nlst%route_order_f ", route_order_f + write(6,*) " nlst%gwbasmskfil ", gwbasmskfil + write(6,*) " nlst%gwstrmfil ", gwstrmfil + write(6,*) " nlst%geo_finegrid_flnm ", geo_finegrid_flnm +#ifdef WRF_HYDRO_NUDGING + write(6,*) " nlst%nudgingParamFile", trim(nudgingParamFile) + write(6,*) " nlst%netWkReExFile", trim(netWkReExFile) + write(6,*) " nlst%readTimesliceParallel", readTimesliceParallel + write(6,*) " nlst%temporalPersistence", temporalPersistence + write(6,*) " nlst%nudgingLastObsFile", trim(nudgingLastObsFile) +#endif +#endif /* HYDRO_D */ +#ifdef MPP_LAND + endif +#endif + +#ifdef MPP_LAND + !bcast other variable. + call mpp_land_bcast_real1(nlst%dt) +#endif + +! derive rtFlag + nlst%rtFlag = 1 + if(channel_option .eq. 4) nlst%rtFlag = 0 +! if(CHANRTSWCRT .eq. 0 .and. SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0 + if(SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0 + return + end subroutine read_rt_nlst + + +end module module_namelist diff --git a/wrfv2_fire/hydro/Data_Rec/namelist.inc b/wrfv2_fire/hydro/Data_Rec/namelist.inc new file mode 100644 index 00000000..f7ba7c5f --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/namelist.inc @@ -0,0 +1,65 @@ + TYPE namelist_rt_field + + integer :: nsoil, SOLVEG_INITSWC + real,allocatable,dimension(:) :: ZSOIL8 + real out_dt, rst_dt, dt + integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN + character(len=256) :: restart_file = "" + 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 = "" + integer :: DEEPGWSPIN + integer :: order_to_write, rst_typ + character(len=256) :: upmap_file = "" ! user defined mapping file for NHDPLUS + +! additional character + character :: hgrid + character(len=19) :: olddate="123456" + character(len=19) :: startdate="123456" + character(len=19) :: sincedate="123456" + + integer :: iocflag ! used for NCEP REALTIME OUTPUT + + + integer:: RT_OPTION, CHANRTSWCRT, channel_option, & + SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & + GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & + sys_cpl, gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, & + gwsoilcpl, UDMP_OPT + logical:: GwPreDiag, GwSpinUp + real:: DTRT_TER,DTRT_CH, DTCT, dxrt0, gwChanCondConstIn, gwChanCondConstOut, gwIhShift + character(len=256) :: route_topo_f="" + character(len=256) :: route_chan_f="" + character(len=256) :: route_link_f="" + character(len=256) :: route_lake_f="" + character(len=256) :: route_direction_f="" + character(len=256) :: route_order_f="" + character(len=256) :: gwbasmskfil ="" + character(len=256) :: gwstrmfil ="" + character(len=256) :: geo_finegrid_flnm ="" + character(len=256) :: udmap_file ="" + character(len=256) :: GWBUCKPARM_file = "" + + integer ::frxst_pts_out ! ASCII point timeseries output at user specified points + integer ::CHRTOUT_DOMAIN ! Netcdf point timeseries output at all channel points + integer ::CHRTOUT_GRID ! Netcdf grid of channel streamflow values + integer ::LSMOUT_DOMAIN ! Netcdf grid of variables passed between LSM and routing components + integer ::RTOUT_DOMAIN ! Netcdf grid of terrain routing variables on routing grid + integer ::output_gw ! Netcdf grid of GW + integer ::outlake ! Netcdf grid of lake + integer :: rtFlag + +#ifdef WRF_HYDRO_NUDGING + character(len=256) :: nudgingParamFile + character(len=256) :: netwkReExFile + logical :: readTimesliceParallel + logical :: temporalPersistence + character(len=256) :: nudgingLastObsFile +#endif + + + END TYPE namelist_rt_field + diff --git a/wrfv2_fire/hydro/Data_Rec/rt_include.inc b/wrfv2_fire/hydro/Data_Rec/rt_include.inc new file mode 100644 index 00000000..dbc1e853 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/rt_include.inc @@ -0,0 +1,218 @@ + TYPE RT_FIELD + INTEGER :: IX, JX + logical initialized + logical restQSTRM + REAL :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT + REAL :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT + REAL :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC + REAL :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT + INTEGER :: IXRT,JXRT,vegct + INTEGER :: AGGFACYRT, AGGFACXRT, KRTel_option, FORC_TYP + INTEGER :: SATLYRCHKRT,DT_FRACRT + INTEGER :: LAKE_CT, STRM_CT + REAL :: RETDEP_CHAN ! Channel retention depth + INTEGER :: NLINKS !maximum number of unique links in channel + INTEGER :: GNLINKS !maximum number of unique links in channel for parallel computation + INTEGER :: NLAKES !number of lakes modeled + INTEGER :: NLINKSL !maximum number of links using linked routing + INTEGER :: MAXORDER !maximum stream order + integer :: timestep_flag ! 1 cold start run else continue run + + INTEGER :: GNLINKSL, linklsS, linklsE , nlinksize !## for reach based channel routing + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR ROUTING + INTEGER, allocatable, DIMENSION(:,:) :: CH_NETRT !-- keeps track of the 0-1 channel network + INTEGER, allocatable, DIMENSION(:,:) :: CH_LNKRT !-- linked routing grid (should combine with CH_NETRT.. redundant Gochis!) + + + INTEGER, allocatable, DIMENSION(:,:) :: CH_NETLNK, GCH_NETLNK !-- assigns a unique value to each channel gridpoint, called links + REAL, allocatable, DIMENSION(:,:) :: LATVAL,LONVAL !-- lat lon + REAL, allocatable, DIMENSION(:,:) :: TERRAIN + REAL, allocatable, DIMENSION(:,:) :: landRunOff ! used for NHDPLUS only + REAL, allocatable, DIMENSION(:) :: CHLAT,CHLON ! channel lat and lon + ! INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, BASIN_MSK,LAK_1K + INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, LAK_1K + INTEGER, allocatable, DIMENSION(:,:) :: g_LAK_1K + ! REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT, QSUBBDRYTRT + REAL :: QSUBBDRYTRT + REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT + REAL, allocatable, DIMENSION(:,:,:) :: SO8RT + INTEGER, allocatable, DIMENSION(:,:,:) :: SO8RT_D, SO8LD_D + REAL, allocatable, DIMENSION(:,:) :: SO8LD_Vmax + REAL Vmax + REAL, allocatable, DIMENSION(:,:) :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT + REAL, allocatable, DIMENSION(:,:) :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC + REAL, allocatable, DIMENSION(:,:) :: QSUBRT,ZWATTABLRT,QSUBBDRYRT,SOLDEPRT + REAL, allocatable, DIMENSION(:,:) :: SUB_RESID + REAL, allocatable, DIMENSION(:,:) :: q_sfcflx_x,q_sfcflx_y + INTEGER, allocatable, DIMENSION(:) :: map_l2g, map_g2l + + INTEGER :: nToInd + INTEGER, allocatable, DIMENSION(:) :: toNodeInd + INTEGER, allocatable, DIMENSION(:,:) :: gtoNode + +! temp arrary cwatavail + real, allocatable, DIMENSION(:,:,:) :: SMCREFRT +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR GW/Baseflow + INTEGER :: numbasns + INTEGER :: gnumbasns + INTEGER, allocatable, DIMENSION(:) :: basnsInd ! basin index for tile + INTEGER, allocatable, DIMENSION(:,:) :: GWSUBBASMSK !GW basin mask grid + REAL, allocatable, DIMENSION(:,:) :: qinflowbase !strm inflow/baseflow from GW + REAL, allocatable, DIMENSION(:,:) :: SOLDRAIN !time-step drainage + INTEGER, allocatable, DIMENSION(:,:) :: gw_strm_msk !GW basin mask grid + INTEGER, allocatable, DIMENSION(:,:) :: gw_strm_msk_lind !GW basin mask grid tile maping index + REAL, allocatable, DIMENSION(:) :: z_gwsubbas !depth in GW bucket + REAL, allocatable, DIMENSION(:) :: qin_gwsubbas !flow to GW bucket + REAL, allocatable, DIMENSION(:) :: qout_gwsubbas!flow from GW bucket + REAL, allocatable, DIMENSION(:) :: gwbas_pix_ct !ct of strm pixels in + REAL, allocatable, DIMENSION(:) :: basns_area !basin area + REAL, allocatable, DIMENSION(:) :: node_area !nodes area + + REAL, allocatable, DIMENSION(:) :: z_q_bas_parm !GW bucket disch params + INTEGER, allocatable, DIMENSION(:) :: nhdBuckMask ! bucket mask for NHDPLUS + INTEGER, allocatable, DIMENSION(:) :: ct2_bas !ct of lnd pixels in basn + REAL, allocatable, DIMENSION(:) :: bas_pcp !sub-basin avg'd pcp + INTEGER :: bas + INTEGER, allocatable, DIMENSION(:) :: bas_id + CHARACTER(len=19) :: header + CHARACTER(len=1) :: jnk + REAL, allocatable, DIMENSION(:) :: gw_buck_coeff,gw_buck_exp,z_max !GW bucket parameters +!DJG Switch for Deep Sat GW Init: + INTEGER :: DEEPGWSPIN !Switch to setup deep GW spinp +!BF Variables for gw2d + integer, allocatable, dimension(:,:) :: soiltyp, soiltypRT + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG,DNY VARIABLES FOR CHANNEL ROUTING +!-- channel params + INTEGER, allocatable, DIMENSION(:) :: LINK !channel link + INTEGER, allocatable, DIMENSION(:) :: TO_NODE !link's to node + INTEGER, allocatable, DIMENSION(:) :: FROM_NODE !link's from node + INTEGER, allocatable, DIMENSION(:) :: ORDER !link's order + INTEGER, allocatable, DIMENSION(:) :: STRMFRXSTPTS !frxst point flag + CHARACTER(len=15), allocatable, DIMENSION(:) :: gages + ! 123456789012345 + CHARACTER(len=15) :: gageMiss = ' ' +! CHARACTER(len=15) :: gageMiss = ' -9999' + + INTEGER, allocatable, DIMENSION(:) :: TYPEL !type of link Muskingum: 0 strm 1 lake + !-- Diffusion: 0 edge or pour; 1 interior; 2 lake + INTEGER, allocatable, DIMENSION(:) :: TYPEN !type of link 0 strm 1 lake + REAL, allocatable, DIMENSION(:) :: QLAKEI !lake inflow in difussion scheme + REAL, allocatable, DIMENSION(:) :: QLAKEO !lake outflow in difussion scheme + INTEGER, allocatable, DIMENSION(:) :: LAKENODE !which nodes flow into which lakes + INTEGER, allocatable, DIMENSION(:) :: LINKID ! id of links on linked routing + REAL, allocatable, DIMENSION(:) :: CVOL ! channel volume + INTEGER, allocatable, DIMENSION(:,:) :: pnode !parent nodes : start from 2 + integer :: maxv_p ! array size for second column of the pnode + + REAL, allocatable, DIMENSION(:) :: MUSK, MUSX !muskingum params + REAL, allocatable, DIMENSION(:) :: CHANLEN !link length + REAL, allocatable, DIMENSION(:) :: MannN !mannings N + REAL, allocatable, DIMENSION(:) :: So !link slope + REAL, allocatable, DIMENSION(:) :: ChSSlp, Bw !trapezoid link params + REAL, allocatable, DIMENSION(:,:) :: QLINK !flow in link +#ifdef WRF_HYDRO_NUDGING + REAL, allocatable, DIMENSION(:) :: nudge !difference between modeled and DA adj link flow +#endif + REAL, allocatable, DIMENSION(:) :: HLINK !head in link + REAL, allocatable, DIMENSION(:) :: ZELEV !elevation of nodes for channel + INTEGER, allocatable, DIMENSION(:) :: CHANXI,CHANYJ !map chan to fine grid + REAL, DIMENSION(50) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table + + REAL, allocatable, DIMENSION(:) :: RESHT !reservoir height +!-- lake params + INTEGER, allocatable, DIMENSION(:) :: LAKEIDA !id of lakes in routlink file + INTEGER, allocatable, DIMENSION(:) :: LAKEIDM !id of LAKES Modeled in LAKEPARM.nc or tbl + REAL, allocatable, DIMENSION(:) :: HRZAREA !horizontal extent of lake, km^2 + REAL, allocatable, DIMENSION(:) :: WEIRL !overtop weir length (m) + REAL, allocatable, DIMENSION(:) :: ORIFICEC !coefficient of orifice + REAL, allocatable, DIMENSION(:) :: ORIFICEA !orifice opening area (m^2) + REAL, allocatable, DIMENSION(:) :: ORIFICEE !orifice elevation (m) + REAL, allocatable, DIMENSION(:) :: LATLAKE, LONLAKE,ELEVLAKE ! lake info + + INTEGER, allocatable, DIMENSION(:) :: LAKEIDX ! integer index for lakes, mapped to linkid + +!!! accumulated variables for reach beased rt + REAL, allocatable, DIMENSION(:) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket + !REAL, allocatable, DIMENSION(:) :: qqLndRunOff, qqStrmvolrt, qqBucket + REAL, allocatable, DIMENSION(:) :: QLateral, velocity + +#ifdef MPP_LAND + INTEGER, allocatable, DIMENSION(:) :: lake_index,nlinks_index + INTEGER, allocatable, DIMENSION(:,:) :: Link_location + INTEGER, allocatable, DIMENSION(:) :: LLINKID + integer mpp_nlinks, yw_mpp_nlinks, LNLINKSL +#endif + INTEGER, allocatable, DIMENSION(:,:) :: CH_LNKRT_SL !-- reach based links used for mapping + + + REAL, allocatable, DIMENSION(:,:) :: OVROUGHRTFAC,RETDEPRTFAC + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR AGGREGATION/DISAGGREGATION + REAL, allocatable, DIMENSION(:,:,:) :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT,SICE + REAL, allocatable, DIMENSION(:,:) :: INFXSAGGRT + REAL, allocatable, DIMENSION(:,:) :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_TS,LAKE_INFLORT_TS + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM + REAL, allocatable, DIMENSION(:,:) :: INFXSWGT, ywtmp + REAL, allocatable, DIMENSION(:) :: SMCAGGRT,STCAGGRT,SH2OAGGRT + REAL :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT + REAL, allocatable, DIMENSION(:,:,:) :: dist ! 8 direction of distance +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR ONLINE MASS BALANCE CALCULATION + REAL(KIND=8) :: DCMC,DSWE,DACRAIN,DSFCEVP,DCANEVP,DEDIR,DETT,DEPND,DESNO,DSFCRNFF + REAL(KIND=8) :: DSMCTOT,RESID,SUMEVP,DUG1RNFF,DUG2RNFF,SMCTOT1,SMCTOT2,DETP + REAL(KIND=8) :: suminfxsrt,suminfxs1,suminfxs2,dprcp_ts + REAL(KIND=8) :: CHAN_IN1,CHAN_IN2,LAKE_IN1,LAKE_IN2,zzz, CHAN_STOR,CHAN_OUT + REAL(KIND=8) :: CHAN_INV,LAKE_INV !-channel and lake inflow in volume + REAL(KIND=8) :: DQBDRY + REAL :: QSTRMVOLTRT1,LAKE_INFLOTRT1,QBDRYTOT1,LSMVOL + REAL(KIND=8), allocatable, DIMENSION(:) :: DSMC,SMCRTCHK + REAL(KIND=8), allocatable, DIMENSION(:,:) :: CMC_INIT,SWE_INIT +! REAL(KIND=8), allocatable, DIMENSION(:,:,:) :: SMC_INIT + REAL(KIND=8) :: SMC_INIT,SMC_FINAL,resid2,resid1 + REAL(KIND=8) :: chcksm1,chcksm2,CMC1,CMC2,prcp_in,ETATOT,dsmctot_av + + integer :: g_ixrt,g_jxrt,flag + integer :: allo_status = -99 + integer iywtmp + + +!-- lake params + REAL, allocatable, DIMENSION(:) :: LAKEMAXH !maximum depth (m) + REAL, allocatable, DIMENSION(:) :: WEIRC !coeff of overtop weir + REAL, allocatable, DIMENSION(:) :: WEIRH !depth of Lake coef + + + + +!DJG Modified namelist for routing and agg. variables + real Z_tmp + + !!! define land surface grid variables + REAL, allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX + REAL, allocatable, DIMENSION(:,:) :: SMCMAX1,SMCWLT1,SMCREF1 + INTEGER, allocatable, DIMENSION(:,:) :: VEGTYP + REAL, allocatable, DIMENSION(:) :: SLDPTH + +!!! define constant/parameter + real :: ov_rough(50), ZSOIL(100) +! out_counts: couput counts for current run. +! his_out_counts: used for channel routing output and special for restart. +! his_out_counts = previous run + out_counts + integer :: out_counts, rst_counts, his_out_counts + + REAL, allocatable, DIMENSION(:,:) :: lat_lsm, lon_lsm + REAL, allocatable, DIMENSION(:,:,:) :: dist_lsm + + END TYPE RT_FIELD diff --git a/wrfv2_fire/hydro/HYDRO_drv/Makefile b/wrfv2_fire/hydro/HYDRO_drv/Makefile new file mode 100644 index 00000000..0b92dda7 --- /dev/null +++ b/wrfv2_fire/hydro/HYDRO_drv/Makefile @@ -0,0 +1,29 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = \ + module_HYDRO_drv.o +all: $(OBJS) + +.F.o: + @echo "" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f +# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) -I../mod $(*).f +# $(RMD) $(*).f + @echo "" + ar -r ../lib/libHYDRO.a $(@) + cp *.mod ../mod + +# +# Dependencies: +# +module_HYDRO_drv.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_gw_gw2d_data.o \ + ../Routing/module_GW_baseflow.o ../Routing/module_HYDRO_utils.o ../Routing/module_HYDRO_io.o ../Routing/module_RT.o + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F new file mode 100644 index 00000000..15b43347 --- /dev/null +++ b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F @@ -0,0 +1,1665 @@ +! Program Name: +! 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_HYDRO_drv +#ifdef MPP_LAND + use module_HYDRO_io, only: output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd, & + restart_out_bi, restart_in_bi, mpp_output_chrt2, mpp_output_lakes2 + USE module_mpp_land +#else + use module_HYDRO_io, only: output_rt, output_chrt, output_chrt2, output_lakes +#endif + use module_HYDRO_io, only: sub_output_gw, restart_out_nc, restart_in_nc, & + get_file_dimension ,get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, & + output_lsm, output_GW_Diag + use module_HYDRO_io, only : output_lakes2 + use module_rt_data, only: rt_domain + use module_GW_baseflow + use module_gw_gw2d + use module_gw_gw2d_data, only: gw2d + use module_channel_routing, only: drive_channel, drive_channel_rsl + use module_namelist, only: nlst_rt, read_rt_nlst + use module_routing, only: getChanDim, landrt_ini + use module_HYDRO_utils +! use module_namelist + use module_lsm_forcing, only: geth_newdate +#ifdef WRF_HYDRO_NUDGING + use module_stream_nudging, only: init_stream_nudging +#endif + + use module_UDMAP, only: get_basn_area_nhd + + implicit none + +#ifdef HYDRO_D + real :: timeOr = 0 + real :: timeSr = 0 + real :: timeCr = 0 + real :: timeGW = 0 + integer :: clock_count_1 = 0 + integer :: clock_count_2 = 0 + integer :: clock_rate = 0 +#endif + + + + contains + subroutine HYDRO_rst_out(did) +#ifdef WRF_HYDRO_NUDGING + use module_stream_nudging, only: output_nudging_last_obs +#endif + implicit none + integer:: rst_out + integer did, outflag + character(len=19) out_date +#ifdef MPP_LAND + character(len=19) str_tmp +#endif + rst_out = -99 +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + if(nlst_rt(did)%dt .gt. nlst_rt(did)%rst_dt*60) then + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%rst_counts)) + else + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%rst_dt*60*rt_domain(did)%rst_counts)) + endif + if ( (nlst_rt(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst_rt(did)%olddate(1:19)) ) then + rst_out = 99 + rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 + endif +! restart every month automatically. + if ( (nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. & + (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00") .and. & + (nlst_rt(did)%rst_dt .le. 0) ) rst_out = 99 + +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(rst_out) +#endif + if(rst_out .gt. 0) then +#ifdef MPP_LAND + if(nlst_rt(did)%rst_bi_out .eq. 1) then + if(my_id .lt. 10) then + write(str_tmp,'(I1)') my_id + else if(my_id .lt. 100) then + write(str_tmp,'(I2)') my_id + else if(my_id .lt. 1000) then + write(str_tmp,'(I3)') my_id + else if(my_id .lt. 10000) then + write(str_tmp,'(I4)') my_id + else if(my_id .lt. 100000) then + write(str_tmp,'(I5)') my_id + else + continue + endif + call mpp_land_bcast_char(16,nlst_rt(did)%olddate(1:16)) + call RESTART_OUT_bi(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst_rt(did)%hgrid)//"."//trim(str_tmp)), did) + else +#endif + call RESTART_OUT_nc(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst_rt(did)%hgrid)), did) +#ifdef MPP_LAND + endif +#endif + +#ifdef WRF_HYDRO_NUDGING + call output_nudging_last_obs !! only does something if temporalPersistence==TRUE +#endif + endif + + + end subroutine HYDRO_rst_out + + subroutine HYDRO_out(did) + + implicit none + integer did, outflag, rtflag + character(len=19) out_date + integer :: Kt, ounit, i + real, dimension(RT_DOMAIN(did)%NLINKS,2) :: str_out + real, dimension(RT_DOMAIN(did)%NLINKS) :: vel_out + +! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & +! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & +! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & +! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & +! qfx_tmp, prcp_out_tmp, etpndx_tmp + + outflag = -99 + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + if(nlst_rt(did)%olddate(1:19) .eq. nlst_rt(did)%startdate(1:19) .and. rt_domain(did)%his_out_counts .eq. 0) then +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts +#else + write(78,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts +#endif +#endif + outflag = 99 + else + if(nlst_rt(did)%dt .gt. nlst_rt(did)%out_dt*60) then + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%out_counts)) + else + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%out_dt*60*rt_domain(did)%out_counts)) + endif + if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19) +#else + write(78,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19) +#endif +#endif + outflag = 99 + endif + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(outflag) +#endif + + call HYDRO_rst_out(did) + + if (outflag .lt. 0) return + + rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 + + rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 + + if(nlst_rt(did)%out_dt*60 .gt. nlst_rt(did)%DT) then + kt = rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60/nlst_rt(did)%DT + else + kt = rt_domain(did)%his_out_counts + endif + +! jump the ouput for the initial time when it has restart file from routing. + rtflag = -99 +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then +#ifndef NCEP_WCOSS + print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) +#else + write(78,*) "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) +#endif + rtflag = 1 + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(rtflag) +#endif + + +!yw keep the initial time otuput for debug + if(rtflag == 1) then + rt_domain(did)%restQSTRM = .false. !!! do not reset QSTRM.. at initial time. +#ifndef HYDRO_REALTIME + return ! jump the initial time output for routing restart +#endif + endif + + + if(nlst_rt(did)%LSMOUT_DOMAIN .eq. 1) & + call output_lsm(trim(nlst_rt(did)%olddate(1:4)//nlst_rt(did)%olddate(6:7)//nlst_rt(did)%olddate(9:10) & + //nlst_rt(did)%olddate(12:13)//nlst_rt(did)%olddate(15:16)// & + ".LSMOUT_DOMAIN"//trim(nlst_rt(did)%hgrid)), & + did) + + + + if(nlst_rt(did)%SUBRTSWCRT .gt. 0 & + .or. nlst_rt(did)%OVRTSWCRT .gt. 0 & + .or. nlst_rt(did)%GWBASESWCRT .gt. 0 ) then + + + + if(nlst_rt(did)%RTOUT_DOMAIN .eq. 1) & + call output_rt( & + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & + nlst_rt(did)%nsoil, & +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& + nlst_rt(did)%sincedate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& + RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SMCRT,& + RT_DOMAIN(did)%SUB_RESID, & + RT_DOMAIN(did)%q_sfcflx_x,RT_DOMAIN(did)%q_sfcflx_y,& + RT_DOMAIN(did)%soxrt,RT_DOMAIN(did)%soyrt,& + RT_DOMAIN(did)%QSTRMVOLRT,RT_DOMAIN(did)%SFCHEADSUBRT, & + nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT,& + RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,& + RT_DOMAIN(did)%LONVAL,RT_DOMAIN(did)%dist,nlst_rt(did)%RTOUT_DOMAIN,& + RT_DOMAIN(did)%QBDRYRT & +#ifdef HYDRO_REALTIME + , nlst_rt(did)%iocflag & +#endif + ) + + + + + if(nlst_rt(did)%GWBASESWCRT .eq. 3) then + + if(nlst_rt(did)%output_gw .eq. 1) & + call sub_output_gw( & + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & + nlst_rt(did)%nsoil, & +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & + nlst_rt(did)%sincedate, nlst_rt(did)%olddate, & + gw2d(did)%h, RT_DOMAIN(did)%SMCRT, & + gw2d(did)%convgw, gw2d(did)%excess, & + gw2d(did)%qsgwrt, gw2d(did)%qgw_chanrt, & + nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, & + RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL, & + RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist, & + nlst_rt(did)%output_gw) + + endif +! BF end gw2d output section + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "before call output_chrt" + call flush(6) +#else + write(78,*) "before call output_chrt" +#endif +#endif + + if (nlst_rt(did)%CHANRTSWCRT.eq.1.or.nlst_rt(did)%CHANRTSWCRT.eq.2) then + +!ADCHANGE: Change values for within lake reaches to NA + str_out = RT_DOMAIN(did)%QLINK + vel_out = RT_DOMAIN(did)%velocity + +#ifdef HYDRO_REALTIME + if (RT_DOMAIN(did)%NLAKES .gt. 0) then + do i=1,RT_DOMAIN(did)%NLINKS + if (RT_DOMAIN(did)%TYPEL(i) .eq. 2) then + str_out(i,1) = -9.E15 + vel_out(i) = -9.E15 + endif + end do + endif +#endif +!ADCHANGE: End + + if(nlst_rt(did)%CHRTOUT_DOMAIN .eq. 1) then +#ifdef MPP_LAND + call mpp_output_chrt(rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, & +#else + call output_chrt( & +#endif + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & + nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& + RT_DOMAIN(did)%CHLAT, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & + !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & + str_out, nlst_rt(did)%DT,Kt, & + RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write, & + RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option, & + rt_domain(did)%gages, rt_domain(did)%gageMiss, & + nlst_rt(did)%dt & +#ifdef WRF_HYDRO_NUDGING + , RT_DOMAIN(did)%nudge & +#endif + , RT_DOMAIN(did)%accLndRunOff, RT_DOMAIN(did)%accQLateral, & + RT_DOMAIN(did)%accStrmvolrt, & + RT_DOMAIN(did)%accBucket, nlst_rt(did)%UDMP_OPT & + ) + else + if(nlst_rt(did)%CHRTOUT_DOMAIN .eq. 2) then +#ifdef MPP_LAND + call mpp_output_chrt2(rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, & +#else + call output_chrt2( & +#endif + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & + nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& + RT_DOMAIN(did)%CHLAT, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & + !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & + str_out, nlst_rt(did)%DT,Kt, & + RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option, & + rt_domain(did)%linkid & +#ifdef WRF_HYDRO_NUDGING + , RT_DOMAIN(did)%nudge & +#endif + !, RT_DOMAIN(did)%QLateral, nlst_rt(did)%iocflag, RT_DOMAIN(did)%velocity & + , RT_DOMAIN(did)%QLateral, nlst_rt(did)%iocflag, vel_out & + , RT_DOMAIN(did)%accLndRunOff, & + RT_DOMAIN(did)%accQLateral, & + RT_DOMAIN(did)%accStrmvolrt, & + RT_DOMAIN(did)%accBucket, & + nlst_rt(did)%UDMP_OPT & + ) + endif + + endif + + +#ifdef MPP_LAND + if(nlst_rt(did)%CHRTOUT_GRID .eq. 1) & + call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & + RT_DOMAIN(did)%GCH_NETLNK, & + nlst_rt(did)%startdate, nlst_rt(did)%olddate, & + !RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & + str_out, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & + RT_DOMAIN(did)%gnlinks,RT_DOMAIN(did)%map_l2g, & + RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) +#endif + + if (RT_DOMAIN(did)%NLAKES.gt.0) then + if(nlst_rt(did)%outlake .eq. 1) then +#ifdef MPP_LAND + call mpp_output_lakes( RT_DOMAIN(did)%lake_index, & +#else + call output_lakes( & +#endif + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%NLAKES, & + trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & + RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, & + RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, & + RT_DOMAIN(did)%QLAKEO, & + RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt) + endif + if(nlst_rt(did)%outlake .eq. 2) then +#ifdef MPP_LAND + call mpp_output_lakes2( RT_DOMAIN(did)%lake_index, & +#else + call output_lakes2( & +#endif + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%NLAKES, & + trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & + RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, & + RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, & + RT_DOMAIN(did)%QLAKEO, & + RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt,RT_DOMAIN(did)%LAKEIDM) + endif + + endif ! end if block of rNLAKES .gt. 0 + endif +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "end calling output functions" +#else + write(78,*) "end calling output functions" +#endif +#endif + + endif ! end of routing switch + + + end subroutine HYDRO_out + + + subroutine HYDRO_rst_in(did) + integer :: did + integer:: flag + + + + flag = -1 +#ifdef MPP_LAND + if(my_id.eq.IO_id) then +#endif + if (trim(nlst_rt(did)%restart_file) /= "") then + flag = 99 + rt_domain(did)%timestep_flag = 99 ! continue run + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(flag) +#endif + + nlst_rt(did)%sincedate = nlst_rt(did)%startdate + + if (flag.eq.99) then + +#ifdef MPP_LAND + if(my_id.eq.IO_id) then +#endif +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file) +#else + write(78,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file) +#endif +#endif +#ifdef MPP_LAND + endif +#endif + +#ifdef MPP_LAND + if(nlst_rt(did)%rst_bi_in .eq. 1) then + call RESTART_IN_bi(trim(nlst_rt(did)%restart_file), did) + else +#endif + call RESTART_IN_nc(trim(nlst_rt(did)%restart_file), did) +#ifdef MPP_LAND + endif +#endif + +!yw if (trim(nlst_rt(did)%restart_file) /= "") then +!yw nlst_rt(did)%restart_file = "" +!yw endif + + endif + end subroutine HYDRO_rst_in + + subroutine HYDRO_time_adv(did) + implicit none + character(len = 19) :: newdate + integer did + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif + call geth_newdate(newdate, nlst_rt(did)%olddate, nint( nlst_rt(did)%dt)) + nlst_rt(did)%olddate = newdate +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "current time is ",newdate +#else + write(78,*) "current time is ",newdate +#endif +#endif +#ifdef MPP_LAND + endif +#endif + end subroutine HYDRO_time_adv + + subroutine HYDRO_exe(did) + + + implicit none + integer:: did + integer:: rst_out + + +! call HYDRO_out(did) + + +! running land surface model +! cpl: 0--offline run; +! 1-- coupling with WRF but running offline lsm; +! 2-- coupling with WRF but do not run offline lsm +! 3-- coupling with LIS and do not run offline lsm +! 4: coupling with CLM +! if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then +! call drive_noahLSF(did,kt) +! else +! ! does not run the NOAH LASF model, only read the parameter +! call read_land_par(did,lsm(did)%ix,lsm(did)%jx) +! endif + + + + + + if (nlst_rt(did)%GWBASESWCRT .ne. 0 & + .or. nlst_rt(did)%SUBRTSWCRT .NE.0 & + .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN + + + RT_DOMAIN(did)%QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT + RT_DOMAIN(did)%LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT + + + + ! step 1) disaggregate specific fields from LSM to Hydro grid + if(nlst_rt(did)%SUBRTSWCRT .NE.0 .or. nlst_rt(did)%OVRTSWCRT .NE. 0) then + call disaggregateDomain_drv(did) + endif + if(nlst_rt(did)%OVRTSWCRT .eq. 0) then + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + call RunOffDisag(RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%landRunOff, & + rt_domain(did)%dist_lsm(:,:,9),RT_DOMAIN(did)%dist(:,:,9), & + RT_DOMAIN(did)%INFXSWGT, nlst_rt(did)%AGGFACTRT, RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) + endif + endif + + +#ifdef HYDRO_D + call system_clock(count=clock_count_1, count_rate=clock_rate) +#endif + ! step 2) + if(nlst_rt(did)%SUBRTSWCRT .NE.0) then + call SubsurfaceRouting_drv(did) + endif +#ifdef HYDRO_D + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeSr = timeSr + float(clock_count_2-clock_count_1)/float(clock_rate) +#ifndef NCEP_WCOSS + write(6,*) "Timing: Subsurface Routing accumulated time--", timeSr +#else + write(78,*) "Timing: Subsurface Routing accumulated time--", timeSr +#endif +#endif + + ! step 3) todo split +#ifdef HYDRO_D + call system_clock(count=clock_count_1, count_rate=clock_rate) +#endif + if(nlst_rt(did)%OVRTSWCRT .NE. 0) then + call OverlandRouting_drv(did) + else + RT_DOMAIN(did)%SFCHEADSUBRT = RT_DOMAIN(did)%INFXSUBRT + RT_DOMAIN(did)%INFXSUBRT = 0. + endif +#ifdef HYDRO_D + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeOr = timeOr + float(clock_count_2-clock_count_1)/float(clock_rate) +#ifndef NCEP_WCOSS + write(6,*) "Timing: Overland Routing accumulated time--", timeOr +#else + write(78,*) "Timing: Overland Routing accumulated time--", timeOr +#endif +#endif + + RT_DOMAIN(did)%QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-RT_DOMAIN(did)%QSTRMVOLRT_DUM + RT_DOMAIN(did)%LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-RT_DOMAIN(did)%LAKE_INFLORT_DUM + + +#ifdef HYDRO_D + call system_clock(count=clock_count_1, count_rate=clock_rate) +#endif + ! step 4) baseflow or groundwater physics + if (nlst_rt(did)%GWBASESWCRT .gt. 0) then + call driveGwBaseflow(did) + endif +#ifdef HYDRO_D + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeGw = timeGw + float(clock_count_2-clock_count_1)/float(clock_rate) +#ifndef NCEP_WCOSS + write(6,*) "Timing: GwBaseflow accumulated time--", timeGw +#else + write(78,*) "Timing: GwBaseflow accumulated time--", timeGw +#endif +#endif + + +#ifdef HYDRO_D + call system_clock(count=clock_count_1, count_rate=clock_rate) +#endif + ! step 5) river channel physics + call driveChannelRouting(did) +#ifdef HYDRO_D + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeCr = timeCr + float(clock_count_2-clock_count_1)/float(clock_rate) +#ifndef NCEP_WCOSS + write(6,*) "Timing: Channel Routing accumulated time--", timeCr +#else + write(78,*) "Timing: Channel Routing accumulated time--", timeCr +#endif +#endif + + ! step 6) aggregate specific fields from Hydro to LSM grid + if (nlst_rt(did)%SUBRTSWCRT .NE.0 .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN + call aggregateDomain(did) + endif + + + end if + + +!yw if (nlst_rt(did)%sys_cpl .eq. 2) then + ! advance to next time step +! call HYDRO_time_adv(did) + ! output for history +! call HYDRO_out(did) +!yw endif + call HYDRO_time_adv(did) + call HYDRO_out(did) + + +! write(90 + my_id,*) "finish calling hydro_exe" +! call flush(90+my_id) +! call mpp_land_sync() + + + + RT_DOMAIN(did)%SOLDRAIN = 0 + RT_DOMAIN(did)%QSUBRT = 0 + + + + end subroutine HYDRO_exe + + + +!---------------------------------------------------- + subroutine driveGwBaseflow(did) + + implicit none + integer, intent(in) :: did + + integer :: i, jj, ii + +!------------------------------------------------------------------ +!DJG Begin GW/Baseflow Routines +!------------------------------------------------------------------- + + IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow + +! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow + + If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "*****yw******start simp_gw_buck " +#else + write(78,*) "*****yw******start simp_gw_buck " +#endif +#endif + + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + call simp_gw_buck_nhd(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, & + RT_DOMAIN(did)%numbasns,nlst_rt(did)%AGGFACTRT, nlst_rt(did)%DT, RT_DOMAIN(did)%INFXSWGT, & + RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%SOLDRAIN, RT_DOMAIN(did)%dist(:,:,9),rt_domain(did)%dist_lsm(:,:,9), & + RT_DOMAIN(did)%gw_buck_coeff, RT_DOMAIN(did)%gw_buck_exp, RT_DOMAIN(did)%z_max, & + RT_DOMAIN(did)%z_gwsubbas, RT_DOMAIN(did)%qout_gwsubbas,RT_DOMAIN(did)%qin_gwsubbas, & + nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT, & +#ifdef MPP_LAND + RT_DOMAIN(did)%LNLINKSL & +#else + RT_DOMAIN(did)%numbasns & +#endif + , rt_domain(did)%basns_area, rt_domain(did)%nhdBuckMask & + ) + else + call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& + RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%gnumbasns,& + RT_DOMAIN(did)%basns_area,& + RT_DOMAIN(did)%basnsInd, RT_DOMAIN(did)%gw_strm_msk_lind, & + RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & + RT_DOMAIN(did)%SOLDRAIN, & + RT_DOMAIN(did)%z_gwsubbas,& + RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& + RT_DOMAIN(did)%qinflowbase,& + RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & + RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& + RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%z_max,& + nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) + endif + + if(nlst_rt(did)%GWBASESWCRT .gt. 0 .and. nlst_rt(did)%output_gw .eq. 2) then + ! ouput of bucket information for NCAR GW option. + call output_GW_Diag(did) + endif + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "*****yw******end simp_gw_buck " +#else + write(78,*) "*****yw******end simp_gw_buck " +#endif +#endif + +!!!For parameter setup runs output the percolation for each basin, +!!!otherwise comment out this output... + else if (nlst_rt(did)%gwBaseSwCRT .eq. 3) then + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "*****bf******start 2d_gw_model " +#else + write(78,*) "*****bf******start 2d_gw_model " +#endif +#endif + + ! compute qsgwrt between lsm and gw with namelist selected coupling method + ! qsgwrt is defined on the routing grid and needs to be aggregated for SFLX + if (nlst_rt(did)%gwsoilcpl .GT. 0) THEN + + call gwSoilFlux(did) + + end if + + + gw2d(did)%excess = 0. + + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & + gw2d(did)%excess, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + gw2d(did)%istep) + + + gw2d(did)%ho = gw2d(did)%h + + + + ! put surface exceeding groundwater to surface routing inflow + RT_DOMAIN(did)%SFCHEADSUBRT = RT_DOMAIN(did)%SFCHEADSUBRT & + + gw2d(did)%excess*1000. ! convert to mm + + ! aggregate qsgw from routing to lsm grid + call aggregateQsgw(did) + + gw2d(did)%istep = gw2d(did)%istep + 1 + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "*****bf******end 2d_gw_model " +#else + write(78,*) "*****bf******end 2d_gw_model " +#endif +#endif + + End if + + END IF !DJG (End if for RTE SWC activation) +!------------------------------------------------------------------ +!DJG End GW/Baseflow Routines +!------------------------------------------------------------------- + + + end subroutine driveGwBaseflow + + + + +!------------------------------------------- + subroutine driveChannelRouting(did) + + implicit none + integer, intent(in) :: did + +!------------------------------------------------------------------- +!------------------------------------------------------------------- +!DJG,DNY Begin Channel and Lake Routing Routines +!------------------------------------------------------------------- + + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN + + + if(rt_domain(did)%restQSTRM) then + RT_DOMAIN(did)%QSTRMVOLRT_TS = 0.000001 + rt_domain(did)%restQSTRM = .false. +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "***** set QSTRMVOLRT_TS = 0.000001 *********" +#else + write(78,*) "***** set QSTRMVOLRT_TS = 0.000001 *********" +#endif + call flush(6) +#endif + endif +101 continue + + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + !!! for user defined Reach based Routing method. + + call drive_CHANNEL_RSL(nlst_rt(did)%UDMP_OPT,RT_DOMAIN(did)%timestep_flag, RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS, RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, & + RT_DOMAIN(did)%TYPEL, RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%CH_LNKRT, & + RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT, nlst_rt(did)%DTRT_CH, & + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%CHANLEN, RT_DOMAIN(did)%MannN, RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp,RT_DOMAIN(did)%Bw, & + RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH, RT_DOMAIN(did)%WEIRH, RT_DOMAIN(did)%WEIRC, & + RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, RT_DOMAIN(did)%ORIFICEA, & + RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%CVOL, RT_DOMAIN(did)%QLAKEI, & + RT_DOMAIN(did)%QLAKEO, RT_DOMAIN(did)%LAKENODE, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & + RT_DOMAIN(did)%nlinks, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, RT_DOMAIN(did)%node_area, & + RT_DOMAIN(did)%qout_gwsubbas, & + RT_DOMAIN(did)%LAKEIDA, RT_DOMAIN(did)%LAKEIDM, RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%LAKEIDX & +#ifdef MPP_LAND + , RT_DOMAIN(did)%nlinks_index, RT_DOMAIN(did)%mpp_nlinks, RT_DOMAIN(did)%yw_mpp_nlinks & + , RT_DOMAIN(did)%LNLINKSL & + , RT_DOMAIN(did)%gtoNode, RT_DOMAIN(did)%toNodeInd, RT_DOMAIN(did)%nToInd & +#endif + , RT_DOMAIN(did)%CH_LNKRT_SL, RT_DOMAIN(did)%landRunOff & +#ifdef WRF_HYDRO_NUDGING + , RT_DOMAIN(did)%nudge & +#endif + , rt_domain(did)%accLndRunOff, rt_domain(did)%accQLateral, rt_domain(did)%accStrmvolrt, rt_domain(did)%accBucket & + , rt_domain(did)%QLateral, rt_domain(did)%velocity & + , rt_domain(did)%nlinksize, nlst_rt(did)%OVRTSWCRT, nlst_rt(did)%SUBRTSWCRT) +else + call drive_CHANNEL(RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & + RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& + RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& + RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& + RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%CH_LNKRT,& + RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT, nlst_rt(did)%DTRT_CH,& + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& + RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & + RT_DOMAIN(did)%Bw,& + RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& + RT_DOMAIN(did)%WEIRH, & + RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & + RT_DOMAIN(did)%ORIFICEA, & + RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & + RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& + RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & + RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & + RT_DOMAIN(did)%RETDEP_CHAN, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, & + RT_DOMAIN(did)%node_area & +#ifdef MPP_LAND + ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& + RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & + RT_DOMAIN(did)%yw_mpp_nlinks & + , RT_DOMAIN(did)%LNLINKSL,RT_DOMAIN(did)%LLINKID & + , rt_domain(did)%gtoNode,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd & +#endif + , rt_domain(did)%CH_LNKRT_SL & + ,nlst_rt(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, & + nlst_rt(did)%gwChanCondSw, nlst_rt(did)%gwChanCondConstIn, & + nlst_rt(did)%gwChanCondConstOut & + ) +endif + + if((nlst_rt(did)%gwBaseSwCRT == 3) .and. (nlst_rt(did)%gwChanCondSw .eq. 1)) then + + ! add/rm channel-aquifer exchange contribution + + gw2d(did)%ho = gw2d(did)%ho & + +(((gw2d(did)%qgw_chanrt*(-1)) * gw2d(did)%dt / gw2d(did)%dx**2) & + / gw2d(did)%poros) + + endif + endif + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "*****yw******end drive_CHANNEL " +#else + write(78,*) "*****yw******end drive_CHANNEL " +#endif +#endif + + end subroutine driveChannelRouting + + + +!------------------------------------------------ + subroutine aggregateDomain(did) + +#ifdef MPP_LAND + use module_mpp_land, only: sum_real1, my_id, io_id, numprocs +#endif + + implicit none + integer, intent(in) :: did + + integer :: i, j, krt, ixxrt, jyyrt, & + AGGFACYRT, AGGFACXRT + +#ifdef HYDRO_D +! ADCHANGE: Water balance variables + integer :: kk + real :: smcrttot1,smctot2,sicetot2 + real :: suminfxsrt1,suminfxs2 +#endif + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + print *, "Beginning Aggregation..." +#else + write(78,*) "Beginning Aggregation..." +#endif +#endif + +#ifdef HYDRO_D +! ADCHANGE: START Initial water balance variables +! ALL VARS in MM + suminfxsrt1 = 0. + smcrttot1 = 0. + do i=1,RT_DOMAIN(did)%IXRT + do j=1,RT_DOMAIN(did)%JXRT + suminfxsrt1 = suminfxsrt1 + RT_DOMAIN(did)%SFCHEADSUBRT(I,J) & + / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + do kk=1,nlst_rt(did)%NSOIL + smcrttot1 = smcrttot1 + RT_DOMAIN(did)%SMCRT(I,J,KK)*RT_DOMAIN(did)%SLDPTH(KK)*1000. & + / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + end do + end do + end do +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxsrt1) + CALL sum_real1(smcrttot1) + suminfxsrt1 = suminfxsrt1/float(numprocs) + smcrttot1 = smcrttot1/float(numprocs) +#endif +! END Initial water balance variables +#endif + + do J=1,RT_DOMAIN(did)%JX + do I=1,RT_DOMAIN(did)%IX + + RT_DOMAIN(did)%SFCHEADAGGRT = 0. +!DJG Subgrid weighting edit... + RT_DOMAIN(did)%LSMVOL=0. + do KRT=1,nlst_rt(did)%NSOIL +! SMCAGGRT(KRT) = 0. + RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. + end do + + + do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + + + IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + +!State Variables + RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & + + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) +!DJG Subgrid weighting edit... + RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & + + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & + * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) + + do KRT=1,nlst_rt(did)%NSOIL +!DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) + RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) + end do + + end do + end do + + + + RT_DOMAIN(did)%SFCHEADRT(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & + / (nlst_rt(did)%AGGFACTRT**2) + + do KRT=1,nlst_rt(did)%NSOIL +!DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) + RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + / (nlst_rt(did)%AGGFACTRT**2) + end do + + + +!DJG Calculate subgrid weighting array... + + do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ??? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + if (RT_DOMAIN(did)%LSMVOL.gt.0.) then + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & + * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) & + / RT_DOMAIN(did)%LSMVOL + else + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = 1./FLOAT(nlst_rt(did)%AGGFACTRT**2) + end if + + do KRT=1,nlst_rt(did)%NSOIL + +!!!yw added for debug + if(RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .lt. 0) then +#ifndef NCEP_WCOSS + print*, "Error negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) +#else + write(78,*) "WARNING: negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) +#endif + endif + if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then +#ifndef NCEP_WCOSS + print *, "Error negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) +#else + write(78,*) "WARNING: negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) +#endif + endif + +!end + IF (RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .GT. & + RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT)) THEN + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + print *, "SMCMAX exceeded upon aggregation...", & + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT), & + RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT) +#else + write(78,*) "FATAL ERROR: SMCMAX exceeded upon aggregation...", & + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT), & + RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT) +#endif +#endif + call hydro_stop("In module_HYDRO_drv.F aggregateDomain() - "// & + "SMCMAX exceeded upon aggregation.") + END IF + IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LT.0.) THEN +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + print *, "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + print *, "Error negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) +#else + write(78,*) "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + write(78,*) "FATAL ERROR: negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) +#endif +#endif + call hydro_stop("In module_HYDRO_drv.F aggregateDomain() "// & + "- Error negative SH2OX") + END IF + + IF ( RT_DOMAIN(did)%SH2OX(I,J,KRT) .gt. 0 ) THEN + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & + = RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) & + / RT_DOMAIN(did)%SH2OX(I,J,KRT) + ELSE +#ifdef HYDRO_D + print *, "Error zero SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) +#endif + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = 0.0 + ENDIF +!?yw + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-05, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) + end do + + end do + end do + + end do + end do + + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) + + do i = 1, nlst_rt(did)%NSOIL + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) + end do +#endif + +!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... + RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE + +#ifdef HYDRO_D +! ADCHANGE: START Final water balance variables +! ALL VARS in MM + suminfxs2 = 0. + smctot2 = 0. + sicetot2 = 0. + do i=1,RT_DOMAIN(did)%IX + do j=1,RT_DOMAIN(did)%JX + suminfxs2 = suminfxs2 + RT_DOMAIN(did)%SFCHEADRT(I,J) & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + do kk=1,nlst_rt(did)%NSOIL + smctot2 = smctot2 + RT_DOMAIN(did)%SMC(I,J,KK)*RT_DOMAIN(did)%SLDPTH(KK)*1000. & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + sicetot2 = sicetot2 + RT_DOMAIN(did)%SICE(I,J,KK)*RT_DOMAIN(did)%SLDPTH(KK)*1000. & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + end do + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxs2) + CALL sum_real1(smctot2) + CALL sum_real1(sicetot2) + suminfxs2 = suminfxs2/float(numprocs) + smctot2 = smctot2/float(numprocs) + sicetot2 = sicetot2/float(numprocs) +#endif + +#ifdef MPP_LAND + if (my_id .eq. IO_id) then +#endif + print *, "Agg Mass Bal: " + print *, "WB_AGG!InfxsDiff", suminfxs2-suminfxsrt1 + print *, "WB_AGG!Infxs1", suminfxsrt1 + print *, "WB_AGG!Infxs2", suminfxs2 + print *, "WB_AGG!SMCDiff", smctot2-smcrttot1-sicetot2 + print *, "WB_AGG!SMC1", smcrttot1 + print *, "WB_AGG!SMC2", smctot2 + print *, "WB_AGG!SICE2", sicetot2 + print *, "WB_AGG!Residual", (suminfxs2-suminfxsrt1) + & + (smctot2-smcrttot1-sicetot2) +#ifdef MPP_LAND + endif +#endif +! END Final water balance variables +#endif + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + print *, "Finished Aggregation..." +#else + write(78,*) "Finished Aggregation..." +#endif +#endif + + + end subroutine aggregateDomain + + subroutine RunOffDisag(runoff1x_in, runoff1x, area_lsm,cellArea, infxswgt, AGGFACTRT, ix,jx) + implicit none + real, dimension(:,:) :: runoff1x_in, runoff1x, area_lsm, cellArea, infxswgt + integer :: i,j,ix,jx,AGGFACYRT, AGGFACXRT, AGGFACTRT, IXXRT, JYYRT + + do J=1,JX + do I=1,IX + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#endif +!DJG Implement subgrid weighting routine... + if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then + runoff1x(IXXRT,JYYRT) = 0 + else + runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J) & + *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT) + endif + + enddo + enddo + enddo + enddo + + end subroutine RunOffDisag + + + subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) + implicit none + integer ntime, did + integer rst_out, ix,jx +! integer, OPTIONAL:: ix0,jx0 + integer:: ix0,jx0 + integer, dimension(ix0,jx0),OPTIONAL :: vegtyp, soltyp + + +#ifdef MPP_LAND + call MPP_LAND_INIT() +#endif + + +! read the namelist +! the lsm namelist will be read by rtland sequentially again. + call read_rt_nlst(nlst_rt(did) ) + + if(nlst_rt(did)%rtFlag .eq. 0) return + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! get the dimension + call get_file_dimension(trim(nlst_rt(did)%geo_static_flnm), ix,jx) + + +#ifdef MPP_LAND + + if (nlst_rt(did)%sys_cpl .eq. 1 .or. nlst_rt(did)%sys_cpl .eq. 4) then +!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; +! 2-- coupling with WRF but do not run offline lsm +! 3-- coupling with LIS and do not run offline lsm +! 4: coupling with CLM + +! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. + call log_map2d() + + global_nx = ix ! get from land model + global_ny = jx ! get from land model + + call mpp_land_bcast_int1(global_nx) + call mpp_land_bcast_int1(global_ny) + +!!! temp set global_nx to ix + rt_domain(did)%ix = global_nx + rt_domain(did)%jx = global_ny + +! over write the ix and jx + call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& + nlst_rt(did)%AGGFACTRT) + else +! coupled with WRF, LIS + numprocs = node_info(1,1) + + call wrf_LAND_set_INIT(node_info,numprocs,nlst_rt(did)%AGGFACTRT) + + + rt_domain(did)%ix = local_nx + rt_domain(did)%jx = local_ny + endif + + + + rt_domain(did)%g_IXRT=global_rt_nx + rt_domain(did)%g_JXRT=global_rt_ny + rt_domain(did)%ixrt = local_rt_nx + rt_domain(did)%jxrt = local_rt_ny + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" + write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt + write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " + write(6,*) rt_domain(did)%ix, rt_domain(did)%jx + write(6,*) "global_nx, global_ny, local_nx, local_ny" + write(6,*) global_nx, global_ny, local_nx, local_ny +#else + write(78,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" + write(78,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt + write(78,*) "rt_domain(did)%ix, rt_domain(did)%jx " + write(78,*) rt_domain(did)%ix, rt_domain(did)%jx + write(78,*) "global_nx, global_ny, local_nx, local_ny" + write(78,*) global_nx, global_ny, local_nx, local_ny +#endif +#endif +#else +! sequential + rt_domain(did)%ix = ix + rt_domain(did)%jx = jx + rt_domain(did)%ixrt = ix*nlst_rt(did)%AGGFACTRT + rt_domain(did)%jxrt = jx*nlst_rt(did)%AGGFACTRT +#endif + + +! allocate rt arrays + + + call getChanDim(did) + + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "finish getChanDim " +#else + write(78,*) "finish getChanDim " +#endif +#endif + + if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then + call gw2d_allocate(did,& + rt_domain(did)%ixrt,& + rt_domain(did)%jxrt,& + nlst_rt(did)%nsoil) +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "finish gw2d_allocate" +#else + write(78,*) "finish gw2d_allocate" +#endif +#endif + endif + +! calculate the distance between grids for routing. +! decompose the land parameter/data + + +! ix0= rt_domain(did)%ix +! jx0= rt_domain(did)%jx + if(present(vegtyp)) then + call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) + else + call lsm_input(did,ix0=ix0,jx0=jx0) + endif + + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "finish decomposion" +#else + write(78,*) "finish decomposion" +#endif +#endif + + + call get_dist_lsm(did) + call get_dist_lrt(did) + + +! rt model initilization + call LandRT_ini(did) + + + if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then + + call gw2d_ini(did,& + nlst_rt(did)%dt,& + nlst_rt(did)%dxrt0) +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "finish gw2d_ini" +#else + write(78,*) "finish gw2d_ini" +#endif +#endif + endif +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) "finish LandRT_ini" +#else + write(78,*) "finish LandRT_ini" +#endif +#endif + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IF (nlst_rt(did)%TERADJ_SOLAR.EQ.1 .and. nlst_rt(did)%CHANRTSWCRT.NE.2) THEN ! Perform ter rain adjustment of incoming solar +#ifdef MPP_LAND + call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) +#else + call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx) +#endif + endif + + + IF (nlst_rt(did)%GWBASESWCRT .gt. 0) then + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + call get_basn_area_nhd(rt_domain(did)%basns_area) + else + call get_basn_area(did) + endif + endif + + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 ) then + call get_node_area(did) + endif + + +#ifdef WRF_HYDRO_NUDGING + if(nlst_rt(did)%CHANRTSWCRT .ne. 0) call init_stream_nudging +#endif + + +! if (trim(nlst_rt(did)%restart_file) == "") then +! output at the initial time +! call HYDRO_out(did) +! return +! endif + +! restart the file + + ! jummp the initial time output +! rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 +! rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 + + + call HYDRO_rst_in(did) + + call HYDRO_out(did) + + end subroutine HYDRO_ini + + subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) + implicit none + integer did, leng + parameter(leng=100) + integer :: i,j, nn + integer, allocatable, dimension(:,:) :: soltyp + real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc + + integer :: ix0,jx0 + integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0 + +#ifdef HYDRO_D +#ifndef NCEP_WCOSS + write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx +#else + write(78,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx +#endif +#endif + + allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) + + soltyp = 0 + call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + + + call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + + call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + + + + if(nlst_rt(did)%sys_cpl .eq. 2 ) then + ! coupling with WRF + if(present(soltyp0) ) then + where(soltyp0 == 14) VEGTYP0 = 16 + where(VEGTYP0 == 16 ) soltyp0 = 14 + soltyp = soltyp0 + RT_DOMAIN(did)%VEGTYP = VEGTYP0 + endif + endif + + where(soltyp == 14) RT_DOMAIN(did)%VEGTYP = 16 + where(RT_DOMAIN(did)%VEGTYP == 16 ) soltyp = 14 + +! LKSAT, +! temporary set + RT_DOMAIN(did)%SMCRTCHK = 0 + RT_DOMAIN(did)%SMCAGGRT = 0 + RT_DOMAIN(did)%STCAGGRT = 0 + RT_DOMAIN(did)%SH2OAGGRT = 0 + + + RT_DOMAIN(did)%zsoil(1:nlst_rt(did)%nsoil) = nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) + + RT_DOMAIN(did)%sldpth(1) = abs( RT_DOMAIN(did)%zsoil(1) ) + do i = 2, nlst_rt(did)%nsoil + RT_DOMAIN(did)%sldpth(i) = RT_DOMAIN(did)%zsoil(i-1)-RT_DOMAIN(did)%zsoil(i) + enddo + RT_DOMAIN(did)%SOLDEPRT = -1.0*RT_DOMAIN(did)%ZSOIL(nlst_rt(did)%NSOIL) + +! input OV_ROUGH from OVROUGH.TBL +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + +#ifndef NCEP_WCOSS + open(71,file="HYDRO.TBL", form="formatted") +!read OV_ROUGH first + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(71) +#else + open(13, form="formatted") +!read OV_ROUGH first + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(13) +#endif + +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) + call mpp_land_bcast_real(leng,xdum1) + call mpp_land_bcast_real(leng,MAXSMC) + call mpp_land_bcast_real(leng,refsmc) + call mpp_land_bcast_real(leng,wltsmc) +#endif + + rt_domain(did)%lksat = 0.0 + do j = 1, RT_DOMAIN(did)%jx + 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) == 1 ) 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)) + ENDIF + end do + end do + + + rt_domain(did)%soiltyp = soltyp + + if(allocated(soltyp)) deallocate(soltyp) + + + end subroutine lsm_input + + +end module module_HYDRO_drv + +! stop the job due to the fatal error. + subroutine HYDRO_stop(msg) +#ifdef MPP_LAND + use module_mpp_land +#endif + character(len=*) :: msg + integer :: ierr + ierr = 1 +#ifndef NCEP_WCOSS +!#ifdef HYDRO_D !! PLEASE NEVER UNCOMMENT THIS IFDEF, it's just one incredibly useful string. + write(6,*) "The job is stopped due to the fatal error. ", trim(msg) + call flush(6) +!#endif +#else + write(78,*) "FATAL ERROR: ", trim(msg) + call flush(78) + close(78) +#endif +#ifdef MPP_LAND +#ifndef HYDRO_D + print*, "---" + print*, "FATAL ERROR! Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." + print*, "" +#endif + +! call mpp_land_sync() +! write(my_id+90,*) msg +! call flush(my_id+90) + + call mpp_land_abort() + call MPI_finalize(ierr) +#else + stop "FATAL ERROR: Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." +#endif + + return + end subroutine HYDRO_stop + + +! stop the job due to the fatal error. + subroutine HYDRO_finish() +#ifdef MPP_LAND + USE module_mpp_land +#endif +#ifdef WRF_HYDRO_NUDGING + use module_stream_nudging, only: finish_stream_nudging +#endif + + integer :: ierr + +#ifdef WRF_HYDRO_NUDGING + call finish_stream_nudging() +#endif +#ifndef NCEP_WCOSS + print*, "The model finished successfully......." +#else + write(78,*) "The model finished successfully......." +#endif +#ifdef MPP_LAND +! call mpp_land_abort() +#ifndef NCEP_WCOSS + call flush(6) +#else + call flush(78) + close(78) +#endif + call mpp_land_sync() + call MPI_finalize(ierr) + stop +#else + +#ifndef WRF_HYDRO_NUDGING + stop !!JLM want to time at the top NoahMP level. +#endif + +#endif + + return + end subroutine HYDRO_finish diff --git a/wrfv2_fire/hydro/MPP/CPL_WRF.F b/wrfv2_fire/hydro/MPP/CPL_WRF.F new file mode 100644 index 00000000..6cfb5799 --- /dev/null +++ b/wrfv2_fire/hydro/MPP/CPL_WRF.F @@ -0,0 +1,225 @@ +! Program Name: +! 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: + +! This is used as a coupler with the WRF model. +MODULE MODULE_CPL_LAND + + !use module_mpp_land, only: HYDRO_COMM_WORLD + + IMPLICIT NONE + + integer, public :: HYDRO_COMM_WORLD = -1 + integer my_global_id + + integer total_pe_num + integer global_ix,global_jx + + integer,allocatable,dimension(:,:) :: node_info + + logical initialized, cpl_land, time_step_read_rstart, & + time_step_write_rstart, time_step_output + character(len=19) cpl_outdate, cpl_rstdate + + integer, public :: cartGridComm + integer, public :: np_up_down, np_left_right + integer, public :: p_up_down, p_left_right + + contains + + ! sets incoming communicator and then calls CPL_LAND_INIT + !subroutine CPL_LAND_INIT_COMM(istart,iend,jstart,jend,hydroCommunicator) + ! implicit none + ! + ! integer :: istart,iend,jstart,jend + ! integer :: hydroCommunicator + ! + ! HYDRO_COMM_WORLD = hydroCommunicator + ! call CPL_LAND_INIT(istart,iend,jstart,jend) + !end subroutine + + subroutine CPL_LAND_INIT(istart,iend,jstart,jend) + implicit none + include "mpif.h" + integer ierr + logical mpi_inited + integer istart,iend,jstart,jend + + integer :: xx, ndim + integer, dimension(0:1) :: dims, coords + logical cyclic(0:1), reorder + data cyclic/.false.,.false./ ! not cyclic + data reorder/.false./ + + CALL mpi_initialized( mpi_inited, ierr ) + if ( .NOT. mpi_inited ) then + call mpi_init(ierr) + HYDRO_COMM_WORLD = MPI_COMM_WORLD + endif + + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_global_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, total_pe_num, ierr ) + + allocate(node_info(9,total_pe_num)) + + node_info = -99 + +! send node info to node 0 + node_info(1,my_global_id+1) = total_pe_num + node_info(6,my_global_id+1) = istart + node_info(7,my_global_id+1) = iend + node_info(8,my_global_id+1) = jstart + node_info(9,my_global_id+1) = jend + + + call send_info() + call find_left() + call find_right() + call find_up() + call find_down() + + call send_info() + + ! initialize cartesian grid communicator + dims(0) = 0 + dims(1) = 0 + do xx=1,total_pe_num + if(node_info(2,xx) .eq. (-1)) then + dims(0) = dims(0)+1 + endif + if(node_info(4,xx) .eq. (-1)) then + dims(1) = dims(1)+1 + endif + enddo + + ndim = 2 + np_up_down = dims(0) + np_left_right = dims(1) + + call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & + cyclic, reorder, cartGridComm, ierr) + + call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) + + p_up_down = coords(0) + p_left_right = coords(1) + + initialized = .false. ! land model need to be initialized. + return + END subroutine CPL_LAND_INIT + + subroutine send_info() + implicit none + include "mpif.h" + integer,allocatable,dimension(:,:) :: tmp_info + integer ierr, i,size, tag + integer mpp_status(MPI_STATUS_SIZE) + tag = 9 + size = 9 + + if(my_global_id .eq. 0) then + do i = 1, total_pe_num-1 + call mpi_recv(node_info(:,i+1),size,MPI_INTEGER, & + i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + enddo + else + call mpi_send(node_info(:,my_global_id+1),size, & + MPI_INTEGER,0,tag,HYDRO_COMM_WORLD,ierr) + endif + + call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + + size = 9 * total_pe_num + call mpi_bcast(node_info,size,MPI_INTEGER, & + 0,HYDRO_COMM_WORLD,ierr) + + call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + + return + end subroutine send_info + + subroutine find_left() + implicit none + integer i + + node_info(2,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & + (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & + ((node_info(7,i)+1).eq.node_info(6,my_global_id+1)) ) then + node_info(2,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_left + + subroutine find_right() + implicit none + integer i + + node_info(3,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & + (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & + ((node_info(6,i)-1).eq.node_info(7,my_global_id+1)) ) then + node_info(3,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_right + + subroutine find_up() + implicit none + integer i + + node_info(4,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & + (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & + ((node_info(8,i)-1).eq.node_info(9,my_global_id+1)) ) then + node_info(4,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_up + + subroutine find_down() + implicit none + integer i + + node_info(5,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & + (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & + ((node_info(9,i)+1).eq.node_info(8,my_global_id+1)) ) then + node_info(5,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_down + +END MODULE MODULE_CPL_LAND diff --git a/wrfv2_fire/hydro/MPP/Makefile b/wrfv2_fire/hydro/MPP/Makefile new file mode 100644 index 00000000..06333f58 --- /dev/null +++ b/wrfv2_fire/hydro/MPP/Makefile @@ -0,0 +1,39 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = CPL_WRF.o mpp_land.o module_mpp_ReachLS.o module_mpp_GWBUCKET.o + +all: $(OBJS) +mpp_land.o: mpp_land.F + @echo "" + $(RMD) $(*).o $(*).mod $(*).stb *~ + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + ar -r ../lib/libHYDRO.a $(@) + +CPL_WRF.o: CPL_WRF.F + @echo "" + $(RMD) $(*).o $(*).mod $(*).stb *~ *.f + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) $(*).f + + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + ar -r ../lib/libHYDRO.a $(@) + +module_mpp_ReachLS.o: module_mpp_ReachLS.F + @echo "" + $(RMD) $(*).o $(*).mod $(*).stb *~ + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + ar -r ../lib/libHYDRO.a $(@) + +module_mpp_GWBUCKET.o: module_mpp_GWBUCKET.F + @echo "" + $(RMD) $(*).o $(*).mod $(*).stb *~ + $(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F + ar -r ../lib/libHYDRO.a $(@) + +clean: + $(RMD) *.o *.mod *.stb *~ diff --git a/wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F b/wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F new file mode 100644 index 00000000..c1d1f969 --- /dev/null +++ b/wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F @@ -0,0 +1,236 @@ +! Program Name: +! 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: + +! This is used as a coupler with the WRF model. +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 + implicit none + + + + include "mpif.h" + + integer,allocatable,dimension(:) :: sizeInd ! size of Basins for each tile + integer :: maxSizeInd + + integer :: gw_ini + + contains + + subroutine gwbucket_ini() + allocate(sizeInd(numprocs)) + sizeInd = 0 + gw_ini = 99 + maxSizeInd = 0 + end subroutine gwbucket_ini + + + subroutine collectSizeInd(numbasns) + implicit none + integer, intent(in) :: numbasns + integer :: i, ierr, tag, rcv + + call mpp_land_sync() + + if(gw_ini .ne. 99) call gwbucket_ini() + + if(my_id .ne. IO_id) then + tag = 66 + call mpi_send(numbasns,1,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + if(i .eq. IO_id) then + sizeInd(i+1) = numbasns + else + tag = 66 + call mpi_recv(rcv,1,& + MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) + + sizeInd(i+1) = rcv + end if + if(sizeInd(i+1) .gt. maxSizeInd) maxSizeInd = sizeInd(i+1) + end do + end if + end subroutine collectSizeInd + + subroutine gw_write_io_real(numbasns,inV,ind,outV) + implicit none + integer, intent(in) :: numbasns + integer :: i, ierr, tag, tag2,k + real,intent(in), dimension(numbasns) :: inV + integer,intent(in), dimension(numbasns) :: ind + real, dimension(:) :: outV + real, allocatable,dimension(:) :: vbuff + integer, allocatable,dimension(:) :: ibuff + + if(gw_ini .ne. 99) then + stop "FATAL ERROR: mpp_GWBUCKET not initialized." + endif + + if(my_id .eq. IO_id) then + outV = 0.0 + allocate(vbuff(maxSizeInd)) + allocate(ibuff(maxSizeInd)) + else + allocate(vbuff(1)) + allocate(ibuff(1)) + endif + + if(my_id .ne. IO_id) then + if(numbasns .gt. 0) then + tag = 62 + call mpi_send(inV,numbasns,MPI_REAL, IO_id, & + tag,MPI_COMM_WORLD,ierr) + tag2 = 63 + call mpi_send(ind,numbasns,MPI_INTEGER, IO_id, & + tag2,MPI_COMM_WORLD,ierr) + endif + else + + do k = 1, numbasns + outV(ind(k)) = inV(k) + end do + + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + if(sizeInd(i+1) .gt. 0) then + tag = 62 + call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& + MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr) + tag2 = 63 + call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& + MPI_INTEGER,i,tag2,MPI_COMM_WORLD,mpp_status,ierr) + + do k = 1, sizeInd(i+1) + outV(ibuff(k)) = vbuff(k) + end do + endif + end if + end do + end if + if(allocated(ibuff)) deallocate(ibuff) + if(allocated(vbuff)) deallocate(vbuff) + end subroutine gw_write_io_real + + subroutine gw_write_io_int(numbasns,inV,ind,outV) + implicit none + integer, intent(in) :: numbasns + integer :: i, ierr, tag, tag2,k + integer,intent(in), dimension(numbasns) :: inV + integer,intent(in), dimension(numbasns) :: ind + integer, dimension(:) :: outV + integer, allocatable,dimension(:) :: vbuff + integer, allocatable,dimension(:) :: ibuff + + if(gw_ini .ne. 99) then + stop "FATAL ERROR: mpp_GWBUCKET not initialized." + endif + + if(my_id .eq. IO_id) then + outV = 0.0 + allocate(vbuff(maxSizeInd)) + allocate(ibuff(maxSizeInd)) + else + allocate(vbuff(1)) + allocate(ibuff(1)) + endif + + if(my_id .ne. IO_id) then + if(numbasns .gt. 0) then + tag = 62 + call mpi_send(inV,numbasns,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + tag2 = 63 + call mpi_send(ind,numbasns,MPI_INTEGER, IO_id, & + tag2,MPI_COMM_WORLD,ierr) + endif + else + + do k = 1, numbasns + outV(ind(k)) = inV(k) + end do + + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + if(sizeInd(i+1) .gt. 0) then + tag = 62 + call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& + MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) + tag2 = 63 + call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& + MPI_INTEGER,i,tag2,MPI_COMM_WORLD,mpp_status,ierr) + + do k = 1, sizeInd(i+1) + outV(ibuff(k)) = vbuff(k) + end do + endif + end if + end do + end if + deallocate(ibuff) + deallocate(vbuff) + end subroutine gw_write_io_int + + subroutine gw_decompose_real(gnumbasns,numbasns,ind,inV,outV) + implicit none + integer, intent(in) :: numbasns, gnumbasns + integer :: i, ierr, tag, bas + real,intent(in), dimension(:) :: inV + integer,intent(in), dimension(:) :: ind + real, dimension(:) :: outV + real, dimension(gnumbasns) :: buff + + outV = 0 + if(gnumbasns .lt. 0) return + + if(my_id .eq. io_id) buff = inV + call mpp_land_bcast_real(gnumbasns,buff) + + do i = 1, numbasns + bas = ind(i) + outV(i) = buff(bas) + end do + end subroutine gw_decompose_real + + subroutine gw_sum_real(vinout,nsize,gsize,ind) + implicit none + integer nsize,i,j,tag,ierr,gsize, k + real*8, dimension(nsize):: vinout + integer, dimension(nsize) :: ind + real*8, dimension(gsize) :: vbuff + + vbuff = 0 + do k = 1, nsize + vbuff(ind(k)) = vinout(k) + end do + call sum_real8(vbuff,gsize) + do k = 1, nsize + vinout(k) = vbuff(ind(k)) + end do + end subroutine gw_sum_real + + + +end MODULE MODULE_mpp_GWBUCKET + + diff --git a/wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F b/wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F new file mode 100644 index 00000000..5434bba8 --- /dev/null +++ b/wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F @@ -0,0 +1,1089 @@ +! Program Name: +! 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: + +! This is used as a coupler with the WRF model. +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 + implicit none + + + TYPE Grid2ReachMap + real,allocatable, dimension(:) :: sv + real,allocatable, dimension(:) :: rv + real,allocatable, dimension(:) :: rvId + real,allocatable, dimension(:) :: snId + end TYPE Grid2ReachMap + + interface ReachLS_decomp + module procedure ReachLS_decompReal + module procedure ReachLS_decompInt + module procedure ReachLS_decompChar + end interface + + interface ReachLS_write_io + module procedure ReachLS_wReal + module procedure ReachLS_wReal2 + module procedure ReachLS_wInt + module procedure ReachLS_wInt2 + module procedure ReachLS_wChar + end interface + + interface gBcastValue + module procedure gbcastReal + module procedure gbcastInt + module procedure gbcastReal2 + end interface + + interface updateLinkV + module procedure updateLinkV8_mem + module procedure updateLinkV4_mem + end interface + + + + include "mpif.h" + + integer,allocatable,dimension(:) :: sDataRec ! sending data size + integer,allocatable,dimension(:) :: rDataRec ! receiving data size + integer,allocatable,dimension(:) :: linkls_s ! receiving data size + integer,allocatable,dimension(:) :: linkls_e ! receiving data size + integer,allocatable,dimension(:) :: ToInd ! size of toInd + + integer :: numprocs + integer, allocatable, dimension(:) :: LLINKIDINDX, aLinksl + integer :: LLINKLEN, gNlinksl, tmpnlinksl, l_nlinksl, max_nlinkSL + + contains + + + subroutine updateLinkV8_mem(LinkV, outV) +! for big memory data + implicit none + real, dimension(:) :: outV + real*8, dimension(:) :: LinkV + real, allocatable, dimension(:) :: gLinkV_r4 + real*8, allocatable,dimension(:) :: tmpBuf, gLinkV_r8 + integer :: ierr, i, tag, k,m,lsize + integer, allocatable,dimension(:) :: lindex + if(my_id .eq. io_id) then + allocate(gLinkV_r4(gnlinksl)) + allocate(gLinkV_r8(gnlinksl)) + gLinkV_r4 = 0.0 + gLinkV_r8 = 0.0 + do i = 1, LLINKLEN + gLinkV_r8(LLINKIDINDX(i)) = LinkV(i) + end do + endif + + if(my_id .ne. IO_id) then + + tag = 101 + call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + if(LLINKLEN .gt. 0) then + tag = 102 + call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 103 + call mpi_send(LinkV,LLINKLEN,MPI_DOUBLE_PRECISION, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + tag = 101 + call mpi_recv(lsize,1,MPI_INTEGER, i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(lsize .gt. 0) then + allocate(lindex(lsize) ) + allocate(tmpBuf(lsize) ) + tag = 102 + call mpi_recv(lindex,lsize,MPI_INTEGER, i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 103 + call mpi_recv(tmpBuf,lsize,& + MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, lsize + gLinkV_r8(lindex(k)) = gLinkV_r8(lindex(k)) + tmpBuf(k) + end do + if(allocated(lindex)) deallocate(lindex) + if(allocated(tmpBuf)) deallocate(tmpBuf) + endif + end if + end do + gLinkV_r4 = gLinkV_r8 + if(allocated(gLinkV_r8)) deallocate(gLinkV_r8) + end if + + call ReachLS_decompReal(gLinkV_r4,outV) + + if(my_id .eq. io_id) then + if(allocated(gLinkV_r4)) deallocate(gLinkV_r4) + endif + end subroutine updateLinkV8_mem + + subroutine updateLinkV4_mem(LinkV, outV) +! for big memory data + implicit none + real, dimension(:) :: outV + real, dimension(:) :: LinkV + real, allocatable, dimension(:) :: gLinkV_r4 + real, allocatable,dimension(:) :: tmpBuf + integer :: ierr, i, tag, k,m,lsize + integer, allocatable,dimension(:) :: lindex + if(my_id .eq. io_id) then + allocate(gLinkV_r4(gnlinksl)) + gLinkV_r4 = 0.0 + do i = 1, LLINKLEN + gLinkV_r4(LLINKIDINDX(i)) = LinkV(i) + end do + endif + + if(my_id .ne. IO_id) then + + tag = 101 + call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + if(LLINKLEN .gt. 0) then + tag = 102 + call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 103 + call mpi_send(LinkV,LLINKLEN,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + tag = 101 + call mpi_recv(lsize,1,MPI_INTEGER, i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(lsize .gt. 0) then + allocate(lindex(lsize) ) + allocate(tmpBuf(lsize) ) + tag = 102 + call mpi_recv(lindex,lsize,MPI_INTEGER, i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 103 + call mpi_recv(tmpBuf,lsize,& + MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, lsize + gLinkV_r4(lindex(k)) = gLinkV_r4(lindex(k)) + tmpBuf(k) + end do + if(allocated(lindex)) deallocate(lindex) + if(allocated(tmpBuf)) deallocate(tmpBuf) + endif + end if + end do + end if + + call ReachLS_decompReal(gLinkV_r4,outV) + + if(my_id .eq. io_id) then + if(allocated(gLinkV_r4)) deallocate(gLinkV_r4) + endif + end subroutine updateLinkV4_mem + + + subroutine updateLinkV8(LinkV, outV) + implicit none + real, dimension(:) :: outV + real*8, dimension(:) :: LinkV + real*8, dimension(gNlinksl) :: gLinkV,gLinkV_r + real, dimension(gNlinksl) :: gLinkV_r4 + integer :: ierr, i, tag + gLinkV = 0.0 + gLinkV_r = 0.0 + do i = 1, LLINKLEN + gLinkV(LLINKIDINDX(i)) = LinkV(i) + end do + + if(my_id .ne. IO_id) then + tag = 102 + call mpi_send(gLinkV,gnlinksl,MPI_DOUBLE_PRECISION, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + gLinkV_r = gLinkV + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + tag = 102 + call mpi_recv(gLinkV,gnlinksl,& + MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + gLinkV_r = gLinkV_r + gLinkV + end if + end do + end if + gLinkV_r4 = gLinkV_r + + call ReachLS_decompReal(gLinkV_r4,outV) + end subroutine updateLinkV8 + + subroutine updateLinkV4(LinkV, outV) + implicit none + real, dimension(:) :: outV + real, dimension(:) :: LinkV + real, dimension(gNlinksl) :: gLinkV,gLinkV_r + real, dimension(gNlinksl) :: gLinkV_r4 + integer :: ierr, i, tag + gLinkV = 0.0 + gLinkV_r = 0.0 + do i = 1, LLINKLEN + gLinkV(LLINKIDINDX(i)) = LinkV(i) + end do + + if(my_id .ne. IO_id) then + tag = 102 + call mpi_send(gLinkV,gnlinksl,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + gLinkV_r = gLinkV + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + tag = 102 + call mpi_recv(gLinkV,gnlinksl,& + MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + gLinkV_r = gLinkV_r + gLinkV + end if + end do + end if + gLinkV_r4 = gLinkV_r + call ReachLS_decompReal(gLinkV_r4,outV) + end subroutine updateLinkV4 + + subroutine gbcastReal(inV, outV) + implicit none + real, dimension(:) :: outV + real, dimension(:) :: inV + integer :: ierr + call ReachLS_write_io(inV,outV) + call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_REAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + end subroutine gbcastReal + + subroutine gbcastReal2_old(index,size1,inV, insize, outV) + implicit none + integer :: size1, insize + integer,dimension(:) :: index + real, dimension(:) :: outV + real, dimension(:) :: inV + real, dimension(max_nlinkSL) :: tmpV + integer :: ierr, k, i, m, j, bsize + outV = 0 + do i = 0, numprocs -1 + bsize = linkls_e(i+1) - linkls_s(i+1) + 1 + if(linkls_e(i+1) .gt. 0) then + if(my_id .eq. i) tmpV(1:bsize) = inV(1:bsize) + call mpi_bcast(tmpV(1:bsize),bsize,MPI_REAL, & + i,HYDRO_COMM_WORLD,ierr) + do j = 1, size1 + do k = 1, bsize + if(index(j) .eq. (linkls_s(i+1) + k -1) ) then + outV(j) = tmpV(k) + goto 100 + endif + end do + 100 continue + end do + + endif + end do + end subroutine gbcastReal2_old + + subroutine gbcastReal2(index,size1,inV, insize, outV) + implicit none + integer :: size1, insize + integer,dimension(:) :: index + real, dimension(:) :: outV + real, dimension(:) :: inV +! real, dimension(max_nlinkSL) :: tmpV + real, dimension(gnlinksl) :: gbuf + integer :: ierr, k, i, m, j, bsize + outV = 0 + call ReachLS_write_io(inV,gbuf) + call mpi_bcast(gbuf,gnlinksl,MPI_REAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + do j = 1, size1 + outV(j) = gbuf(index(j)) + end do + end subroutine gbcastReal2 + + + + + subroutine gbcastInt(inV, outV) + implicit none + integer, dimension(:) :: outV + integer, dimension(:) :: inV + integer :: ierr + call ReachLS_write_io(inV,outV) + call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + end subroutine gbcastInt + + + subroutine getLocalIndx(glinksl,LINKID, LLINKID) + implicit none + integer, dimension(:) :: LINKID, LLINKID + integer :: i,k, glinksl, ierr + integer :: gLinkId(glinksl) + LLINKLEN = size(LLINKID,1) + allocate(LLINKIDINDX(LLINKLEN)) + LLINKIDINDX = 0 + gNlinksl = glinksl + + call ReachLS_write_io(LINKID,gLinkId) + + call mpi_bcast(gLinkId(1:glinksl),glinksl,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + + do i = 1, LLINKLEN + do k = 1, glinksl + if(LLINKID(i) .eq. gLinkId(k)) then + LLINKIDINDX(i) = k + goto 1001 + endif + end do +1001 continue + end do + + call mpp_land_sync() + end subroutine getLocalIndx + + subroutine ReachLS_ini(glinksl,nlinksl,linklsS, linklsE) + implicit none + integer, intent(in) :: glinksl + integer, intent(out) :: nlinksl, linklsS, linklsE + integer :: i, ii, ierr + +! get my_id and numprocs + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + + + nlinksl = glinksl / numprocs + allocate(linkls_s(numprocs)) + allocate(linkls_e(numprocs)) + allocate(aLinksl(numprocs)) + allocate(ToInd(numprocs)) + + ToInd = -1 + + linkls_s(1) = 1 + linkls_e(1) = nlinksl + aLinksl = nlinksl + + do i = 2, mod(glinksl, numprocs)+1 + aLinksl(i) = aLinksl(i) + 1 + end do + do i = 2, numprocs + linkls_s(i) = linkls_e(i-1)+1 + linkls_e(i) = linkls_s(i) + aLinksl(i)-1 + end do + + nlinksl = aLinksl(my_id+1) + + linklsS = linkls_s(my_id+1) + linklsE = linkls_e(my_id+1) + tmpnlinksl = aLinksl(my_id+1) + l_nlinksl = nlinksl + + max_nlinksl = l_nlinksl + call mpp_land_max_int1(max_nlinksl) + + gNlinksl = glinksl + end subroutine ReachLS_ini + + subroutine MapGrid2ReachIni(in2d) + implicit none + integer, intent(in),dimension(:,:) :: in2d + integer :: ix, jx, i,j,n,ntotal, ierr + integer, dimension(numprocs) :: tmpS + + allocate(sDataRec(numprocs)) + allocate(rDataRec(numprocs)) + + ntotal = 0 + sDataRec = 0 + rDataRec = 0 + ix = size(in2d,1) + jx = size(in2d,2) + do j = 1, jx + do i = 1, ix + if(in2d(i,j) .gt. 0) then + do n = 1, numprocs + if((in2d(i,j) .ge. linkls_s(n)) .and. (in2d(i,j) .le. linkls_e(n)) ) then + sDataRec(n) = sDataRec(n) + 1 + endif + end do + endif + enddo + enddo + + do n = 1, numprocs + if(my_id .eq. n-1) then + tmpS = sDataRec + endif + call mpi_bcast(tmpS,numprocs,MPI_INTEGER, & + n-1,HYDRO_COMM_WORLD,ierr) + rDataRec(n) = tmpS(n) + enddo + + end subroutine MapGrid2ReachIni + + + subroutine ReachLS_decompReal(inV,outV) + implicit none + real,INTENT(in),dimension(:) :: inV + real,INTENT(out),dimension(:) :: outV + integer :: i, ierr, tag + tag = 11 + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(1:(linkls_e(i)-linkls_s(i)+1) ) = inV(linkls_s(i):linkls_e(i)) + endif + else + if(aLinksl(i) .gt. 0) then + call mpi_send(inV(linkls_s(i):linkls_e(i)), & + aLinksl(i), & + MPI_REAL, i-1 ,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + call mpi_recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! + aLinksl(my_id+1), & + MPI_REAL, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + call mpp_land_sync() + END subroutine ReachLS_decompReal + + subroutine ReachLS_decompInt(inV,outV) + implicit none + integer,INTENT(in),dimension(:) :: inV + integer,INTENT(out),dimension(:) :: outV + integer :: i, ierr, tag + tag = 11 + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(1:linkls_e(i)-linkls_s(i)+1) = inV(linkls_s(i):linkls_e(i)) + endif + else + if(aLinksl(i) .gt. 0) then + call mpi_send(inV(linkls_s(i):linkls_e(i)), & + aLinksl(i), & + MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + call mpi_recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & + alinksl(my_id+1), & + MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + + call mpp_land_sync() + + END subroutine ReachLS_decompInt + + + subroutine ReachLS_decompChar(inV,outV) + implicit none + character(len=*),intent(in), dimension(:) :: inV + character(len=*),intent(out),dimension(:) :: outV + integer :: i, ierr, tag + integer :: strLen + strLen = len(inV(1)) + tag = 11 + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(1:(linkls_e(i)-linkls_s(i)+1)) = inV(linkls_s(i):linkls_e(i)) + endif + else + if(aLinksl(i) .gt. 0) then + ! The mpi_send takes what you give it and THEN treats each caracter as an array element. + call mpi_send(inV(linkls_s(i):linkls_e(i)), & + aLinksl(i), & + MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, ierr) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + ! The mpi_recv treats each caracter as an array element. + call mpi_recv(outV(1 : ((linkls_e(my_id+1)-linkls_s(my_id+1)+1)) ), & !jlm should have +1 + alinksl(my_id+1), & + MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, mpp_status,ierr ) + endif + endif + call mpp_land_sync() + end subroutine ReachLS_decompChar + + + subroutine ReachLS_wReal(inV,outV) + implicit none + real,INTENT(in),dimension(:) :: inV + real,INTENT(out),dimension(:) :: outV + integer :: i, ierr, tag, ss , mm + outV = 0 + if(my_id .eq. io_id) then + do i = 1, numprocs + tag = 12 + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1) + endif + else + if(aLinksl(i) .gt. 0) then + + call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + aLinksl(i), & + MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + tag = 12 + ss = size(inv,1) + call mpi_send(inV(1:aLinksl(my_id+1) ), & + aLinksl(my_id+1), & + MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + call mpp_land_sync() + END subroutine ReachLS_wReal + + subroutine ReachLS_wInt(inV,outV) + implicit none + integer,INTENT(in),dimension(:) :: inV + integer,INTENT(out),dimension(:) :: outV + integer :: i, ierr, tag + outV = 0 + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1) + endif + else + if(aLinksl(i) .gt. 0) then + tag = 12 + call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + aLinksl(i), & + MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + tag = 12 + call mpi_send(inV(1:aLinksl(my_id+1) ), & + aLinksl(my_id+1), & + MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + call mpp_land_sync() + END subroutine ReachLS_wInt + + + subroutine ReachLS_wInt2(inV,outV,len,glen) + implicit none + integer :: len, glen + integer,INTENT(in),dimension(len) :: inV + integer,INTENT(out),dimension(glen) :: outV + integer :: i, ierr, tag + outV = 0 + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1) + endif + else + if(aLinksl(i) .gt. 0) then + tag = 12 + call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + aLinksl(i), & + MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + tag = 12 + call mpi_send(inV(1:aLinksl(my_id+1) ), & + aLinksl(my_id+1), & + MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + call mpp_land_sync() + END subroutine ReachLS_wInt2 + + subroutine ReachLS_wReal2(inV,outV,len,glen) + implicit none + integer :: len, glen + real,INTENT(in),dimension(len) :: inV + real,INTENT(out),dimension(glen) :: outV + integer :: i, ierr, tag + outV = 0 + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1) + endif + else + if(aLinksl(i) .gt. 0) then + tag = 12 + call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + aLinksl(i), & + MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + tag = 12 + call mpi_send(inV(1:aLinksl(my_id+1) ), & + aLinksl(my_id+1), & + MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + call mpp_land_sync() + END subroutine ReachLS_wReal2 + + subroutine ReachLS_wChar(inV,outV) + implicit none + character(len=*), intent(in), dimension(:) :: inV + character(len=*) ,intent(out),dimension(:) :: outV + integer :: i, ierr, tag + integer :: strLen + strLen = len(inV(1)) + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + if(alinksl(i) .gt. 0) then + outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1) + endif + else + if(aLinksl(i) .gt. 0) then + tag = 12 + ! ? seems asymmetric with ReachLS_decompChar + call mpi_recv(outV( linkls_s(i) : linkls_e(i) ), & +! call mpi_recv(outV( ((linkls_s(i)-1)+1) : (linkls_e(i)) ), & + aLinksl(i), & + MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, mpp_status, ierr ) + endif + endif + end do + else + if(aLinksl(my_id+1) .gt. 0) then + tag = 12 + ! The mpi_send takes what you give it and THEN treats each caracter as an array element. + call mpi_send(inV(1:aLinksl(my_id+1)), & + aLinksl(my_id+1), & + MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, ierr) + endif + endif + call mpp_land_sync() + end subroutine ReachLS_wChar + + + subroutine getFromInd(linkid,to,ind,indLen) + integer,dimension(:) :: linkid, to + integer, allocatable, dimension(:) ::ind + integer :: k, m, kk, mm,indLen + integer, dimension(gnlinksl) :: glinkid + call ReachLS_write_io(linkid,glinkid) + mm = size(to,1) + kk = 0 + do k = 1, gnlinksl + do m = 1, mm + if(glinkid(k) .eq. to(m) ) then + kk = kk +1 + goto 2001 + endif + end do +2001 continue + end do + allocate(ind(kk)) + kk = 0 + do k = 1, gnlinksl + do m = 1, mm + if(glinkid(k) .eq. to(m) ) then + kk = kk +1 + ind(kk) = glinkid(k) + goto 2002 + endif + end do +2002 continue + end do + indLen = kk + + end subroutine getFromInd + + subroutine getToInd(from,to,ind,indLen,gToNodeOut) + integer,dimension(:) :: from, to + integer, allocatable, dimension(:) ::ind + integer, allocatable, dimension(:,:) :: gToNodeOut + integer :: k, m, kk, mm,indLen, i, ierr + integer, dimension(gnlinksl) :: gto + integer:: maxNum,num + + call gBcastValue(to,gto) + +! mm = size(from,1) + mm = l_nlinksl + + maxNum = 0 + + kk = 0 + do m = 1, mm + num = 0 + do k = 1, gnlinksl + if(gto(k) .eq. from(m) ) then + kk = kk +1 + num = num + 1 + endif + end do + if(num .gt. maxNum) maxNum = num + end do + + allocate(ind(kk)) + allocate(gToNodeOut(mm,maxNum+1)) + gToNodeOut = -99 + + indLen = kk + + kk = 0 + do m = 1, mm + num = 1 + do k = 1, gnlinksl + if(gto(k) .eq. from(m) ) then + kk = kk +1 + !yw ind(kk) = gto(k) + ind(kk) = k + !! gToNodeOut(m,num+1) = gto(k) + gToNodeOut(m,num+1) = kk + gToNodeOut(m,1) = num + num = num + 1 + endif + end do + end do + ToInd(my_id+1) = kk + do i = 0, numprocs - 1 + call mpi_bcast(ToInd(i+1),1,MPI_INTEGER, & + i,HYDRO_COMM_WORLD,ierr) + end do + + end subroutine getToInd + + subroutine com_decomp1dInt(inV,gsize,outV,lsize) +! output outV and lsize + implicit none + integer,INTENT(in),dimension(:) :: inV + integer,allocatable,dimension(:) :: outV + integer :: i, ierr, tag, imod, ncomsize + integer :: lsize, ssize,start, gsize, end + tag = 19 + ncomsize = gsize/numprocs + imod = mod(gsize,numprocs) + + + if(my_id .eq. io_id) then + start = 0 + end = 0 + do i = 1, numprocs + if(i-1 .lt. imod) then + ssize = ncomsize + 1 + else + ssize = ncomsize + endif + + start = end + 1 + end = start + ssize - 1 + + if(i-1 .eq. io_id) then + if(ssize .gt. 0) then + allocate(outV(ssize) ) + outV(1:ssize) = inV(1:ssize) + lsize = ssize + else + lsize = 0 + endif + else + if(ssize .gt. 0 ) then + call mpi_send(inV(start:start+ssize-1), ssize, & + MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + end do + else + if(my_id .lt. imod) then + lsize = ncomsize + 1 + else + lsize = ncomsize + endif + if( lsize .gt. 0) then + allocate(outV(lsize) ) + call mpi_recv(outV,lsize, & + MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + call mpp_land_sync() + + + END subroutine com_decomp1dInt + + subroutine com_write1dInt(inV,lsize,outV,gsize) +! output outV and lsize + implicit none + integer,INTENT(in),dimension(:) :: inV + integer,dimension(:) :: outV + integer :: i, ierr, tag, imod, ncomsize + integer :: lsize, rsize,start, gsize, end + tag = 18 + ncomsize = gsize/numprocs + imod = mod(gsize,numprocs) + + if(my_id .eq. io_id) then + start = 0 + end = 0 + do i = 1, numprocs + if(i-1 .lt. imod) then + rsize = ncomsize + 1 + else + rsize = ncomsize + endif + + start = end + 1 + end = start + rsize - 1 + + if(i-1 .eq. io_id) then + if(rsize .gt. 0) then + outV(1:rsize) = inV(1:rsize) + endif + else + if(rsize .gt. 0 ) then + call mpi_recv(outV(start:start+rsize-1), rsize, & + MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif + end do + else + if(my_id .lt. imod) then + lsize = ncomsize + 1 + else + lsize = ncomsize + endif + if( lsize .gt. 0) then + call mpi_send(inV, lsize, & + MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + + call mpp_land_sync() + + END subroutine com_write1dInt + + subroutine pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) + implicit none + integer :: ndata + integer, dimension(:) :: g1bufid, nprocs_map, lnsizes, bufid + integer :: i,j,k, tag, ierr + integer, allocatable,dimension(:) :: buf + integer, dimension(:) :: istart + integer, dimension(numprocs) :: count + ! pack data + + + if(my_id .eq. io_id) then + allocate(buf(ndata)) + count = 0 + do i = 1, ndata + k = nprocs_map(i) + if( k .gt. 0) then + buf(istart(k) + count(k)) = g1bufid(i) + count(k) = count(k) + 1 + end if + end do +! write(6,*) " count = ", count +! write(6,*) " istart = ", istart +! write(6,*) " lnsizes = ", lnsizes + end if + !finish packing + + call mpp_land_sync() +! call hydro_finish() + + if(my_id .ne. IO_id) then + tag = 72 + if(lnsizes(my_id + 1) .gt. 0) then + call mpi_recv(bufid,lnsizes(my_id + 1),& + MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + else + do i = 0, numprocs - 1 + if(i .ne. my_id) then + tag = 72 + if(lnsizes(i+1) .gt. 0) then + call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + lnsizes(i+1),MPI_INTEGER,i, tag,HYDRO_COMM_WORLD,ierr) + endif + else + if(lnsizes(i+1) .gt. 0) then + bufid = buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1) + endif + end if + end do + end if + if(my_id .eq. io_id) then + if(allocated(buf)) deallocate(buf) + endif + end subroutine pack_decomp_int + + subroutine pack_decomp_real8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) + implicit none + integer :: ndata + real*8, dimension(:) :: g1bufid, bufid + integer,dimension(:) :: nprocs_map, lnsizes + integer :: i,j,k, tag, ierr + real*8, allocatable,dimension(:) :: buf + integer, dimension(:) :: istart + integer, dimension(numprocs) :: count + ! pack data + if(my_id .eq. io_id) then + allocate(buf(ndata)) + count = 0 + do i = 1, ndata + k = nprocs_map(i) + if( k .gt. 0) then + buf(istart(k) + count(k)) = g1bufid(i) + count(k) = count(k) + 1 + endif + end do + end if + call mpp_land_sync() + if(my_id .ne. IO_id) then + tag = 72 + if(lnsizes(my_id + 1) .gt. 0) then + call mpi_recv(bufid,lnsizes(my_id + 1),& + MPI_DOUBLE_PRECISION,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + else + do i = 0, numprocs - 1 + if(i .ne. my_id) then + tag = 72 + if(lnsizes(i+1) .gt. 0) then + call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + lnsizes(i+1),MPI_DOUBLE_PRECISION,i, tag,HYDRO_COMM_WORLD,ierr) + endif + else + if(lnsizes(my_id + 1) .gt. 0) then + bufid = buf(istart(i + 1):istart(i+1)+lnsizes(i+1)-1) + endif + end if + end do + end if + if(my_id .eq. io_id) then + if(allocated(buf)) deallocate(buf) + endif + end subroutine pack_decomp_real8 + +! this is used for nhdPlus with Lake. +! resolve the data from TO_NODE grids, and update back to NLINKSL grids. + subroutine TONODE2RSL (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) + implicit none + integer,intent(in) :: size,gNLINKSL,NLINKSL ! + integer,intent(in) , dimension(size) :: ind, inVar + integer,intent(inout), dimension(nlinksl) :: ioVar + integer, allocatable, dimension(:) :: gvar, buf, tmpInd + integer :: i,j,k, tag, ierr, tmpSize, flag + + if(gNLINKSL .le. 0) return + + if(my_id .eq. io_id) then + allocate(gvar(gNLINKSL)) + else + allocate(gvar(1)) + endif + call ReachLS_wInt(ioVar,gvar) + + if(my_id .eq. io_id) then + do i = 1, numprocs + if(i-1 .eq. io_id) then + do k = 1, size + if(inVar(k) .ne. flag) then + gvar(ind(k)) = inVar(k) + endif + end do + else + tag = 82 + call mpi_recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(tmpSize .gt. 0) then + allocate(buf(tmpSize)) + allocate(tmpInd(tmpSize)) + tag = 83 + call mpi_recv(tmpInd, tmpSize , & + MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 84 + call mpi_recv(buf, tmpSize , & + MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, tmpSize + if(buf(k) .ne. flag) then + gvar(tmpInd(k)) = buf(k) + endif + end do + if(allocated(buf)) deallocate(buf) + if(allocated(tmpInd)) deallocate(tmpInd) + endif + endif + end do + else + tag = 82 + call mpi_send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + if(size .gt. 0) then + tag = 83 + call mpi_send(ind(1:size),size, & + MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + tag = 84 + call mpi_send(inVar(1:size),size, & + MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + endif + endif + call ReachLS_decomp(gvar, ioVar) + if(allocated(gvar)) deallocate(gvar) + end subroutine TONODE2RSL + + +END MODULE MODULE_mpp_ReachLS + + diff --git a/wrfv2_fire/hydro/MPP/mpp_land.F b/wrfv2_fire/hydro/MPP/mpp_land.F new file mode 100644 index 00000000..4ce51167 --- /dev/null +++ b/wrfv2_fire/hydro/MPP/mpp_land.F @@ -0,0 +1,2346 @@ +! Program Name: +! 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: + +!#### This is a module for parallel Land model. +MODULE MODULE_MPP_LAND + + use MODULE_CPL_LAND + + IMPLICIT NONE + include "mpif.h" + !integer, public :: HYDRO_COMM_WORLD ! communicator for WRF-Hydro - moved to MODULE_CPL_LAND + integer, public :: left_id,right_id,up_id,down_id,my_id + integer, public :: left_right_np,up_down_np ! define total process in two dimensions. + integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography. + integer, public :: IO_id ! the number for IO. (Last processor for IO) + integer, public :: global_nx, global_ny, local_nx,local_ny + integer, public :: global_rt_nx, global_rt_ny + integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT + integer, public :: numprocs ! total process, get by mpi initialization. + integer :: local_startx, local_starty + integer :: local_startx_rt, local_starty_rt, local_endx_rt, local_endy_rt + + integer mpp_status(MPI_STATUS_SIZE) + + integer overlap_n + integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size + integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size + integer, allocatable, DIMENSION(:), public :: startx,starty + integer, allocatable, DIMENSION(:), public :: mpp_nlinks + + interface check_land + module procedure check_landreal1 + module procedure check_landreal1d + module procedure check_landreal2d + module procedure check_landreal3d + end interface + interface write_io_land + module procedure write_io_real3d + end interface + interface mpp_land_bcast + module procedure mpp_land_bcast_real2 + module procedure mpp_land_bcast_real_1d + module procedure mpp_land_bcast_real8_1d + module procedure mpp_land_bcast_real1 + module procedure mpp_land_bcast_char1d + module procedure mpp_land_bcast_char1 + module procedure mpp_land_bcast_int1 + module procedure mpp_land_bcast_int1d + module procedure mpp_land_bcast_int2d + module procedure mpp_land_bcast_logical + + end interface + + contains + + subroutine LOG_MAP2d() + implicit none + integer :: ndim, ierr + integer, dimension(0:1) :: dims, coords + + logical cyclic(0:1), reorder + data cyclic/.false.,.false./ ! not cyclic + data reorder/.false./ + + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + + call getNX_NY(numprocs, left_right_np,up_down_np) + if(my_id.eq.IO_id) then +#ifdef HYDRO_D + write(6,*) "" + write(6,*) "total process:",numprocs + write(6,*) "left_right_np =", left_right_np,& + "up_down_np=",up_down_np +#endif + end if + +! ### get the row and column of the current process in the logical topography. +! ### left --> right, 0 -->left_right_np -1 +! ### up --> down, 0 --> up_down_np -1 + left_right_p = mod(my_id , left_right_np) + up_down_p = my_id / left_right_np + +! ### get the neighbors. -1 means no neighbor. + down_id = my_id - left_right_np + up_id = my_id + left_right_np + if( up_down_p .eq. 0) down_id = -1 + if( up_down_p .eq. (up_down_np-1) ) up_id = -1 + + left_id = my_id - 1 + right_id = my_id + 1 + if( left_right_p .eq. 0) left_id = -1 + if( left_right_p .eq. (left_right_np-1) ) right_id =-1 + +! ### the IO node is the last processor. +!yw IO_id = numprocs - 1 + IO_id = 0 + +! print the information for debug. + +! BF setup virtual cartesian grid topology + ndim = 2 + + dims(0) = up_down_np ! rows + dims(1) = left_right_np ! columns +! + call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & + cyclic, reorder, cartGridComm, ierr) + + call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) + + p_up_down = coords(0) + p_left_right = coords(1) + np_up_down = up_down_np + np_left_right = left_right_np + + + call mpp_land_sync() + + return + end subroutine log_map2d +!old subroutine MPP_LAND_INIT(flag, ew_numprocs, sn_numprocs) + subroutine MPP_LAND_INIT() +! ### initialize the land model logically based on the two D method. +! ### Call this function directly if it is nested with WRF. + implicit none + integer :: ierr + integer :: ew_numprocs, sn_numprocs ! input the processors in x and y direction. + logical mpi_inited + +! left_right_np = ew_numprocs +! up_down_np = sn_numprocs + + CALL mpi_initialized( mpi_inited, ierr ) + if ( .NOT. mpi_inited ) then + call MPI_INIT( ierr ) ! stand alone land model. + HYDRO_COMM_WORLD = MPI_COMM_WORLD + else + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + return + endif +! create 2d logical mapping of the CPU. + call log_map2d() + return + end subroutine MPP_LAND_INIT + + + subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) + integer in_global_nx,in_global_ny, AGGFACTRT + integer :: over_lap ! the overlaped grid number. (default is 1) + integer :: i + + global_nx = in_global_nx + global_ny = in_global_ny + rt_AGGFACTRT = AGGFACTRT + global_rt_nx = in_global_nx*AGGFACTRT + global_rt_ny = in_global_ny *AGGFACTRT + !overlap_n = 1 +!ywold local_nx = global_nx / left_right_np +!ywold if(left_right_p .eq. (left_right_np-1) ) then +!ywold local_nx = global_nx & +!ywold -int(global_nx/left_right_np)*(left_right_np-1) +!ywold end if +!ywold local_ny = global_ny / up_down_np +!ywold if( up_down_p .eq. (up_down_np-1) ) then +!ywold local_ny = global_ny & +!ywold -int(global_ny/up_down_np)*(up_down_np -1) +!ywold end if + + local_nx = int(global_nx / left_right_np) + !if(global_nx .ne. (local_nx*left_right_np) ) then + if(mod(global_nx, left_right_np) .ne. 0) then + do i = 1, mod(global_nx, left_right_np) + if(left_right_p .eq. i ) then + local_nx = local_nx + 1 + end if + end do + end if + + local_ny = int(global_ny / up_down_np) + !if(global_ny .ne. (local_ny * up_down_np) ) then + if(mod(global_ny,up_down_np) .ne. 0 ) then + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .eq. i) then + local_ny = local_ny + 1 + end if + end do + end if + + local_rt_nx=local_nx*AGGFACTRT+2 + local_rt_ny=local_ny*AGGFACTRT+2 + if(left_id.lt.0) local_rt_nx = local_rt_nx -1 + if(right_id.lt.0) local_rt_nx = local_rt_nx -1 + if(up_id.lt.0) local_rt_ny = local_rt_ny -1 + if(down_id.lt.0) local_rt_ny = local_rt_ny -1 + + call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny) + call calculate_start_p() + + in_global_nx = local_nx + in_global_ny = local_ny +#ifdef HYDRO_D + write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx + write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny + write(6,*) "my_id=",my_id,"global_nx=",global_nx + write(6,*) "my_id=",my_id,"global_nx=",global_ny +#endif + return + end subroutine MPP_LAND_PAR_INI + + subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) +! ### Communicate message on left right direction. + integer NX,NY + real in_out_data(nx,ny),data_r(2,ny) + integer count,size,tag, ierr + integer flag ! 99 replace the boundary, else get the sum. + + if(flag .eq. 99) then ! replace the data + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = ny + call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = ny + call mpi_recv(in_out_data(1,:),size,MPI_REAL, & + left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = ny + tag = 21 + call mpi_send(in_out_data(2,:),size,MPI_REAL, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = ny + call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + else ! get the sum + + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = 2*ny + call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = 2*ny + call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & + HYDRO_COMM_WORLD,mpp_status,ierr) + in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) + in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = 2*ny + tag = 21 + call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = 2*ny + call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + endif ! end if black for flag. + + return + end subroutine MPP_LAND_LR_COM + + subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) +! ### Communicate message on left right direction. + integer NX,NY + real*8 in_out_data(nx,ny),data_r(2,ny) + integer count,size,tag, ierr + integer flag ! 99 replace the boundary, else get the sum. + + if(flag .eq. 99) then ! replace the data + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = ny + call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = ny + call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = ny + tag = 21 + call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = ny + call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + else ! get the sum + + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = 2*ny + call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & + right_id,tag,HYDRO_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = 2*ny + call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & + HYDRO_COMM_WORLD,mpp_status,ierr) + in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) + in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = 2*ny + tag = 21 + call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = 2*ny + call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& + right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + endif ! end if black for flag. + + return + end subroutine MPP_LAND_LR_COM8 + + + subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) + integer local_nx, local_ny, rt_nx,rt_ny + integer i,status,ierr, tag + integer tmp_nx,tmp_ny +! ### if it is IO node, get the local_size of the x and y direction +! ### for all other tasks. + integer s_r(2) + +! if(my_id .eq. IO_id) then + allocate(local_nx_size(numprocs),stat = status) + allocate(local_ny_size(numprocs),stat = status) + allocate(local_rt_nx_size(numprocs),stat = status) + allocate(local_rt_ny_size(numprocs),stat = status) +! end if + + call mpp_land_sync() + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 1 + call mpi_recv(s_r,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + local_nx_size(i+1) = s_r(1) + local_ny_size(i+1) = s_r(2) + else + local_nx_size(i+1) = local_nx + local_ny_size(i+1) = local_ny + end if + end do + else + tag = 1 + s_r(1) = local_nx + s_r(2) = local_ny + call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 2 + call mpi_recv(s_r,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + local_rt_nx_size(i+1) = s_r(1) + local_rt_ny_size(i+1) = s_r(2) + else + local_rt_nx_size(i+1) = rt_nx + local_rt_ny_size(i+1) = rt_ny + end if + end do + else + tag = 2 + s_r(1) = rt_nx + s_r(2) = rt_ny + call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + call mpp_land_sync() + return + end subroutine get_local_size + + + subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) +! ### Communicate message on up down direction. + integer NX,NY + real in_out_data(nx,ny),data_r(nx,2) + integer count,size,tag, status, ierr + integer flag ! 99 replace the boundary , else get the sum of the boundary + + + if(flag .eq. 99) then ! replace the boundary data. + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx + call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx + call mpi_recv(in_out_data(:,1),size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx + call mpi_send(in_out_data(:,2),size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx + call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + else ! flag = 1 + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx*2 + call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx*2 + call mpi_recv(data_r,size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) + in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx*2 + call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx * 2 + call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif ! end of block flag + return + end subroutine MPP_LAND_UB_COM + + subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) +! ### Communicate message on up down direction. + integer NX,NY + real*8 in_out_data(nx,ny),data_r(nx,2) + integer count,size,tag, status, ierr + integer flag ! 99 replace the boundary , else get the sum of the boundary + + + if(flag .eq. 99) then ! replace the boundary data. + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx + call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx + call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx + call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx + call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + + else ! flag = 1 + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx*2 + call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx*2 + call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) + in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) + in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx*2 + call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & + down_id,tag,HYDRO_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx * 2 + call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + endif ! end of block flag + return + end subroutine MPP_LAND_UB_COM8 + + subroutine calculate_start_p() +! calculate startx and starty + integer :: i,status, ierr, tag + integer :: r_s(2) + integer :: t_nx, t_ny + + allocate(starty(numprocs),stat = ierr) + allocate(startx(numprocs),stat = ierr) + + local_startx = int(global_nx/left_right_np) * left_right_p+1 + local_starty = int(global_ny/up_down_np) * up_down_p+1 + +!ywold + t_nx = 0 + do i = 1, mod(global_nx,left_right_np) + if(left_right_p .gt. i ) then + t_nx = t_nx + 1 + end if + end do + local_startx = local_startx + t_nx + + t_ny = 0 + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .gt. i) then + t_ny = t_ny + 1 + end if + end do + local_starty = local_starty + t_ny + + + if(left_id .lt. 0) local_startx = 1 + if(down_id .lt. 0) local_starty = 1 + + + if(my_id .eq. IO_id) then + startx(my_id+1) = local_startx + starty(my_id+1) = local_starty + end if + + r_s(1) = local_startx + r_s(2) = local_starty + call mpp_land_sync() + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ! block receive from other node. + if(i.ne.my_id) then + tag = 1 + call mpi_recv(r_s,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + startx(i+1) = r_s(1) + starty(i+1) = r_s(2) + end if + end do + else + tag = 1 + call mpi_send(r_s,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + + call mpp_land_sync() + +! calculate the routing land start x and y + local_startx_rt = local_startx*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(local_startx_rt.gt.1) local_startx_rt=local_startx_rt - 1 + local_starty_rt = local_starty*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(local_starty_rt.gt.1) local_starty_rt=local_starty_rt - 1 + + local_endx_rt = local_startx_rt + local_rt_nx -1 + local_endy_rt = local_starty_rt + local_rt_ny -1 + + return + end subroutine calculate_start_p + + subroutine decompose_data_real3d (in_buff,out_buff,klevel) + implicit none + integer:: klevel, k + real,dimension(:,:,:) :: in_buff,out_buff + do k = 1, klevel + call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine decompose_data_real3d + + + subroutine decompose_data_real (in_buff,out_buff) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + real,intent(in), dimension(:,:) :: in_buff + real,intent(out), dimension(local_nx,local_ny) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = local_nx_size(i+1)*local_ny_size(i+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = local_nx*local_ny + call mpi_recv(out_buff,size,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_data_real + + + subroutine decompose_data_int (in_buff,out_buff) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer,dimension(:,:) :: in_buff,out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = local_nx_size(i+1)*local_ny_size(i+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = local_nx*local_ny + call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_data_int + + subroutine write_IO_int(in_buff,out_buff) +! the IO node will receive the data from the rest process. + integer,dimension(:,:):: in_buff, out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_nx*local_ny + tag = 2 + call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_nx_size(i+1)*local_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_int + + subroutine write_IO_char_head(in, out, imageHead) + !! JLM 2015-11-30 + !! for i is image number (starting from 0), + !! this routine writes + !! in(1:imageHead(i+1)) + !! to + !! out( (sum(imageHead(i+1-1))+1) : ((sum(imageHead(i+1-1))+1)+imageHead(i+1)) ) + !! where out is on the IO node. + character(len=*), intent(in), dimension(:) :: in + character(len=*), intent(out), dimension(:) :: out + integer, intent(in), dimension(:) :: imageHead + integer :: tag, i, status, ierr, size + integer :: ibegin,iend,jbegin,jend + integer :: lenSize, theStart, theEnd + tag = 2 + if(my_id .ne. IO_id) then + lenSize = imageHead(my_id+1)*len(in(1)) !! some times necessary for character arrays? + if(lenSize .eq. 0) return + call mpi_send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs-1 + lenSize = imageHead(i+1)*len(in(1)) !! necessary? + if(lenSize .eq. 0) cycle + if(i .eq. 0) then + theStart = 1 + else + theStart = sum(imageHead(1:(i+1-1))) +1 + end if + theEnd = theStart + imageHead(i+1) -1 + if(i .eq. IO_id) then + out(theStart:theEnd) = in(1:imageHead(i+1)) + else + call mpi_recv(out(theStart:theEnd),lenSize,& + MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + end subroutine write_IO_char_head + + + subroutine write_IO_real3d(in_buff,out_buff,klevel) + implicit none +! the IO node will receive the data from the rest process. + integer klevel, k + real,dimension(:,:,:):: in_buff, out_buff + do k = 1, klevel + call write_IO_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine write_IO_real3d + + subroutine write_IO_real(in_buff,out_buff) +! the IO node will receive the data from the rest process. + real,dimension(:,:):: in_buff, out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_nx*local_ny + tag = 2 + call mpi_send(in_buff,size,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_nx_size(i+1)*local_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_real + + subroutine write_IO_RT_real(in_buff,out_buff) +! the IO node will receive the data from the rest process. + real,dimension(:,:) :: in_buff, out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_rt_nx*local_rt_ny + tag = 2 + call mpi_send(in_buff,size,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_RT_real + + + subroutine write_IO_RT_int (in_buff,out_buff) +! the IO node will receive the data from the rest process. + integer,intent(in),dimension(:,:) :: in_buff + integer,intent(out),dimension(:,:) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_rt_nx*local_rt_ny + tag = 2 + call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_RT_int + + subroutine mpp_land_bcast_log1(inout) + logical inout + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_log1 + + + subroutine mpp_land_bcast_int(size,inout) + integer size + integer inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int + + subroutine mpp_land_bcast_int1d(inout) + integer len + integer inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int1d + + subroutine mpp_land_bcast_int1d_root(inout, rootId) + integer len + integer inout(:) + integer, intent(in) :: rootId + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int1d_root + + subroutine mpp_land_bcast_int1(inout) + integer inout + integer ierr + call mpi_bcast(inout,1,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int1 + + subroutine mpp_land_bcast_int1_root(inout, rootId) + integer inout + integer ierr + integer, intent(in) :: rootId + call mpi_bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int1_root + + subroutine mpp_land_bcast_logical(inout) + logical :: inout + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_logical + + subroutine mpp_land_bcast_logical_root(inout, rootId) + logical :: inout + integer, intent(in) :: rootId + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_logical_root + + + subroutine mpp_land_bcast_real1(inout) + real inout + integer ierr + call mpi_bcast(inout,1,MPI_REAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real1 + + subroutine mpp_land_bcast_real_1d(inout) + integer len + real inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_real, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real_1d + + + subroutine mpp_land_bcast_real_1d_root(inout, rootId) + integer len + real inout(:) + integer, intent(in) :: rootId + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_real,rootId,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real_1d_root + + + subroutine mpp_land_bcast_real8_1d(inout) + integer len + real*8 inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_double, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real8_1d + + + subroutine mpp_land_bcast_real(size1,inout) + integer size1 + ! real inout(size1) + real , dimension(:) :: inout + integer ierr, len + call mpi_bcast(inout,size1,MPI_real, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real + + subroutine mpp_land_bcast_int2d(inout) + integer length1, k,length2 + integer inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & + IO_id,HYDRO_COMM_WORLD,ierr) + end do + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int2d + + subroutine mpp_land_bcast_real2(inout) + integer length1, k,length2 + real inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_real, & + IO_id,HYDRO_COMM_WORLD,ierr) + end do + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real2 + + subroutine mpp_land_bcast_real3d(inout) + integer j, k, length1, length2, length3 + real inout(:,:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + length3 = size(inout,3) + do k = 1, length3 + do j = 1, length2 + call mpi_bcast(inout(:,j,k), length1, MPI_real, & + IO_id, HYDRO_COMM_WORLD, ierr) + end do + end do + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real3d + + subroutine mpp_land_bcast_rd(size,inout) + integer size + real*8 inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_REAL8, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_rd + + subroutine mpp_land_bcast_char(size,inout) + integer size + character inout(*) + integer ierr + call mpi_bcast(inout,size,MPI_CHARACTER, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char + + subroutine mpp_land_bcast_char_root(size,inout,rootId) + integer size + character inout(*) + integer, intent(in) :: rootId + integer ierr + call mpi_bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char_root + + + subroutine mpp_land_bcast_char1d(inout) + character(len=*) :: inout(:) + integer :: lenSize + integer :: ierr + lenSize = size(inout,1)*len(inout) + call mpi_bcast(inout,lenSize,MPI_CHARACTER, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char1d + + subroutine mpp_land_bcast_char1d_root(inout,rootId) + character(len=*) :: inout(:) + integer, intent(in) :: rootId + integer :: lenSize + integer :: ierr + lenSize = size(inout,1)*len(inout) + call mpi_bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char1d_root + + subroutine mpp_land_bcast_char1(inout) + integer len + character(len=*) inout + integer ierr + len = LEN_TRIM(inout) + call mpi_bcast(inout,len,MPI_CHARACTER, & + IO_id,HYDRO_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char1 + + + subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + real in_out_data(nx,ny) + + call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) + + return + end subroutine MPP_LAND_COM_REAL + + subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + real*8 in_out_data(nx,ny) + + call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) + + return + end subroutine MPP_LAND_COM_REAL8 + + subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + integer data(nx,ny) + real in_out_data(nx,ny) + + in_out_data = data + 0.0 + call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) + data = in_out_data + 0 + + return + end subroutine MPP_LAND_COM_INTEGER + + subroutine read_restart_3(unit,nz,out) + integer unit,nz,i + real buf3(global_nx,global_ny,nz),& + out(local_nx,local_ny,3) + if(my_id.eq.IO_id) read(unit) buf3 + do i = 1,nz + call decompose_data_real (buf3(:,:,i),out(:,:,i)) + end do + return + end subroutine read_restart_3 + + subroutine read_restart_2(unit,out) + integer unit,ierr2 + real buf2(global_nx,global_ny),& + out(local_nx,local_ny) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 + call mpp_land_bcast_int1(ierr2) + if(ierr2 .ne. 0) return + + call decompose_data_real (buf2,out) + return + end subroutine read_restart_2 + + subroutine read_restart_rt_2(unit,out) + integer unit,ierr2 + real buf2(global_rt_nx,global_rt_ny),& + out(local_rt_nx,local_rt_ny) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 + call mpp_land_bcast_int1(ierr2) + if(ierr2.ne.0) return + + call decompose_RT_real(buf2,out, & + global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) + return + end subroutine read_restart_rt_2 + + subroutine read_restart_rt_3(unit,nz,out) + integer unit,nz,i,ierr2 + real buf3(global_rt_nx,global_rt_ny,nz),& + out(local_rt_nx,local_rt_ny,3) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3 + call mpp_land_bcast_int1(ierr2) + if(ierr2.ne.0) return + + do i = 1,nz + call decompose_RT_real (buf3(:,:,i),out(:,:,i),& + global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) + end do + return + end subroutine read_restart_rt_3 + + subroutine write_restart_3(unit,nz,in) + integer unit,nz,i + real buf3(global_nx,global_ny,nz),& + in(local_nx,local_ny,nz) + do i = 1,nz + call write_IO_real(in(:,:,i),buf3(:,:,i)) + end do + if(my_id.eq.IO_id) write(unit) buf3 + return + end subroutine write_restart_3 + + subroutine write_restart_2(unit,in) + integer unit + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit) buf2 + return + end subroutine write_restart_2 + + subroutine write_restart_rt_2(unit,in) + integer unit + real buf2(global_rt_nx,global_rt_ny), & + in(local_rt_nx,local_rt_ny) + call write_IO_RT_real(in,buf2) + if(my_id.eq.IO_id) write(unit) buf2 + return + end subroutine write_restart_rt_2 + + subroutine write_restart_rt_3(unit,nz,in) + integer unit,nz,i + real buf3(global_rt_nx,global_rt_ny,nz),& + in(local_rt_nx,local_rt_ny,nz) + do i = 1,nz + call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) + end do + if(my_id.eq.IO_id) write(unit) buf3 + return + end subroutine write_restart_rt_3 + + subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer g_nx,g_ny,nx,ny + real,intent(in),dimension(:,:) :: in_buff + real,intent(out),dimension(:,:) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = (iend-ibegin+1)*(jend-jbegin+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = nx*ny + call mpi_recv(out_buff,size,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_RT_real + + subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer g_nx,g_ny,nx,ny + integer,intent(in),dimension(:,:) :: in_buff + integer,intent(out),dimension(:,:) :: out_buff + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + call mpp_land_sync() + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = (iend-ibegin+1)*(jend-jbegin+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) + end if + end do + else + size = nx*ny + call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_RT_int + + subroutine getNX_NY(nprocs, nx,ny) + ! calculate the nx and ny based on the total nprocs. + integer nprocs, nx, ny + integer i,j, max + max = nprocs + do j = 1, nprocs + if( mod(nprocs,j) .eq. 0 ) then + i = nprocs/j + if( abs(i-j) .lt. max) then + max = abs(i-j) + nx = i + ny = j + end if + end if + end do + return + end subroutine getNX_NY + + subroutine pack_global_22(in, & + out,k) + integer ix,jx,k,i + real out(global_nx,global_ny,k) + real in(local_nx,local_ny,k) + do i = 1, k + call write_IO_real(in(:,:,i),out(:,:,i)) + enddo + return + end subroutine pack_global_22 + + + subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) + implicit none + integer total_pe + integer info(9,total_pe),AGGFACTRT + integer :: ierr, status + integer i + + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + + if(numprocs .ne. total_pe) then + write(6,*) "FATAL ERROR: In wrf_LAND_set_INIT() - numprocs .ne. total_pe ",numprocs, total_pe + call mpp_land_abort() + endif + + +! ### get the neighbors. -1 means no neighbor. + left_id = info(2,my_id+1) + right_id = info(3,my_id+1) + up_id = info(4,my_id+1) + down_id = info(5,my_id+1) + IO_id = 0 + + allocate(local_nx_size(numprocs),stat = status) + allocate(local_ny_size(numprocs),stat = status) + allocate(local_rt_nx_size(numprocs),stat = status) + allocate(local_rt_ny_size(numprocs),stat = status) + allocate(starty(numprocs),stat = ierr) + allocate(startx(numprocs),stat = ierr) + + i = my_id + 1 + local_nx = info(7,i) - info(6,i) + 1 + local_ny = info(9,i) - info(8,i) + 1 + + global_nx = 0 + global_ny = 0 + do i = 1, numprocs + global_nx = max(global_nx,info(7,i)) + global_ny = max(global_ny,info(9,i)) + enddo + + local_rt_nx = local_nx*AGGFACTRT+2 + local_rt_ny = local_ny*AGGFACTRT+2 + if(left_id.lt.0) local_rt_nx = local_rt_nx -1 + if(right_id.lt.0) local_rt_nx = local_rt_nx -1 + if(up_id.lt.0) local_rt_ny = local_rt_ny -1 + if(down_id.lt.0) local_rt_ny = local_rt_ny -1 + + global_rt_nx = global_nx*AGGFACTRT + global_rt_ny = global_ny*AGGFACTRT + rt_AGGFACTRT = AGGFACTRT + + do i =1,numprocs + local_nx_size(i) = info(7,i) - info(6,i) + 1 + local_ny_size(i) = info(9,i) - info(8,i) + 1 + startx(i) = info(6,i) + starty(i) = info(8,i) + + local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2 + local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2 + if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 + if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 + if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 + if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 + enddo + return + end subroutine wrf_LAND_set_INIT + + subroutine getMy_global_id() + integer ierr + call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) + return + end subroutine getMy_global_id + + subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer Link_location(ix,jy) + integer i,j, flag + real Link_V(size), tmp_inout(ix,jy) + + tmp_inout = -999 + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + +! commu nicate tmp_inout + call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_REAL + + subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer Link_location(ix,jy) + integer i,j, flag + integer Link_V(size), tmp_inout(ix,jy) + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + +! commu nicate tmp_inout + call MPP_LAND_COM_INTEGER(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_INT + subroutine print_2(unit,in,fm) + integer unit + character(len=*) fm + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit,*) buf2 + return + end subroutine print_2 + + subroutine print_rt_2(unit,in) + integer unit + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit,*) buf2 + return + end subroutine print_rt_2 + + subroutine mpp_land_max_int1(v) + implicit none + integer v, r1, max + integer i, ierr, tag + if(my_id .eq. IO_id) then + max = v + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 101 + call mpi_recv(r1,1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(max <= r1) max = r1 + end if + end do + else + tag = 101 + call mpi_send(v,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + call mpp_land_bcast_int1(max) + v = max + return + end subroutine mpp_land_max_int1 + + subroutine mpp_land_max_real1(v) + implicit none + real v, r1, max + integer i, ierr, tag + if(my_id .eq. IO_id) then + max = v + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 101 + call mpi_recv(r1,1,MPI_REAL,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(max <= r1) max = r1 + end if + end do + else + tag = 101 + call mpi_send(v,1,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + call mpp_land_bcast_real1(max) + v = max + return + end subroutine mpp_land_max_real1 + + subroutine mpp_same_int1(v) + implicit none + integer v,r1 + integer i, ierr, tag + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 109 + call mpi_recv(r1,1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(v .ne. r1) v = -99 + end if + end do + else + tag = 109 + call mpi_send(v,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + call mpp_land_bcast_int1(v) + end subroutine mpp_same_int1 + + + + subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) + implicit none + integer gnlinks,nlinks, map_l2g(nlinks) + real recv(nlinks), v(nlinks) + ! real g_v(gnlinks), tmp_v(gnlinks) + integer i, ierr, tag, k + integer length, node, message_len + integer,allocatable,dimension(:) :: tmp_map + real, allocatable, dimension(:) :: tmp_v + real, dimension(:) :: g_v + + if(my_id .eq. io_id) then + allocate(tmp_map(gnlinks)) + allocate(tmp_v(gnlinks)) + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif + else + allocate(tmp_map(1)) + allocate(tmp_v(1)) + endif + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) + if(i .ne. my_id) then + !block receive from other node. + + tag = 109 + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 119 + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,message_len + node = tmp_map(k) + if(node .gt. 0) then + g_v(node) = tmp_v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=", node +#endif + endif + enddo + else + do k = 1,nlinks + node = map_l2g(k) + if(node .gt. 0) then + g_v(node) = v(k) + else +#ifdef HYDRO_D + write(6,*) "local Maping infor k=",k," node=",node +#endif + endif + enddo + end if + + end do + else + tag = 109 + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 119 + call mpi_send(v,nlinks,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + + end if + if(allocated(tmp_map)) deallocate(tmp_map) + if(allocated(tmp_v)) deallocate(tmp_v) + end subroutine write_chanel_real + + subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) + implicit none + integer gnlinks,nlinks, map_l2g(nlinks) + integer :: recv(nlinks), v(nlinks) + integer, allocatable, dimension(:) :: tmp_map , tmp_v + integer, dimension(:) :: g_v + integer i, ierr, tag, k + integer length, node, message_len + + if(my_id .eq. io_id) then + allocate(tmp_map(gnlinks)) + allocate(tmp_v(gnlinks)) + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif + else + allocate(tmp_map(1)) + allocate(tmp_v(1)) + endif + + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) + if(i .ne. my_id) then + !block receive from other node. + + tag = 109 + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 119 + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,message_len + if(tmp_map(k) .gt. 0) then + node = tmp_map(k) + g_v(node) = tmp_v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=",tmp_v(k) +#endif + endif + enddo + else + do k = 1,nlinks + if(map_l2g(k) .gt. 0) then + node = map_l2g(k) + g_v(node) = v(k) + else +#ifdef HYDRO_D + write(6,*) "Maping infor k=",k," node=",map_l2g(k) +#endif + endif + enddo + end if + + end do + else + tag = 109 + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 119 + call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + if(allocated(tmp_map)) deallocate(tmp_map) + if(allocated(tmp_v)) deallocate(tmp_v) + end subroutine write_chanel_int + + + + subroutine write_lake_real(v,nodelist_in,nlakes) + implicit none + real recv(nlakes), v(nlakes) + integer nodelist(nlakes), nlakes, nodelist_in(nlakes) + integer i, ierr, tag, k + integer length, node + + nodelist = nodelist_in + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 129 + call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + tag = 139 + call mpi_recv(recv(:),nlakes,MPI_REAL,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + do k = 1,nlakes + if(nodelist(k) .gt. -99) then + node = nodelist(k) + v(node) = recv(node) + endif + enddo + end if + + end do + else + tag = 129 + call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + tag = 139 + call mpi_send(v,nlakes,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + end subroutine write_lake_real + + subroutine read_rst_crt_r(unit,out,size) + implicit none + integer unit, size, ierr,ierr2 + real out(size),out1(size) + if(my_id.eq.IO_id) then + read(unit,IOSTAT=ierr2,end=99) out1 + if(ierr2.eq.0) out=out1 + endif +99 continue + call mpp_land_bcast_int1(ierr2) + if(ierr2 .ne. 0) return + call mpi_bcast(out,size,MPI_REAL, & + IO_id,HYDRO_COMM_WORLD,ierr) + return + end subroutine read_rst_crt_r + + subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) + integer :: unit,gnlinks,nlinks,map_l2g(nlinks) + real cd(nlinks) + real g_cd (gnlinks) + call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) + write(unit) g_cd + return + end subroutine write_rst_crt_r + + subroutine sum_int1d(vin,nsize) + implicit none + integer nsize,i,j,tag,ierr + integer, dimension(nsize):: vin,recv + tag = 319 + if(nsize .le. 0) return + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + vin(:) = vin(:) + recv(:) + endif + end do + else + call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int1d(vin) + return + end subroutine sum_int1d + + subroutine combine_int1d(vin,nsize, flag) + implicit none + integer nsize,i,j,tag,ierr, flag, k + integer, dimension(nsize):: vin,recv + tag = 319 + if(nsize .le. 0) return + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(recv(k) .ne. flag) then + vin(k) = recv(k) + endif + enddo + endif + end do + else + call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int1d(vin) + return + end subroutine combine_int1d + + + + subroutine sum_real8(vin,nsize) + implicit none + integer nsize,i,j,tag,ierr + real*8, dimension(nsize):: vin,recv + real, dimension(nsize):: v + tag = 319 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + vin(:) = vin(:) + recv(:) + endif + end do + v = vin + else + call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_real(nsize,v) + vin = v + return + end subroutine sum_real8 + +! subroutine get_globalDim(ix,g_ix) +! implicit none +! integer ix,g_ix, ierr +! include "mpif.h" +! +! if ( my_id .eq. IO_id ) then +! g_ix = ix +! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & +! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) +! else +! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & +! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) +! endif +! call mpp_land_bcast_int1(g_ix) +! +! return +! +! end subroutine get_globalDim + + subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) + integer sg, s,e, size, s_in, e_in + integer index_s(2) + integer tag, ierr,i +! s: start index, e: end index + real vl(e_in-s_in+1), vg(sg) + s = s_in + e = e_in + + if(my_id .eq. IO_id) then + vg(s:e) = vl + end if + + index_s(1) = s + index_s(2) = e + size = e - s + 1 + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 202 + call mpi_recv(index_s,2,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + + tag = 203 + e = index_s(2) + s = index_s(1) + size = e - s + 1 + call mpi_recv(vg(s:e),size,MPI_REAL, & + i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + endif + end do + else + tag = 202 + call mpi_send(index_s,2,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + + tag = 203 + call mpi_send(vl,size,MPI_REAL,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + end if + + return + end subroutine gather_1d_real_tmp + + subroutine sum_real1(inout) + implicit none + real:: inout, send + integer :: ierr + send = inout + CALL MPI_ALLREDUCE(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr) + end subroutine sum_real1 + + subroutine sum_double(inout) + implicit none + real*8:: inout, send + integer :: ierr + send = inout + !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr) + CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr) + end subroutine sum_double + + subroutine mpp_chrt_nlinks_collect(nlinks) + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + allocate(mpp_nlinks(numprocs),stat = status) + tag = 138 + mpp_nlinks = 0 + if(my_id .eq. IO_id) then + do i = 0,numprocs -1 + if(i .ne. my_id) then + call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + else + mpp_nlinks(i+1) = 0 + end if + end do + else + call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + + + end subroutine mpp_chrt_nlinks_collect + + subroutine getLocalXY(ix,jx,startx,starty,endx,endy) +!!! this is for NoahMP only + implicit none + integer:: ix,jx,startx,starty,endx,endy + startx = local_startx + starty = local_starty + endx = startx + ix -1 + endy = starty + jx -1 + end subroutine getLocalXY + + subroutine check_landreal1(unit, inVar) + implicit none + integer :: unit + real :: inVar + if(my_id .eq. IO_id) then + write(unit,*) inVar + call flush(unit) + endif + end subroutine check_landreal1 + + subroutine check_landreal1d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:) + if(my_id .eq. IO_id) then + write(unit,*) inVar + call flush(unit) + endif + end subroutine check_landreal1d + subroutine check_landreal2d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:,:) + real :: g_var(global_nx,global_ny) + call write_io_real(inVar,g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + call flush(unit) + endif + end subroutine check_landreal2d + + subroutine check_landreal3d(unit, inVar) + implicit none + integer :: unit, k, klevel + real :: inVar(:,:,:) + real :: g_var(global_nx,global_ny) + klevel = size(inVar,2) + do k = 1, klevel + call write_io_real(inVar(:,k,:),g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + call flush(unit) + endif + end do + end subroutine check_landreal3d + + subroutine mpp_collect_1d_int(nlinks,vinout) + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + integer, dimension(nlinks) :: vinout + integer, dimension(nlinks) :: buf + tag = 139 + call mpp_land_sync() + if(my_id .eq. IO_id) then + do i = 0,numprocs -1 + if(i .ne. my_id) then + call mpi_recv(buf,nlinks,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + vinout = vinout + buf + end if + end do + else + call mpi_send(vinout,nlinks,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_sync() + call mpp_land_bcast_int1d(vinout) + + end subroutine mpp_collect_1d_int + + subroutine mpp_collect_1d_int_mem(nlinks,vinout) + ! consider the memory and big size data transport + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + integer, dimension(nlinks) :: vinout, tmpIn + integer, dimension(nlinks) :: buf + integer :: lsize, k,m + integer, allocatable, dimension(:) :: tmpBuf + + call mpp_land_sync() + if(my_id .eq. IO_id) then + allocate (tmpBuf(nlinks)) + do i = 0,numprocs -1 + if(i .ne. my_id) then + tag = 120 + call mpi_recv(lsize,1,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + if(lsize .gt. 0) then + tag = 121 + call mpi_recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, lsize + m = tmpBuf(k) + vinout(m) = 1 + end do + endif + end if + end do + if(allocated(tmpBuf)) deallocate(tmpBuf) + else + lsize = 0 + do k = 1, nlinks + if(vinout(k) .gt. 0) then + lsize = lsize + 1 + tmpIn(lsize) = k + end if + end do + tag = 120 + call mpi_send(lsize,1,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + if(lsize .gt. 0) then + tag = 121 + call mpi_send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + endif + call mpp_land_sync() + call mpp_land_bcast_int1d(vinout) + + end subroutine mpp_collect_1d_int_mem + +! stop the job due to the fatal error. + subroutine fatal_error_stop(msg) + character(len=*) :: msg + integer :: ierr + write(6,*) "The job is stoped due to the fatal error. ", trim(msg) + call flush(6) + call mpp_land_abort() + call MPI_finalize(ierr) + return + end subroutine fatal_error_stop + + subroutine updateLake_seqInt(in,nsize,in0) + implicit none + integer :: nsize + integer, dimension(nsize) :: in + integer, dimension(nsize) :: tmp + integer, dimension(:) :: in0 + integer tag, i, status, ierr, k + if(nsize .le. 0) return + + tag = 29 + if(my_id .ne. IO_id) then + call mpi_send(in,nsize,MPI_INTEGER, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + call mpi_recv(tmp,nsize,& + MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(in0(k) .ne. tmp(k)) in(k) = tmp(k) + end do + end if + end do + end if + call mpp_land_bcast_int1d(in) + + end subroutine updateLake_seqInt + + subroutine updateLake_seq(in,nsize,in0) + implicit none + integer :: nsize + real, dimension(nsize) :: in + real, dimension(nsize) :: tmp + real, dimension(:) :: in0 + integer tag, i, status, ierr, k + if(nsize .le. 0) return + + tag = 29 + if(my_id .ne. IO_id) then + call mpi_send(in,nsize,MPI_REAL, IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + if(i .ne. IO_id) then + call mpi_recv(tmp,nsize,& + MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(in0(k) .ne. tmp(k)) in(k) = tmp(k) + end do + end if + end do + end if + call mpp_land_bcast_real_1d(in) + + end subroutine updateLake_seq + +!subroutine match1dLake: +!global lake. Find the same lake and mark as flag +! default of win is 0 + subroutine match1dLake(vin,nsize,flag) + implicit none + integer nsize,i,j,tag,ierr, flag, k + integer, dimension(nsize):: vin,recv + tag = 319 + if(nsize .le. 0) return + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_INTEGER,i, & + tag,HYDRO_COMM_WORLD,mpp_status,ierr) + do k = 1, nsize + if(recv(k) .eq. flag) vin(k) = flag + if(vin(k) .ne. flag) then + if(vin(k) .gt. 0 .and. recv(k) .gt. 0) then + vin(k) = flag + else + if(recv(k) .gt. 0) vin(k) = recv(k) + endif + endif + end do + endif + end do + else + call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + tag,HYDRO_COMM_WORLD,ierr) + endif + call mpp_land_bcast_int1d(vin) + return + end subroutine match1dLake + + subroutine mpp_land_abort() + implicit none + integer ierr + CALL MPI_ABORT(HYDRO_COMM_WORLD,1,IERR) + end subroutine mpp_land_abort ! mpp_land_abort + + subroutine mpp_land_sync() + implicit none + integer ierr + call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + if(ierr .ne. 0) call mpp_land_abort() + return + end subroutine mpp_land_sync ! mpp_land_sync + + + subroutine mpp_comm_scalar_real(scalar, fromImage, toImage) + implicit none + real, intent(inout) :: scalar + integer, intent(in) :: fromImage, toImage + integer:: ierr, tag + tag=2 + if(my_id .eq. fromImage) & + call mpi_send(scalar, 1, MPI_REAL, & + toImage, tag, HYDRO_COMM_WORLD, ierr) + if(my_id .eq. toImage) & + call mpi_recv(scalar, 1, MPI_REAL, & + fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) + end subroutine mpp_comm_scalar_real + + subroutine mpp_comm_scalar_char(scalar, fromImage, toImage) + implicit none + character(len=*), intent(inout) :: scalar + integer, intent(in) :: fromImage, toImage + integer:: ierr, tag, length + tag=2 + length=len(scalar) + if(my_id .eq. fromImage) & + call mpi_send(scalar, length, MPI_CHARACTER, & + toImage, tag, HYDRO_COMM_WORLD, ierr) + if(my_id .eq. toImage) & + call mpi_recv(scalar, length, MPI_CHARACTER, & + fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) + end subroutine mpp_comm_scalar_char + + + +END MODULE MODULE_MPP_LAND + + + diff --git a/wrfv2_fire/hydro/README.hydro b/wrfv2_fire/hydro/README.hydro new file mode 100644 index 00000000..c146626a --- /dev/null +++ b/wrfv2_fire/hydro/README.hydro @@ -0,0 +1,123 @@ + +There are two parts in thi readme file. +Part I is for fully coupled with WRF model. Part II is for offline version. + + +Part I Fully coupled with WRF Model +1. Building + +1) General description +WRF-Hydro is a coupling architecture designed to simplify the coupling of terrestrial +hydrological models with the WRF model. The WRF-Hydro system is compiled as an independent +library to link with the WRF model and called by the WRF model as a function. The calling +of WRF-Hydro within the WRF model is controlled by a macro definition that is specified +as an environment setting during the compiling process. When WRF-Hydro is not activated +within the environment setting before the WRF configuration process, the entire system +defaults to the standard WRF model. To compile WRF-Hydro system, user only needs to set +environment variable ("setenv WRF_HYDRO 1"), and then follow the standard WRF model +configure and compiling process. + +2) Environment settings +The following environment variables need to be set before configuring and compiling the WRF-HYDRO model, +(those are defined in setEnvar.csh for offline). The compiling scripts will automatic source setEnvar.csh. + +setenv WRF_HYDRO 1 +"1" is to activate WRF-Hydro. "0" or no definition will default to the WRF model only. + +setenv HYDRO_D 1 +A "1" for HYDRO_D results in WRF-Hydro producing some run-time diagnostic information. +When HYDRO_D is set to "0 "or not defined, the diagnostic information will not be produced +during run-time. + +You can explicitly set the "NETCDF_INC" and "NETCDF_LIB" environment variables or just set "NETCDF". +If you only set "NETCDF" environment variable, the default NETCDF_INC and NETCDF_LIB inside WRF-Hydro +will be "$NETCDF/include" and "NETCDF/lib". + +setenv NETCDF_INC "$path/netcdf/include" +setenv NETCDF_LIB "$path/netcdf/lib" + +"NETCDF_INC" and "NETCDF_LIB" are defined for the WRF-Hydro only and can be different from those +set for the WRF model. WRF-Hydro has two netcdf libraries for Fortran and C respectively: +libnetcdff and ibnetcdf. If the user's netcdf library combined them together (only has one), +the user will need to manually change this part in order to successfully compile WRF-Hydro. +See the section below on porting about how to change this. + +Notes: If you are going to create model output file that is more than 2Gb, + you should consider using netCDF large file support function. To activate + this, one must set the environment variable WRFIO_NCD_LARGE_FILE_SUPPORT. + In c-shell environment, do + + setenv WRFIO_NCD_LARGE_FILE_SUPPORT 1 + +3) Configuring and compiling +On the following platforms, the configuring and compiling commands are the same as WRF model +after the user has set up the above four environment variables. +The compiler options IBM AIX with xlf fortran are not fully tested. +Other three pgi, gfortran and intel are tested. +As stated above, the WRF-Hydro system is called as a function inside the WRF model and thus only one executable +is created when WRF-Hydro is compiled with WRF. If user compiles the system successfully, +only a single "wrf.exe" file will be created. + +2. Running + +The fully coupled WRF/WRF-Hydro system has the same running or execution command as that of WRF. +Generally the same parameters and initial files are used as when normally running WRF. However, +WRF-Hydro has an additional namelist called "hydro.namelist" as well as some additional parameter +files (.TBL files) that are located under the "hydro/Run" directory. Users need to copy those +files to the directory where the "wrf.exe" is going to be executed. + +For a WRF-Hydro cold start run (i.e. not from a restart file), the user needs to provide three +additional files that are specified in the "hydro.namelist": "GEO_STATIC_FLNM", "GEO_FINEGRID_FLNM" +and, depending on whether or not the baseflow-bucket model is activated, "gwbasmskfil". + +For running WRF-Hydro from restart file, the user needs to uncomment RESTART_FILE from +"hydro.namelist" by removing "!" and provide the exact name for the existing restart file +to be used. Running from a restart condition is common when the land surface has been +`spun-up' by running WRF-Hydro in an offline or `uncoupled' capacity. + +3. Porting + +The WRF-Hydro does not presently support OPENMP. The default support platform is Linux +with the PGI compiler, IBM AIX with the xlf fortran compiler, and Linux with the GFORTRAN +(sequential) compiler. However, WRF-Hydro is fairly easy to port to other systems. +The basic steps to do so are as follows: + +1) Edit "hydro/configure", and add "exit(0);" to the second line so that "configure" will not be executed. +2) Edit "hydro/macros" to set desired compiling options. +3) Under hydro/WRF_cpl directory: +"make -f Makefile.cpl clean" +"make -f Makefile.cpl " + +If there is no error, then user can compile the fully coupled WRF and WRF-Hydro model on the new platform. + +4. Realtime mode: +For realtime mode, user need to do setenv HYDRO_REALTIME before compiling the code. +This will thin the output. + +Part II Offline compiling +Under hydro/ directory. +1. setenv WRF_HYDRO 1 +2. setenv NETCDF your_netcdf_library_path +or +setenv NETCDF_INC "$path/netcdf/include" +setenv NETCDF_LIB "$path/netcdf/lib" +3. ./configure + -------> choose correct compiler +4. ./compile_offline_NoahMP.csh + ---->compile offine version with NoahMP driver +or + ./compile_offline_Noah.csh + ----->compile offline version with Noah driver +5. Executable files are created under hydro/Run directory. + +Note: Noah and NoahMP have the same name of "namelist.hrldas". But they are different. + + +6. Other Issues +If you are doing fully coupled run and your fine mesh grid time step is <= 1. + +Edit the file "dyn_em/module_first_rk_step_part1.F", change the line from +if(HYDRO_dt .gt. 1 ) call wrf_drv_HYDRO(HYDRO_dt, grid, & +to +if(HYDRO_dt .gt. 0 ) call wrf_drv_HYDRO(HYDRO_dt, grid, & + diff --git a/wrfv2_fire/hydro/Rapid_routing/.gitignore b/wrfv2_fire/hydro/Rapid_routing/.gitignore new file mode 100644 index 00000000..c79cdb9a --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/.gitignore @@ -0,0 +1,24 @@ +#******************************************************************************* +#.gitignore +#******************************************************************************* + +#Purpose: +#The git program is informed here to ignore the following files while performing +#its distributed revision control and source code management. +#Author: +#Cedric H. David, 2014 + + +#******************************************************************************* +#List of files that git will ignore +#******************************************************************************* + +#------------------------------------------------------------------------------- +#Initial releases of RAPID included batch submission scripts for supercomputers +#------------------------------------------------------------------------------- +job_* + +#------------------------------------------------------------------------------- +#Legacy name for BSD 3-clause license of RAPID between 20120831 - 20131113 +#------------------------------------------------------------------------------- +rapid_license.txt diff --git a/wrfv2_fire/hydro/Rapid_routing/LICENSE b/wrfv2_fire/hydro/Rapid_routing/LICENSE new file mode 100644 index 00000000..dfe4b437 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2007-2013, Cedric H. David + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. +* The name Cedric H. David may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL CEDRIC H. DAVID BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/wrfv2_fire/hydro/Rapid_routing/README b/wrfv2_fire/hydro/Rapid_routing/README new file mode 100644 index 00000000..40f79a65 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/README @@ -0,0 +1,9 @@ +The Routing Application for Parallel computatIon of Discharge (RAPID) is a river +network routing model. Given surface and groundwater inflow to rivers, this +model can compute flow and volume of water everywhere in river networks made out +of many thousands of reaches. + +For further information on RAPID including peer-reviewed publications, a manual, +sample input/output data, sample processing scripts and animations of model +results, please go to: +http://www.ucchm.org/david/rapid.htm diff --git a/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90 b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90 new file mode 100644 index 00000000..46ac6511 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90 @@ -0,0 +1,18 @@ +program main_program + use hrldas_RAPID_wrapper , only : hrldas_RAPID_ini,hrldas_RAPID_exe + implicit none + + integer, parameter :: ii = 224 + integer, parameter :: jj = 242 + real,dimension(ii,jj) :: runoff + integer ITIME, NTIME +! character(len=100) :: Qout_nc_file = './RAPID.with.WRF_hydro.0000.nc' + + call hrldas_RAPID_ini(NTIME) + + do ITIME=1,NTIME + call hrldas_RAPID_exe(runoff,ii,jj) + end do +! end loop for calling RAPID programs + + end diff --git a/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90 b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90 new file mode 100644 index 00000000..c4a99b5c --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90 @@ -0,0 +1,210 @@ +module hrldas_RAPID_wrapper +!---This Wrapper provides an interface for WRF-Hydro to call RAPID-- +! If not initialized, do initialization first +! If initialized, continue RAPID computation +!---The Wrapper also contains RAPID coupler, which defines where +! LSM runoff is mapped into vector-based river reaches +!---Author: +!---Peirong Lin, 2014-2015--------------------------------------- + +use rapid_var, only : namelist_file, & + Qout_file, & + ZV_read_riv_tot,ZV_read_obs_tot,ZV_read_hum_tot,& + IS_riv_tot,IS_riv_bas,JS_riv_tot, & + IV_riv_bas_id,IV_riv_index,IV_riv_loc1, & + ierr,stage,rank, & + ZS_TauR + +#include "finclude/petscsys.h" +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +#include "finclude/petscmat.h" +#include "finclude/petscksp.h" +#include "finclude/petscpc.h" +#include "finclude/petscviewer.h" +#include "finclude/petsclog.h" +#ifndef NO_TAO +#include "finclude/taosolver.h" +#endif + +!--LPR defined variables for RAPID loop--------- +integer cnt_rapid_run +logical initialized +character(len=100) :: str +character(len=100) :: Qout_nc_dir +character(len=100) :: Qout_nc_file !---LPR: RAPID output file name-- +integer, dimension(:), allocatable :: IV_i_index +integer, dimension(:), allocatable :: IV_j_index +real, dimension(:), allocatable :: ZV_areakm !--LPR: size depending on rivers + +CONTAINS + +!---SUBROUTINE TO LINK WITH WRF-HYDRO----------------- + subroutine hrldas_RAPID_ini(ntime) +! use rapid_main , only : rapid_ini + implicit none + integer :: ntime + + if (rank==0) then + print *,'RAPID initialized = ',initialized + if(initialized) return !If not first time initialization + + print *,'***********************************************************' + print *,'*******Initialize RAPID model******************************' + print *,'***********************************************************' + call rapid_ini(ntime) + initialized = .True. + end if + + call PetscLogStageRegister('Read Comp Write',stage,ierr) + call PetscLogStagePush(stage,ierr) + end subroutine hrldas_RAPID_ini + + + +!---SUBROUTINE TO LINK WITH WRF-HYDRO & DRIVE RAPID ----------------- + subroutine hrldas_RAPID_exe(runoff,ii,jj) +! use rapid_main , only : rapid_main_exe + implicit none + real,dimension(ii,jj) :: runoff + integer :: ii,jj + + !---LPR: convert LSM runoff to mm/hour (previous: mm, total runoff in a time step) + runoff = runoff/ZS_TauR*3600 !if LSM=3hrly, original runoff is in + + !---LPR: MPI debug information------------------ + !write(70+rank,*) "yywww test inside the rapid " + !call flush(70+rank) + + if (rank==0) then + if(cnt_rapid_run==0) then + Qout_nc_dir = Qout_file !---define RAPID output director-------- + end if + cnt_rapid_run = cnt_rapid_run + 1 + !---LPR: define RAPID output filenames---------------------------- + if (cnt_rapid_run < 10) then + write(str,100) cnt_rapid_run +100 format('0000',i1) + else if (cnt_rapid_run < 100) then + write(str,200) cnt_rapid_run +200 format('000',i2) + else if (cnt_rapid_run < 1000) then + write(str,300) cnt_rapid_run +300 format('00',i3) + else if (cnt_rapid_run < 10000) then + write(str,400) cnt_rapid_run +400 format('0',i4) + else + write(str,'(i5)') cnt_rapid_run + end if + Qout_nc_file = trim(Qout_nc_dir)//'RAPID.with.WRF_hydro.'//trim(str)//'.nc' + print *,'RAPID output Qout_nc_file = ',trim(Qout_nc_file) + end if + + call rapid_main(1,runoff,ii,jj,Qout_nc_file) + + !--LPR: add to test runoff in RESTART run mode, can remove this later----------- + !if(cnt_rapid_run == 2) then + ! write(81,*) runoff + !endif + + end subroutine hrldas_RAPID_exe + + + +!-----------RAPID initialization call---------------------------------------------- + subroutine rapid_ini(NTIME) + implicit none + integer NTIME + namelist_file='./rapid_namelist' + + if (rank==0) then + print *,'First time RAPID initialization ... & + May take a while depending on size of river network ... & + ... Wait ...' + call rapid_init + end if + + end subroutine rapid_ini + + + +!--------------RAPID coupler: gridded runoff to vector runoff----------------------- + subroutine rapid_runoff_to_inflow(ZM_runoff,ZV_Vlat,cnt_rapid_run) + implicit none + + real, dimension(:,:), intent(in) :: ZM_runoff + Vec, intent(out) :: ZV_Vlat + integer :: cnt_rapid_run + integer :: JS_lon,JS_lat + character(len=100) :: rapid_coupling_file='./rapid_input_tx/RAPID_coupling_WRF_hydro.csv' + !---LPR: need to optimize code----- + + !----------tease out weird runoff values----------- + if (rank==0) then + if (maxval(ZM_runoff)>1000) stop 'Runoff exceeds 1000' + if (minval(ZM_runoff)<0) stop 'Negative runoff' + !print *, 'Maximum value for ZM_runoff is:', maxval(ZM_runoff) + end if + + !----------COUPLING START---------------------------- + if (rank==0) then + !---initialize river reaches-------------------------------------- + do JS_riv_tot=1,IS_riv_tot + ZV_read_riv_tot(JS_riv_tot) = 0. + end do + + if (cnt_rapid_run==1) then + allocate(IV_i_index(IS_riv_tot)) + allocate(IV_j_index(IS_riv_tot)) + allocate(ZV_areakm(IS_riv_tot)) + !If first time RAPID call: read coupling files + !----------OPTION 1: Catchment centroid-based coupling----------- + open(88,file=rapid_coupling_file,status='old') + do JS_riv_tot=1,IS_riv_tot + read(88,*) IV_riv_bas_id(JS_riv_tot),ZV_areakm(JS_riv_tot), & + IV_i_index(JS_riv_tot),IV_j_index(JS_riv_tot) + end do + close(88) + print *,' LPR CHECK river 30000 ',IV_riv_bas_id(30000),ZV_areakm(30000), & + IV_i_index(30000),IV_j_index(30000) + !---------END OPTION 1---------------------------------- + + !---------OPTION 2: Area-weighted coupling---------------------- + + !--------END OPTION 2----------------------------------- + + print *,'****First time: RAPID read coupling file successfully************' + end if !---LPR: only read coupling inforamtion once--------------- + + !---LPR: actual coupling (mapping runoff from LSM to rivers)------------ + do JS_riv_tot=1,IS_riv_tot + JS_lon=IV_i_index(JS_riv_tot) + JS_lat=IV_j_index(JS_riv_tot) + !print *,'Location ::: ',JS_lon,JS_lat + !print *,'Values ::: ',ZM_runoff(JS_lon,JS_lat),ZV_areakm(JS_riv_tot) + ZV_read_riv_tot(JS_riv_tot)=ZM_runoff(JS_lon,JS_lat) & + *ZV_areakm(JS_riv_tot)*1000 + !with runoff in kg/m2=mm and area in km2 + !----LPR CHECK POINTS------------ + if(JS_riv_tot .eq. 30000) then + print *,'***LPR CHECK*** m3_riv value = ',ZV_read_riv_tot(JS_riv_tot) + end if + end do + + print *, '************************************************************' + print *, '***** LPR: RAPID coupling successful! **********************' + print *, '************************************************************' + end if + + !------write to PETSC vector--------------------------- + if (rank==0) then + print *,' number of river reaches = ',IS_riv_bas + call VecSetValues(ZV_Vlat,IS_riv_bas,IV_riv_loc1,& + ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr) + end if + call VecAssemblyBegin(ZV_Vlat,ierr) + call VecAssemblyEnd(ZV_Vlat,ierr) + end subroutine rapid_runoff_to_inflow + +end module hrldas_RAPID_wrapper diff --git a/wrfv2_fire/hydro/Rapid_routing/makefile b/wrfv2_fire/hydro/Rapid_routing/makefile new file mode 100644 index 00000000..41297072 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/makefile @@ -0,0 +1,245 @@ +#******************************************************************************* +#makefile +#******************************************************************************* + +#Purpose: +#This file, along with the make utility allows compiling/linking RAPID +#Author: +#Cedric H. David, 2008-2015 + + +#******************************************************************************* +#PETSc and TAO rules and variables (where environment variables and options are) +#******************************************************************************* + +#------------------------------------------------------------------------------- +#Default RAPID - includes optimization with TAO +#------------------------------------------------------------------------------- +#FPPFLAGS= +#include ${TAO_DIR}/conf/tao_base + +#------------------------------------------------------------------------------- +#If want to use RAPID without TAO, in which case the optimization is unavailable +#------------------------------------------------------------------------------- +FPPFLAGS=-D NO_TAO +include ${PETSC_DIR}/conf/variables +include ${PETSC_DIR}/conf/rules +#include ${PETSC_DIR}/lib/petsc/conf/variables +#include ${PETSC_DIR}/lib/petsc/conf/rules +#PETSC_FC_INCLUDES=-I/work/02151/peirongl/_code_wrfhydro/wrf_hydro_model/trunk/NDHMS/petsc-3.6.2/include/ +#PETSC_LIB=-L/work/02151/peirongl/_code_wrfhydro/wrf_hydro_model/trunk/NDHMS/petsc-3.6.2/lib/ + +#******************************************************************************* +#Location of netCDF include and lib directories +#******************************************************************************* +NETCDF_LIB=-L ${TACC_NETCDF_LIB} -lnetcdf +NETCDF_INCLUDE=-I ${TACC_NETCDF_INC} + + +#******************************************************************************* +#makefile instructions +#******************************************************************************* + +#------------------------------------------------------------------------------- +#Test that environment variables are properly read by make +#------------------------------------------------------------------------------- +dummy: + echo ${FLINKER} ${FPPFLAGS} + +#------------------------------------------------------------------------------- +#Link RAPID main +#------------------------------------------------------------------------------- +rapid: rapid_main.o \ + rapid_init.o \ + rapid_read_namelist.o \ + rapid_arrays.o \ + rapid_create_obj.o \ + rapid_create_Qout_file.o \ + rapid_open_Qout_file.o \ + rapid_open_Vlat_file.o \ + rapid_open_Qobs_file.o \ + rapid_open_Qfor_file.o \ + rapid_open_Qhum_file.o \ + rapid_write_Qout_file.o \ + rapid_read_Vlat_file.o \ + rapid_read_Qobs_file.o \ + rapid_read_Qfor_file.o \ + rapid_read_Qhum_file.o \ + rapid_close_Qout_file.o \ + rapid_close_Vlat_file.o \ + rapid_close_Qobs_file.o \ + rapid_close_Qfor_file.o \ + rapid_close_Qhum_file.o \ + rapid_get_Qdam.o \ + rapid_set_Qext0.o \ + rapid_hsh_mat.o \ + rapid_net_mat.o \ + rapid_net_mat_brk.o \ + rapid_obs_mat.o \ + rapid_routing.o \ + rapid_routing_param.o \ + rapid_phiroutine.o \ + rapid_destro_obj.o \ + rapid_final.o \ + rapid_var.o \ + hrldas_RAPID_wrapper.o \ + hrldas_RAPID_drv.o + ${FLINKER} ${FPPFLAGS} -o \ + rapid \ + rapid_main.o \ + rapid_init.o \ + rapid_read_namelist.o \ + rapid_arrays.o \ + rapid_create_obj.o \ + rapid_create_Qout_file.o \ + rapid_open_Qout_file.o \ + rapid_open_Vlat_file.o \ + rapid_open_Qobs_file.o \ + rapid_open_Qfor_file.o \ + rapid_open_Qhum_file.o \ + rapid_write_Qout_file.o \ + rapid_read_Vlat_file.o \ + rapid_read_Qobs_file.o \ + rapid_read_Qfor_file.o \ + rapid_read_Qhum_file.o \ + rapid_close_Qout_file.o \ + rapid_close_Vlat_file.o \ + rapid_close_Qobs_file.o \ + rapid_close_Qfor_file.o \ + rapid_close_Qhum_file.o \ + rapid_get_Qdam.o \ + rapid_set_Qext0.o \ + rapid_hsh_mat.o \ + rapid_net_mat.o \ + rapid_net_mat_brk.o \ + rapid_routing.o \ + rapid_routing_param.o \ + rapid_obs_mat.o \ + rapid_phiroutine.o \ + rapid_destro_obj.o \ + rapid_final.o \ + rapid_var.o \ + hrldas_RAPID_wrapper.o \ + hrldas_RAPID_drv.o \ + ${TAO_FORTRAN_LIB} ${TAO_LIB} ${PETSC_LIB} ${NETCDF_LIB} + ${RM} *.o *.mod +# ln -sf ../src/rapid ../run/rapid +# ln -sf ../src/rapid ../rtk/rapid +#----LPR: uncomment the link because no RAPID executable will be generated when +#---------coupled with WRF-Hydro + +#------------------------------------------------------------------------------- +#Compile RAPID +#------------------------------------------------------------------------------- +rapid_final.o: rapid_final.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_final.F90 ${PETSC_FC_INCLUDES} + +rapid_destro_obj.o: rapid_destro_obj.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_destro_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_phiroutine.o: rapid_phiroutine.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_phiroutine.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_routing.o: rapid_routing.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_routing.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_init.o: rapid_read_namelist.o rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_init.F90 ${PETSC_FC_INCLUDES} + +rapid_routing_param.o: rapid_routing_param.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_routing_param.F90 ${PETSC_FC_INCLUDES} + +rapid_obs_mat.o: rapid_obs_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_obs_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_net_mat_brk.o: rapid_net_mat_brk.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_net_mat_brk.F90 ${PETSC_FC_INCLUDES} + +rapid_net_mat.o: rapid_net_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_net_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_hsh_mat.o: rapid_hsh_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_hsh_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_get_Qdam.o: rapid_get_Qdam.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_get_Qdam.F90 ${PETSC_FC_INCLUDES} + +rapid_set_Qext0.o: rapid_set_Qext0.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_set_Qext0.F90 ${PETSC_FC_INCLUDES} + +rapid_close_Qfor_file.o: rapid_close_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qfor_file.F90 + +rapid_close_Qhum_file.o: rapid_close_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qhum_file.F90 + +rapid_close_Qobs_file.o: rapid_close_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qobs_file.F90 + +rapid_close_Vlat_file.o: rapid_close_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Vlat_file.F90 ${NETCDF_INCLUDE} + +rapid_close_Qout_file.o: rapid_close_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_read_Qfor_file.o: rapid_read_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qfor_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Qhum_file.o: rapid_read_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qhum_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Qobs_file.o: rapid_read_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qobs_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Vlat_file.o: rapid_read_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Vlat_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_write_Qout_file.o: rapid_write_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_write_Qout_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_open_Qfor_file.o: rapid_open_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qfor_file.F90 + +rapid_open_Qhum_file.o: rapid_open_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qhum_file.F90 + +rapid_open_Qobs_file.o: rapid_open_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qobs_file.F90 + +rapid_open_Vlat_file.o: rapid_open_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Vlat_file.F90 ${NETCDF_INCLUDE} + +rapid_open_Qout_file.o: rapid_open_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_create_Qout_file.o: rapid_create_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_create_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_create_obj.o: rapid_create_obj.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_create_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_arrays.o: rapid_arrays.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_arrays.F90 ${PETSC_FC_INCLUDES} + +rapid_read_namelist.o: rapid_read_namelist.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_namelist.F90 + +rapid_var.o rapid_var.mod: rapid_var.F90 + ${FLINKER} ${FPPFLAGS} -c rapid_var.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +hrldas_RAPID_wrapper.mod hrldas_RAPID_wrapper.o: hrldas_RAPID_wrapper.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c hrldas_RAPID_wrapper.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_main.o: rapid_main.F90 rapid_var.mod hrldas_RAPID_wrapper.mod + ${FLINKER} ${FPPFLAGS} -c rapid_main.F90 ${PETSC_FC_INCLUDES} \ + ${TAO_INCLUDE} ${NETCDF_INCLUDE} + +hrldas_RAPID_drv.o: hrldas_RAPID_drv.F90 hrldas_RAPID_wrapper.mod + ${FLINKER} ${FPPFLAGS} -c hrldas_RAPID_drv.F90 ${PETSC_FC_INCLUDE} ${TAO_INCLUDE} + +#------------------------------------------------------------------------------- +#Clean +#------------------------------------------------------------------------------- +clean:: + ${RM} *.o *.mod rapid ../run/rapid ../rtk/rapid + diff --git a/wrfv2_fire/hydro/Rapid_routing/makefile.cpl b/wrfv2_fire/hydro/Rapid_routing/makefile.cpl new file mode 100644 index 00000000..3363744b --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/makefile.cpl @@ -0,0 +1,197 @@ +#******************************************************************************* +#makefile +#******************************************************************************* + +#Purpose: +#This file, along with the make utility allows compiling/linking RAPID +#Author: +#Cedric H. David, 2008-2015 + + +#******************************************************************************* +#PETSc and TAO rules and variables (where environment variables and options are) +#******************************************************************************* + +#------------------------------------------------------------------------------- +#Default RAPID - includes optimization with TAO +#------------------------------------------------------------------------------- +#FPPFLAGS= +#include ${TAO_DIR}/conf/tao_base + +#------------------------------------------------------------------------------- +#If want to use RAPID without TAO, in which case the optimization is unavailable +#------------------------------------------------------------------------------- +FPPFLAGS=-D NO_TAO +include ${PETSC_DIR}/conf/variables +include ${PETSC_DIR}/conf/rules + + +#******************************************************************************* +#Location of netCDF include and lib directories +#******************************************************************************* +NETCDF_LIB=-L ${TACC_NETCDF_LIB} -lnetcdf +NETCDF_INCLUDE=-I ${TACC_NETCDF_INC} + +#******************************************************************************* +#makefile instructions +#******************************************************************************* + +#------------------------------------------------------------------------------- +#Test that environment variables are properly read by make +#------------------------------------------------------------------------------- +dummy: + echo ${FLINKER} ${FPPFLAGS} + +#------------------------------------------------------------------------------- +#Link RAPID main +#------------------------------------------------------------------------------- +rapid: rapid_main.o \ + rapid_init.o \ + rapid_read_namelist.o \ + rapid_arrays.o \ + rapid_create_obj.o \ + rapid_create_Qout_file.o \ + rapid_open_Qout_file.o \ + rapid_open_Vlat_file.o \ + rapid_open_Qobs_file.o \ + rapid_open_Qfor_file.o \ + rapid_open_Qhum_file.o \ + rapid_write_Qout_file.o \ + rapid_read_Vlat_file.o \ + rapid_read_Qobs_file.o \ + rapid_read_Qfor_file.o \ + rapid_read_Qhum_file.o \ + rapid_close_Qout_file.o \ + rapid_close_Vlat_file.o \ + rapid_close_Qobs_file.o \ + rapid_close_Qfor_file.o \ + rapid_close_Qhum_file.o \ + rapid_get_Qdam.o \ + rapid_set_Qext0.o \ + rapid_hsh_mat.o \ + rapid_net_mat.o \ + rapid_net_mat_brk.o \ + rapid_obs_mat.o \ + rapid_routing.o \ + rapid_routing_param.o \ + rapid_phiroutine.o \ + rapid_destro_obj.o \ + rapid_final.o \ + rapid_var.o \ + hrldas_RAPID_wrapper.o + ar -r ../lib/librapid.a *.o + cp *.mod ../mod/. +# ${RM} *.o *.mod + +#------------------------------------------------------------------------------- +#Compile RAPID +#------------------------------------------------------------------------------- +rapid_final.o: rapid_final.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_final.F90 ${PETSC_FC_INCLUDES} + +rapid_destro_obj.o: rapid_destro_obj.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_destro_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_phiroutine.o: rapid_phiroutine.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_phiroutine.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_routing.o: rapid_routing.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_routing.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_init.o: rapid_read_namelist.o rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_init.F90 ${PETSC_FC_INCLUDES} + +rapid_routing_param.o: rapid_routing_param.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_routing_param.F90 ${PETSC_FC_INCLUDES} + +rapid_obs_mat.o: rapid_obs_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_obs_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_net_mat_brk.o: rapid_net_mat_brk.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_net_mat_brk.F90 ${PETSC_FC_INCLUDES} + +rapid_net_mat.o: rapid_net_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_net_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_hsh_mat.o: rapid_hsh_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_hsh_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_get_Qdam.o: rapid_get_Qdam.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_get_Qdam.F90 ${PETSC_FC_INCLUDES} + +rapid_set_Qext0.o: rapid_set_Qext0.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_set_Qext0.F90 ${PETSC_FC_INCLUDES} + +rapid_close_Qfor_file.o: rapid_close_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qfor_file.F90 + +rapid_close_Qhum_file.o: rapid_close_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qhum_file.F90 + +rapid_close_Qobs_file.o: rapid_close_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qobs_file.F90 + +rapid_close_Vlat_file.o: rapid_close_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Vlat_file.F90 ${NETCDF_INCLUDE} + +rapid_close_Qout_file.o: rapid_close_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_read_Qfor_file.o: rapid_read_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qfor_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Qhum_file.o: rapid_read_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qhum_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Qobs_file.o: rapid_read_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qobs_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Vlat_file.o: rapid_read_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Vlat_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_write_Qout_file.o: rapid_write_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_write_Qout_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_open_Qfor_file.o: rapid_open_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qfor_file.F90 + +rapid_open_Qhum_file.o: rapid_open_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qhum_file.F90 + +rapid_open_Qobs_file.o: rapid_open_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qobs_file.F90 + +rapid_open_Vlat_file.o: rapid_open_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Vlat_file.F90 ${NETCDF_INCLUDE} + +rapid_open_Qout_file.o: rapid_open_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_create_Qout_file.o: rapid_create_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_create_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_create_obj.o: rapid_create_obj.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_create_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_arrays.o: rapid_arrays.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_arrays.F90 ${PETSC_FC_INCLUDES} + +rapid_read_namelist.o: rapid_read_namelist.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_namelist.F90 + +rapid_var.o rapid_var.mod: rapid_var.F90 + ${FLINKER} ${FPPFLAGS} -c rapid_var.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +hrldas_RAPID_wrapper.mod hrldas_RAPID_wrapper.o: hrldas_RAPID_wrapper.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c hrldas_RAPID_wrapper.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_main.o: rapid_main.F90 rapid_var.mod hrldas_RAPID_wrapper.mod + ${FLINKER} ${FPPFLAGS} -c rapid_main.F90 ${PETSC_FC_INCLUDES} \ + ${TAO_INCLUDE} ${NETCDF_INCLUDE} + +#------------------------------------------------------------------------------- +#Clean +#------------------------------------------------------------------------------- +clean:: + ${RM} *.o *.mod rapid ../run/rapid ../rtk/rapid + diff --git a/wrfv2_fire/hydro/Rapid_routing/makefile.orig b/wrfv2_fire/hydro/Rapid_routing/makefile.orig new file mode 100644 index 00000000..ad4d8b53 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/makefile.orig @@ -0,0 +1,229 @@ +#******************************************************************************* +#makefile +#******************************************************************************* + +#Purpose: +#This file, along with the make utility allows compiling/linking RAPID +#Author: +#Cedric H. David, 2008-2015 + + +#******************************************************************************* +#PETSc and TAO rules and variables (where environment variables and options are) +#******************************************************************************* + +#------------------------------------------------------------------------------- +#Default RAPID - includes optimization with TAO +#------------------------------------------------------------------------------- +#FPPFLAGS= +#include ${TAO_DIR}/conf/tao_base + +#------------------------------------------------------------------------------- +#If want to use RAPID without TAO, in which case the optimization is unavailable +#------------------------------------------------------------------------------- +FPPFLAGS=-D NO_TAO +include ${PETSC_DIR}/conf/variables +include ${PETSC_DIR}/conf/rules + + +#******************************************************************************* +#Location of netCDF include and lib directories +#******************************************************************************* +NETCDF_LIB=-L ${TACC_NETCDF_LIB} -lnetcdf +NETCDF_INCLUDE=-I ${TACC_NETCDF_INC} + + +#******************************************************************************* +#makefile instructions +#******************************************************************************* + +#------------------------------------------------------------------------------- +#Test that environment variables are properly read by make +#------------------------------------------------------------------------------- +dummy: + echo ${FLINKER} ${FPPFLAGS} + +#------------------------------------------------------------------------------- +#Link RAPID main +#------------------------------------------------------------------------------- +rapid: rapid_main.o \ + rapid_init.o \ + rapid_read_namelist.o \ + rapid_arrays.o \ + rapid_create_obj.o \ + rapid_create_Qout_file.o \ + rapid_open_Qout_file.o \ + rapid_open_Vlat_file.o \ + rapid_open_Qobs_file.o \ + rapid_open_Qfor_file.o \ + rapid_open_Qhum_file.o \ + rapid_write_Qout_file.o \ + rapid_read_Vlat_file.o \ + rapid_read_Qobs_file.o \ + rapid_read_Qfor_file.o \ + rapid_read_Qhum_file.o \ + rapid_close_Qout_file.o \ + rapid_close_Vlat_file.o \ + rapid_close_Qobs_file.o \ + rapid_close_Qfor_file.o \ + rapid_close_Qhum_file.o \ + rapid_get_Qdam.o \ + rapid_set_Qext0.o \ + rapid_hsh_mat.o \ + rapid_net_mat.o \ + rapid_net_mat_brk.o \ + rapid_obs_mat.o \ + rapid_routing.o \ + rapid_routing_param.o \ + rapid_phiroutine.o \ + rapid_destro_obj.o \ + rapid_final.o \ + rapid_var.o + ${FLINKER} ${FPPFLAGS} -o \ + rapid \ + rapid_main.o \ + rapid_init.o \ + rapid_read_namelist.o \ + rapid_arrays.o \ + rapid_create_obj.o \ + rapid_create_Qout_file.o \ + rapid_open_Qout_file.o \ + rapid_open_Vlat_file.o \ + rapid_open_Qobs_file.o \ + rapid_open_Qfor_file.o \ + rapid_open_Qhum_file.o \ + rapid_write_Qout_file.o \ + rapid_read_Vlat_file.o \ + rapid_read_Qobs_file.o \ + rapid_read_Qfor_file.o \ + rapid_read_Qhum_file.o \ + rapid_close_Qout_file.o \ + rapid_close_Vlat_file.o \ + rapid_close_Qobs_file.o \ + rapid_close_Qfor_file.o \ + rapid_close_Qhum_file.o \ + rapid_get_Qdam.o \ + rapid_set_Qext0.o \ + rapid_hsh_mat.o \ + rapid_net_mat.o \ + rapid_net_mat_brk.o \ + rapid_routing.o \ + rapid_routing_param.o \ + rapid_obs_mat.o \ + rapid_phiroutine.o \ + rapid_destro_obj.o \ + rapid_final.o \ + rapid_var.o \ + ${TAO_FORTRAN_LIB} ${TAO_LIB} ${PETSC_LIB} ${NETCDF_LIB} + ${RM} *.o *.mod + ln -sf ../src/rapid ../run/rapid + ln -sf ../src/rapid ../rtk/rapid + +#------------------------------------------------------------------------------- +#Compile RAPID +#------------------------------------------------------------------------------- +rapid_main.o: rapid_main.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_main.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_final.o: rapid_final.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_final.F90 ${PETSC_FC_INCLUDES} + +rapid_destro_obj.o: rapid_destro_obj.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_destro_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_phiroutine.o: rapid_phiroutine.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_phiroutine.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_routing.o: rapid_routing.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_routing.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_init.o: rapid_read_namelist.o rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_init.F90 ${PETSC_FC_INCLUDES} + +rapid_routing_param.o: rapid_routing_param.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_routing_param.F90 ${PETSC_FC_INCLUDES} + +rapid_obs_mat.o: rapid_obs_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_obs_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_net_mat_brk.o: rapid_net_mat_brk.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_net_mat_brk.F90 ${PETSC_FC_INCLUDES} + +rapid_net_mat.o: rapid_net_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_net_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_hsh_mat.o: rapid_hsh_mat.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_hsh_mat.F90 ${PETSC_FC_INCLUDES} + +rapid_get_Qdam.o: rapid_get_Qdam.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_get_Qdam.F90 ${PETSC_FC_INCLUDES} + +rapid_set_Qext0.o: rapid_set_Qext0.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_set_Qext0.F90 ${PETSC_FC_INCLUDES} + +rapid_close_Qfor_file.o: rapid_close_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qfor_file.F90 + +rapid_close_Qhum_file.o: rapid_close_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qhum_file.F90 + +rapid_close_Qobs_file.o: rapid_close_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qobs_file.F90 + +rapid_close_Vlat_file.o: rapid_close_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Vlat_file.F90 ${NETCDF_INCLUDE} + +rapid_close_Qout_file.o: rapid_close_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_close_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_read_Qfor_file.o: rapid_read_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qfor_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Qhum_file.o: rapid_read_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qhum_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Qobs_file.o: rapid_read_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Qobs_file.F90 ${PETSC_FC_INCLUDES} + +rapid_read_Vlat_file.o: rapid_read_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_Vlat_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_write_Qout_file.o: rapid_write_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_write_Qout_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE} + +rapid_open_Qfor_file.o: rapid_open_Qfor_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qfor_file.F90 + +rapid_open_Qhum_file.o: rapid_open_Qhum_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qhum_file.F90 + +rapid_open_Qobs_file.o: rapid_open_Qobs_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qobs_file.F90 + +rapid_open_Vlat_file.o: rapid_open_Vlat_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Vlat_file.F90 ${NETCDF_INCLUDE} + +rapid_open_Qout_file.o: rapid_open_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_open_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_create_Qout_file.o: rapid_create_Qout_file.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_create_Qout_file.F90 ${NETCDF_INCLUDE} + +rapid_create_obj.o: rapid_create_obj.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_create_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +rapid_arrays.o: rapid_arrays.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_arrays.F90 ${PETSC_FC_INCLUDES} + +rapid_read_namelist.o: rapid_read_namelist.F90 rapid_var.mod + ${FLINKER} ${FPPFLAGS} -c rapid_read_namelist.F90 + +rapid_var.o rapid_var.mod: rapid_var.F90 + ${FLINKER} ${FPPFLAGS} -c rapid_var.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} + +#------------------------------------------------------------------------------- +#Clean +#------------------------------------------------------------------------------- +clean:: + ${RM} *.o *.mod rapid ../run/rapid ../rtk/rapid + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90 new file mode 100644 index 00000000..6adb263e --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90 @@ -0,0 +1,709 @@ +!******************************************************************************* +!Subroutine - rapid_arrays +!******************************************************************************* +subroutine rapid_arrays + +!Purpose: +!Create arrays from input files that are useful for RAPID. +!for all simulations, RAPID can run on a subset of all available river reaches +!of the domain. +!Three Fortran vectors are useful here: +! - IV_riv_bas_id(IS_riv_bas) allows to know the IDs of the subbasin studied +! - IV_riv_bas_index(IS_riv_bas) allows to know where the flow values are +! located in Vlat_file using the 1-based ZV_read_riv_tot +! - IV_riv_bas_loc1(IS_riv_bas) allows to know where to ad dthe flow values in +! the current modeling domain using the 0-based ZV_Qout +!When human-induced option is activated, the flow entering each given river ID +!is read from a file and added to the inflow the corresponding river. +!Three Fortran vectors are useful here: +! - IV_hum_bas_id(IS_hum_bas) allows to know the IDs of the humand-induced flows +! locations into the subbasin +! - IV_hum_index(IS_hum_bas) allows to know where the flow values are +! located in Qhum_file using the 1-based ZV_read_hum_tot +! - IV_hum_loc1(IS_hum_bas) allows to know where to add the flow values +! in the current modeling domain using the 0-based ZV_Qhum +!When forcing option is activated, the flow exiting each given river ID is +!read from a file and added to the inflow of its downstream river. +!Three Fortran vectors are useful here: +! - IV_for_bas_id(IS_for_bas) allows to know the IDs of the forcing locations +! flowing into the subbasin +! - IV_for_index(IS_for_bas) allows to know where the flow values are +! located in Qfor_file using the 1-based ZV_read_for_tot +! - IV_for_loc2(IS_for_bas) allows to know where to add the flow values +! in the current modeling domain using the 0-based ZV_Qfor +!When dam option is activated, the flow exiting each given river ID is +!obtained from a model and added to the inflow of its downstream river. +!Four Fortran vectors are useful here: +! - IV_dam_bas_id(IS_dam_bas) allows to know the IDs of the dam locations +! in the subbasin +! - IV_dam_index(IS_dam_bas) allows to know where the flow values are +! located in dam model array using the 1-based ZV_read_dam_tot +! - IV_dam_loc2(IS_dam_bas) allows to know where to add the flow values +! in the current modeling domain using the 0-based ZV_Qdam +! - IV_dam_pos(IS_dam_bas) allows to know where to read the flow values for the +! dam model in the current modeling domain using the 0-based ZV_Qdam +!When RAPID is run in optimization mode, the flow measured at each given river +!ID is read from a file and compared to computations. +!Three Fortran vectors are useful here: +! - IV_obs_bas_id(IS_obs_bas) allows to know the IDs of the observations +! - IV_obs_index(IS_obs_bas) allows to know where the flow values are +! located in Qobs_file using the 1-based ZV_read_obs_tot +! - IV_obs_loc1(IS_obs_bas) allows to know where to put the flow values +! in the current modeling domain using the 0-based ZV_Qobs +!Author: +!Cedric H. David, 2014-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rapid_connect_file, & + IS_riv_tot,JS_riv_tot,JS_up, & + IV_riv_tot_id,IV_down,IV_nbup,IM_up,IM_index_up, & + riv_bas_id_file, & + IS_riv_bas,JS_riv_bas,JS_riv_bas2, & + ZM_hsh_tot,ZM_hsh_bas, & + IV_riv_bas_id,IV_riv_index,IV_riv_loc1, & + BS_opt_hum, & + hum_tot_id_file, & + IS_hum_tot,JS_hum_tot, & + IV_hum_tot_id, & + hum_use_id_file, & + IV_hum_use_id, & + IS_hum_use,JS_hum_use, & + IS_hum_bas,JS_hum_bas, & + IV_hum_bas_id,IV_hum_index,IV_hum_loc1, & + BS_opt_for, & + for_tot_id_file, & + IS_for_tot,JS_for_tot, & + IV_for_tot_id, & + for_use_id_file, & + IV_for_use_id, & + IS_for_use,JS_for_use, & + IS_for_bas,JS_for_bas, & + IV_for_bas_id,IV_for_index,IV_for_loc2,IV_dam_pos, & + BS_opt_dam, & + dam_tot_id_file, & + IS_dam_tot,JS_dam_tot, & + IV_dam_tot_id, & + dam_use_id_file, & + IV_dam_use_id, & + IS_dam_use,JS_dam_use, & + IS_dam_bas,JS_dam_bas, & + IV_dam_bas_id,IV_dam_index,IV_dam_loc2, & + IS_opt_run, & + obs_tot_id_file, & + IS_obs_tot,JS_obs_tot, & + IV_obs_tot_id, & + obs_use_id_file, & + IV_obs_use_id, & + IS_obs_use,JS_obs_use, & + IS_obs_bas,JS_obs_bas, & + IV_obs_index,IV_obs_loc1, & + BS_logical,temp_char,rank,ierr,IS_one,ZS_val + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Relationship between entire domain and study basin +!******************************************************************************* + +!------------------------------------------------------------------------------- +!Read data files +!------------------------------------------------------------------------------- +open(10,file=rapid_connect_file,status='old') +do JS_riv_tot=1,IS_riv_tot + read(10,*) IV_riv_tot_id(JS_riv_tot), IV_down(JS_riv_tot), & + IV_nbup(JS_riv_tot), IM_up(JS_riv_tot,:) +enddo +close(10) + +open(11,file=riv_bas_id_file,status='old') +do JS_riv_bas=1,IS_riv_bas + read(11,*) IV_riv_bas_id(JS_riv_bas) +end do +close(11) + +!------------------------------------------------------------------------------- +!Populate hashtable-like matrices +!------------------------------------------------------------------------------- +call rapid_hsh_mat + +!------------------------------------------------------------------------------- +!Calculate IS_riv_bas +!------------------------------------------------------------------------------- +!This is actually given in the namelist + +!------------------------------------------------------------------------------- +!Allocate and initialize IV_riv_index, IV_riv_loc1, and IM_index_up +!------------------------------------------------------------------------------- +!Allocation is actually done in rapid_init.F90 +IV_riv_index=0 +IV_riv_loc1=0 +IM_index_up=0 + +!------------------------------------------------------------------------------- +!Populate IV_riv_index +!------------------------------------------------------------------------------- +do JS_riv_bas=1,IS_riv_bas + ZS_val=-999 + call MatGetValues(ZM_hsh_tot, & + IS_one,rank, & + IS_one,IV_riv_bas_id(JS_riv_bas)-1, & + ZS_val,ierr) + CHKERRQ(ierr) + JS_riv_tot=int(ZS_val) + if (JS_riv_tot>0) then + IV_riv_index(JS_riv_bas)=JS_riv_tot + else + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas) + call PetscPrintf(PETSC_COMM_WORLD, & + 'ERROR: reach ID' // temp_char // & + ' not included in domain' // char(10),ierr) + stop + end if +end do +!vector with (Fortran, 1-based) indexes corresponding to reaches of basin +!within whole network +!IV_riv_index has two advantages. 1) it is needed in order to read inflow +!data (Vlat for ex). 2) It allows to avoid one other nested loop in the +!following, which reduces tremendously the computation time. + +!------------------------------------------------------------------------------- +!Populate IV_riv_loc1 +!------------------------------------------------------------------------------- +do JS_riv_bas=1,IS_riv_bas + IV_riv_loc1(JS_riv_bas)=JS_riv_bas-1 +enddo +!vector with zero-base index corresponding to one-base index + +!------------------------------------------------------------------------------- +!Populate IM_index_up +!------------------------------------------------------------------------------- +do JS_riv_bas2=1,IS_riv_bas +do JS_up=1, IV_nbup(IV_riv_index(JS_riv_bas2)) + ZS_val=-999 + call MatGetValues(ZM_hsh_bas, & + IS_one,rank, & + IS_one,IM_up(IV_riv_index(JS_riv_bas2),JS_up)-1, & + ZS_val,ierr) + CHKERRQ(ierr) + JS_riv_bas=int(ZS_val) + if (JS_riv_bas>0) IM_index_up(JS_riv_bas2,JS_up)=JS_riv_bas +end do +end do +!Used in traditional Muskingum method and to quicken matrix prealloc. & creation + +!------------------------------------------------------------------------------- +!Optional, display IV_riv_loc1, IV_riv_index, and IM_index_up +!------------------------------------------------------------------------------- +!if (rank==0) then +! print *, IV_riv_loc1 +! print *, IV_riv_index +! do JS_riv_bas=1,IS_riv_bas +! print *, IM_index_up(JS_riv_bas,:) +! end do +!end if + + +!******************************************************************************* +!If human-induced flows are used +!******************************************************************************* +if (BS_opt_hum) then +call PetscPrintf(PETSC_COMM_WORLD,'WARNING: Human-induced option activated' // & + char(10),ierr) + +!------------------------------------------------------------------------------- +!Read data files +!------------------------------------------------------------------------------- +open(14,file=hum_tot_id_file,status='old') +read(14,*) IV_hum_tot_id +close(14) + +open(15,file=hum_use_id_file,status='old') +read(15,*) IV_hum_use_id +close(15) + +!------------------------------------------------------------------------------- +!Calculate IS_hum_bas +!------------------------------------------------------------------------------- +write(temp_char,'(i10)') IS_hum_tot +call PetscPrintf(PETSC_COMM_WORLD,' Total number of human-induced ' // & + 'IDs in hum_tot_id_file:' // temp_char // char(10),ierr) + +write(temp_char,'(i10)') IS_hum_use +call PetscPrintf(PETSC_COMM_WORLD,' Total number of human-induced ' // & + 'IDs in hum_use_id_file:' // temp_char // char(10),ierr) + +IS_hum_bas=0 +!initialize to zero + +do JS_hum_use=1,IS_hum_use + do JS_riv_bas=1,IS_riv_bas + if (IV_hum_use_id(JS_hum_use)==IV_riv_bas_id(JS_riv_bas)) then + IS_hum_bas=IS_hum_bas+1 + end if + end do +end do + +write(temp_char,'(i10)') IS_hum_bas +call PetscPrintf(PETSC_COMM_WORLD,' Total number of human-induced ' // & + 'IDs in this simulation:' // temp_char // char(10),ierr) + +!------------------------------------------------------------------------------- +!Allocate and initialize IV_hum_bas_id, IV_hum_index, IV_hum_loc1 +!------------------------------------------------------------------------------- +allocate(IV_hum_bas_id(IS_hum_bas)) +allocate(IV_hum_index(IS_hum_bas)) +allocate(IV_hum_loc1(IS_hum_bas)) + +IV_hum_bas_id=0 +IV_hum_index=0 +IV_hum_loc1=0 + +!------------------------------------------------------------------------------- +!Populate IV_hum_bas_id +!------------------------------------------------------------------------------- +if (IS_hum_bas>0) then + +JS_hum_bas=0 +do JS_hum_use=1,IS_hum_use +do JS_riv_bas=1,IS_riv_bas + if (IV_hum_use_id(JS_hum_use)==IV_riv_bas_id(JS_riv_bas)) then + JS_hum_bas=JS_hum_bas+1 + IV_hum_bas_id(JS_hum_bas)=IV_riv_bas_id(JS_riv_bas) + end if +end do +end do + +end if + +!------------------------------------------------------------------------------- +!Populate IV_hum_index +!------------------------------------------------------------------------------- +do JS_hum_bas=1,IS_hum_bas +do JS_hum_tot=1,IS_hum_tot + if (IV_hum_bas_id(JS_hum_bas)==IV_hum_tot_id(JS_hum_tot)) then + IV_hum_index(JS_hum_bas)=JS_hum_tot + end if +end do +end do + +!------------------------------------------------------------------------------- +!Populate IV_hum_loc1 +!------------------------------------------------------------------------------- +do JS_hum_bas=1,IS_hum_bas +do JS_riv_bas=1,IS_riv_bas + if (IV_riv_bas_id(JS_riv_bas)==IV_hum_bas_id(JS_hum_bas)) then + IV_hum_loc1(JS_hum_bas)=JS_riv_bas-1 + end if +end do +end do + +!------------------------------------------------------------------------------- +!Print warning when human-induced is used +!------------------------------------------------------------------------------- +if (rank==0 .and. IS_hum_bas>0) then + print *, ' Human-induced flows added to computed flows, using:' + !print *, ' IV_hum_tot_id =', IV_hum_tot_id + print *, ' IV_hum_use_id =', IV_hum_use_id + print *, ' IV_hum_bas_id =', IV_hum_bas_id + print *, ' IV_hum_index =', IV_hum_index + print *, ' IV_hum_loc1 =', IV_hum_loc1 +end if +!Warning about human-induced flows + +!------------------------------------------------------------------------------- +!End if human-induced is used +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!If forcing is used +!******************************************************************************* +if (BS_opt_for) then +call PetscPrintf(PETSC_COMM_WORLD,'WARNING: Forcing option activated'// & + char(10),ierr) + +!------------------------------------------------------------------------------- +!Read data files +!------------------------------------------------------------------------------- +open(16,file=for_tot_id_file,status='old') +read(16,*) IV_for_tot_id +close(16) + +open(17,file=for_use_id_file,status='old') +read(17,*) IV_for_use_id +close(17) + +!------------------------------------------------------------------------------- +!Calculate IS_for_bas +!------------------------------------------------------------------------------- +write(temp_char,'(i10)') IS_for_tot +call PetscPrintf(PETSC_COMM_WORLD,' Total number of forcing IDs in ' //& + 'for_tot_id_file:' // temp_char // char(10),ierr) + +write(temp_char,'(i10)') IS_for_use +call PetscPrintf(PETSC_COMM_WORLD,' Total number of forcing IDs in ' //& + 'for_use_id_file:' // temp_char // char(10),ierr) + +IS_for_bas=0 +!initialize to zero + +do JS_for_use=1,IS_for_use + do JS_riv_tot=1,IS_riv_tot + if (IV_for_use_id(JS_for_use)==IV_riv_tot_id(JS_riv_tot)) then + + do JS_riv_bas=1,IS_riv_bas + if (IV_down(JS_riv_tot)==IV_riv_bas_id(JS_riv_bas)) then + IS_for_bas=IS_for_bas+1 + end if + end do + + end if + end do +end do + +write(temp_char,'(i10)') IS_for_bas +call PetscPrintf(PETSC_COMM_WORLD,' Total number of forcing IDs in ' //& + 'this simulation:' // temp_char // char(10),ierr) + +!------------------------------------------------------------------------------- +!Allocate and initialize the vectors IV_for_index and IV_for_loc2 +!------------------------------------------------------------------------------- +allocate(IV_for_bas_id(IS_for_bas)) +allocate(IV_for_index(IS_for_bas)) +allocate(IV_for_loc2(IS_for_bas)) + +IV_for_bas_id=0 +IV_for_index=0 +IV_for_loc2=0 + +!------------------------------------------------------------------------------- +!Populate IV_for_bas_id +!------------------------------------------------------------------------------- +if (IS_for_bas>0) then + +JS_for_bas=0 +!initialize to zero + +do JS_for_use=1,IS_for_use + do JS_riv_tot=1,IS_riv_tot + if (IV_for_use_id(JS_for_use)==IV_riv_tot_id(JS_riv_tot)) then + + do JS_riv_bas=1,IS_riv_bas + if (IV_down(JS_riv_tot)==IV_riv_bas_id(JS_riv_bas)) then + JS_for_bas=JS_for_bas+1 + IV_for_bas_id(JS_for_bas)=IV_for_use_id(JS_for_use) + end if + end do + + end if + end do +end do + +end if + +!------------------------------------------------------------------------------- +!Populate IV_for_index +!------------------------------------------------------------------------------- +do JS_for_bas=1,IS_for_bas +do JS_for_tot=1,IS_for_tot + if (IV_for_bas_id(JS_for_bas)==IV_for_tot_id(JS_for_tot)) then + IV_for_index(JS_for_bas)=JS_for_tot + end if +end do +end do + +!------------------------------------------------------------------------------- +!Populate IV_for_loc2 +!------------------------------------------------------------------------------- +do JS_for_bas=1,IS_for_bas +do JS_riv_tot=1,IS_riv_tot + if (IV_for_bas_id(JS_for_bas)==IV_riv_tot_id(JS_riv_tot)) then + do JS_riv_bas=1,IS_riv_bas + +if (IV_down(JS_riv_tot)==IV_riv_bas_id(JS_riv_bas)) then + IV_for_loc2(JS_for_bas)=IV_riv_loc1(JS_riv_bas) +end if + + end do + end if +end do +end do + +!------------------------------------------------------------------------------- +!Print warning when forcing is used +!------------------------------------------------------------------------------- +if (rank==0 .and. IS_for_bas>0) then + print *, ' Forcing flows replace computed flows, using:' + !print *, ' IV_for_tot_id =', IV_for_tot_id + print *, ' IV_for_use_id =', IV_for_use_id + print *, ' IV_for_bas_id =', IV_for_bas_id + print *, ' IV_for_index =', IV_for_index + print *, ' IV_for_loc2 =', IV_for_loc2 +end if +!Warning about forcing downstream basins + +!------------------------------------------------------------------------------- +!End if forcing is used +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!If dam model is used +!******************************************************************************* +if (BS_opt_dam) then +call PetscPrintf(PETSC_COMM_WORLD,'WARNING: Dam option activated'// & + char(10),ierr) + +!------------------------------------------------------------------------------- +!Read data files +!------------------------------------------------------------------------------- +open(18,file=dam_tot_id_file,status='old') +read(18,*) IV_dam_tot_id +close(18) + +open(19,file=dam_use_id_file,status='old') +read(19,*) IV_dam_use_id +close(19) + +!------------------------------------------------------------------------------- +!Calculate IS_dam_bas +!------------------------------------------------------------------------------- +write(temp_char,'(i10)') IS_dam_tot +call PetscPrintf(PETSC_COMM_WORLD,' Total number of dam IDs in ' // & + 'dam_tot_id_file:' // temp_char // char(10),ierr) + +write(temp_char,'(i10)') IS_dam_use +call PetscPrintf(PETSC_COMM_WORLD,' Total number of dam IDs in ' // & + 'dam_use_id_file:' // temp_char // char(10),ierr) + +IS_dam_bas=0 + +do JS_dam_use=1,IS_dam_use +do JS_riv_bas=1,IS_riv_bas + if (IV_dam_use_id(JS_dam_use)==IV_riv_tot_id(IV_riv_index(JS_riv_bas)))then + IS_dam_bas=IS_dam_bas+1 + end if +end do +end do + +write(temp_char,'(i10)') IS_dam_bas +call PetscPrintf(PETSC_COMM_WORLD,' Total number of dam IDs in ' // & + 'this simulation:' // temp_char // char(10),ierr) + +!------------------------------------------------------------------------------- +!Allocate and initialize IV_dam_bas_id, IV_dam_index, IV_dam_loc2, IV_dam_pos +!------------------------------------------------------------------------------- +allocate(IV_dam_bas_id(IS_dam_bas)) +allocate(IV_dam_index(IS_dam_bas)) +allocate(IV_dam_loc2(IS_dam_bas)) +allocate(IV_dam_pos(IS_dam_tot)) + +IV_dam_bas_id=0 +IV_dam_index=0 +IV_dam_loc2=0 +IV_dam_pos=0 + +!------------------------------------------------------------------------------- +!Populate IV_dam_bas_id +!------------------------------------------------------------------------------- +if (IS_dam_bas>0) then + +JS_dam_bas=0 + +do JS_dam_use=1,IS_dam_use +do JS_riv_bas=1,IS_riv_bas + if (IV_dam_use_id(JS_dam_use)==IV_riv_tot_id(IV_riv_index(JS_riv_bas)))then + JS_dam_bas=JS_dam_bas+1 + IV_dam_bas_id(JS_dam_bas)=IV_riv_tot_id(IV_riv_index(JS_riv_bas)) + end if +end do +end do + +end if + +!------------------------------------------------------------------------------- +!Populate IV_dam_index +!------------------------------------------------------------------------------- +do JS_dam_bas=1,IS_dam_bas +do JS_dam_tot=1,IS_dam_tot + if (IV_dam_bas_id(JS_dam_bas)==IV_dam_tot_id(JS_dam_tot)) then + IV_dam_index(JS_dam_bas)=JS_dam_tot + end if +end do +end do + +!------------------------------------------------------------------------------- +!Populate IV_dam_loc2 +!------------------------------------------------------------------------------- +do JS_dam_bas=1,IS_dam_bas +do JS_riv_tot=1,IS_riv_tot + if (IV_dam_bas_id(JS_dam_bas)==IV_riv_tot_id(JS_riv_tot)) then + do JS_riv_bas=1,IS_riv_bas + +if (IV_riv_bas_id(JS_riv_bas)==IV_down(JS_riv_tot)) then + IV_dam_loc2(JS_dam_bas)=JS_riv_bas-1 +end if + end do + end if +end do +end do + +!------------------------------------------------------------------------------- +!Populate IV_dam_pos +!------------------------------------------------------------------------------- +do JS_dam_tot=1,IS_dam_tot +do JS_riv_bas=1,IS_riv_bas + if (IV_dam_tot_id(JS_dam_tot)==IV_riv_bas_id(JS_riv_bas)) then + IV_dam_pos(JS_dam_tot)=JS_riv_bas + end if +end do +end do + +!------------------------------------------------------------------------------- +!Print warning when dam model is used +!------------------------------------------------------------------------------- +if (rank==0 .and. IS_dam_bas>0) then + print *, ' Dam flows replace computed flows, using:' + !print *, ' IV_dam_tot_id =', IV_dam_tot_id + print *, ' IV_dam_use_id =', IV_dam_use_id + print *, ' IV_dam_bas_id =', IV_dam_bas_id + print *, ' IV_dam_index =', IV_dam_index + print *, ' IV_dam_loc2 =', IV_dam_loc2 +end if + +if (rank==0 .and. IS_dam_tot>0) then + print *, ' IV_dam_pos =', IV_dam_pos +end if +!Warning about forcing downstream basins + +!------------------------------------------------------------------------------- +!End if dam model is used +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!If optimization mode is selected +!******************************************************************************* +if (IS_opt_run==2) then + +!------------------------------------------------------------------------------- +!Read data files +!------------------------------------------------------------------------------- +open(12,file=obs_tot_id_file,status='old') +read(12,*) IV_obs_tot_id +close(12) + +open(13,file=obs_use_id_file,status='old') +read(13,*) IV_obs_use_id +close(13) + +!------------------------------------------------------------------------------- +!Calculate IS_obs_bas +!------------------------------------------------------------------------------- +write(temp_char,'(i10)') IS_obs_tot +call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in obs_tot_file ' // & + ' :' // temp_char // char(10),ierr) +write(temp_char,'(i10)') IS_obs_use +call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in obs_use_file ' // & + ' :' // temp_char // char(10),ierr) + +IS_obs_bas=0 +!initialize to zero + +do JS_obs_use=1,IS_obs_use + do JS_riv_bas=1,IS_riv_bas + if (IV_obs_use_id(JS_obs_use)==IV_riv_bas_id(JS_riv_bas)) then + IS_obs_bas=IS_obs_bas+1 + end if + end do +end do + +write(temp_char,'(i10)') IS_obs_bas +call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in ' // & + 'this simulation :'//temp_char // char(10),ierr) + +!------------------------------------------------------------------------------- +!Allocate and initialize the vectors IV_obs_index and IV_obs_loc1 +!------------------------------------------------------------------------------- +allocate(IV_obs_index(IS_obs_bas)) +allocate(IV_obs_loc1(IS_obs_bas)) +!allocate vector size + +do JS_obs_bas=1,IS_obs_bas + IV_obs_index(JS_obs_bas)=0 + IV_obs_loc1(JS_obs_bas)=0 +end do +!Initialize both vectors to zero + +!------------------------------------------------------------------------------- +!Populate the vectors IV_obs_index and IV_obs_loc1 +!------------------------------------------------------------------------------- +JS_obs_bas=1 +do JS_obs_use=1,IS_obs_use +do JS_riv_bas=1,IS_riv_bas + if (IV_obs_use_id(JS_obs_use)==IV_riv_bas_id(JS_riv_bas)) then + do JS_obs_tot=1,IS_obs_tot + if (IV_obs_use_id(JS_obs_use)==IV_obs_tot_id(JS_obs_tot)) then + IV_obs_index(JS_obs_bas)=JS_obs_tot + end if + end do + IV_obs_loc1(JS_obs_bas)=JS_riv_bas-1 + JS_obs_bas=JS_obs_bas+1 + end if +end do +end do +!Create vector IV_obs_index and IV_obs_loc1 + +!------------------------------------------------------------------------------- +!Optional - Display vectors +!------------------------------------------------------------------------------- +!if (rank==0) then +! print *, 'IV_obs_index=', IV_obs_index +! print *, 'IV_obs_loc1 =', IV_obs_loc1 +!end if + +!------------------------------------------------------------------------------- +!End if optimization mode is selected +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!End +!******************************************************************************* +call PetscPrintf(PETSC_COMM_WORLD,'Arrays created'//char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) +end subroutine rapid_arrays diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90 new file mode 100644 index 00000000..3ae59c74 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90 @@ -0,0 +1,40 @@ +!******************************************************************************* +!Subroutine - rapid_close_Qfor_file +!******************************************************************************* +subroutine rapid_close_Qfor_file + +!Purpose: +!Close Qfor_file from Fortran. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank + + +implicit none + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Close file +!******************************************************************************* +if (rank==0) close(34) + +!******************************************************************************* +!End subroutine +!******************************************************************************* +end subroutine rapid_close_Qfor_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90 new file mode 100644 index 00000000..4e5dd332 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90 @@ -0,0 +1,40 @@ +!******************************************************************************* +!Subroutine - rapid_close_Qhum_file +!******************************************************************************* +subroutine rapid_close_Qhum_file + +!Purpose: +!Close Qhum_file from Fortran. +!Author: +!Cedric H. David, 2014-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank + + +implicit none + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Close file +!******************************************************************************* +if (rank==0) close(36) + +!******************************************************************************* +!End subroutine +!******************************************************************************* +end subroutine rapid_close_Qhum_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90 new file mode 100644 index 00000000..d2b48114 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90 @@ -0,0 +1,40 @@ +!******************************************************************************* +!Subroutine - rapid_close_Qobs_file +!******************************************************************************* +subroutine rapid_close_Qobs_file + +!Purpose: +!Close Qobs_file from Fortran. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank + + +implicit none + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Close file +!******************************************************************************* +if (rank==0) close(33) + +!******************************************************************************* +!End subroutine +!******************************************************************************* +end subroutine rapid_close_Qobs_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90 new file mode 100644 index 00000000..82ebfa80 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90 @@ -0,0 +1,42 @@ +!******************************************************************************* +!Subroutine - rapid_close_Qout_file +!******************************************************************************* +subroutine rapid_close_Qout_file + +!Purpose: +!Close Qout_file from Fortran/netCDF. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + rank,IS_nc_status,IS_nc_id_fil_Qout + + +implicit none + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Close file +!******************************************************************************* +if (rank==0) IS_nc_status=NF90_CLOSE(IS_nc_id_fil_Qout) + + +!******************************************************************************* +!End subroutine +!******************************************************************************* +end subroutine rapid_close_Qout_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90 new file mode 100644 index 00000000..4279b0bd --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90 @@ -0,0 +1,42 @@ +!******************************************************************************* +!Subroutine - rapid_close_Vlat_file +!******************************************************************************* +subroutine rapid_close_Vlat_file + +!Purpose: +!Close Qobs_file from Fortran/netCDF. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + rank,IS_nc_status,IS_nc_id_fil_Vlat + + +implicit none + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Close file +!******************************************************************************* +if (rank==0) IS_nc_status=NF90_CLOSE(IS_nc_id_fil_Vlat) + + +!******************************************************************************* +!End subroutine +!******************************************************************************* +end subroutine rapid_close_Vlat_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90 new file mode 100644 index 00000000..4620b46a --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90 @@ -0,0 +1,65 @@ +!******************************************************************************* +!Subroutine - rapid_create_Qout_file +!******************************************************************************* +subroutine rapid_create_Qout_file(Qout_file) + +!Purpose: +!Create Qout_file from Fortran/netCDF. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + rank, & + IS_nc_status,IS_nc_id_fil_Qout, & + IS_nc_id_dim_time,IS_nc_id_dim_comid,IV_nc_id_dim, & + IS_nc_id_var_Qout,IS_nc_id_var_comid, & + IV_riv_bas_id,IS_riv_bas +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +character(len=100), intent(in):: Qout_file + + +!******************************************************************************* +!Open file +!******************************************************************************* +if (rank==0) then + + IS_nc_status=NF90_CREATE(Qout_file,NF90_CLOBBER,IS_nc_id_fil_Qout) + IS_nc_status=NF90_DEF_DIM(IS_nc_id_fil_Qout,'Time',NF90_UNLIMITED, & + IS_nc_id_dim_time) + IS_nc_status=NF90_DEF_DIM(IS_nc_id_fil_Qout,'COMID',IS_riv_bas, & + IS_nc_id_dim_comid) + IS_nc_status=NF90_DEF_VAR(IS_nc_id_fil_Qout,'COMID',NF90_INT, & + IS_nc_id_dim_comid,IS_nc_id_var_comid) + IV_nc_id_dim(1)=IS_nc_id_dim_comid + IV_nc_id_dim(2)=IS_nc_id_dim_time + IS_nc_status=NF90_DEF_VAR(IS_nc_id_fil_Qout,'Qout',NF90_REAL, & + IV_nc_id_dim,IS_nc_id_var_Qout) + IS_nc_status=NF90_ENDDEF(IS_nc_id_fil_Qout) + IS_nc_status=NF90_PUT_VAR(IS_nc_id_fil_Qout,IS_nc_id_var_comid, & + IV_riv_bas_id) + IS_nc_status=NF90_CLOSE(IS_nc_id_fil_Qout) + +end if + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_create_Qout_file + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90 new file mode 100644 index 00000000..e6498d69 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90 @@ -0,0 +1,219 @@ +!******************************************************************************* +!Subroutine - rapid_create_obj +!******************************************************************************* +subroutine rapid_create_obj + +!Purpose: +!All PETSc and TAO objects need be created (requirement of both mathematical +!libraries). PETSc and TAO also need be initialized. This is what's done here. +!Author: +!Cedric H. David, 2008-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_bas, & + ZM_hsh_tot,ZM_hsh_bas,IS_riv_id_max, & + ZM_Net,ZM_A,ZM_T,ZM_TC1, & + ZM_Obs,ZV_Qobs,ZV_temp1,ZV_temp2,ZV_kfac, & + ZV_k,ZV_x,ZV_p,ZV_pnorm,ZV_pfac, & + ZV_C1,ZV_C2,ZV_C3,ZV_Cdenom, & + ZV_b,ZV_babsmax,ZV_bhat, & + ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam, & + ZV_Vext,ZV_Vfor,ZV_Vlat, & + ZV_VinitM,ZV_QoutinitM,ZV_QoutinitO,ZV_QoutbarO, & + ZV_QoutR,ZV_QoutinitR,ZV_QoutprevR,ZV_QoutbarR,ZV_QinbarR, & + ZV_QoutRabsmin,ZV_QoutRabsmax,ZV_QoutRhat, & + ZV_VR,ZV_VinitR,ZV_VprevR,ZV_VbarR,ZV_VoutR, & + ZV_Qobsbarrec, & + ierr,ksp,vecscat,ZV_SeqZero,ZS_one,ZV_one,IS_one,ncore,rank + +#ifndef NO_TAO +use rapid_var, only : & + tao,reason,ZV_1stIndex,ZV_2ndIndex +#endif + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + +#ifndef NO_TAO +#include "finclude/taosolver.h" +!TAO solver +#endif + + +!******************************************************************************* +!Initialize PETSc and TAO, and create all the objects +!******************************************************************************* + +!Initialize PETSc -------------------------------------------------------------- +call PetscInitialize(PETSC_NULL_CHARACTER,ierr) + +!Determine number associated with each processor ------------------------------- +call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr) + +!Determine total number of cores used ------------------------------------------ +call MPI_Comm_size(PETSC_COMM_WORLD,ncore,ierr) + +!Create PETSc object that manages all Krylov methods --------------------------- +call KSPCreate(PETSC_COMM_WORLD,ksp,ierr) + +!Matrices----------------------------------------------------------------------- +call MatCreate(PETSC_COMM_WORLD,ZM_Net,ierr) +call MatSetSizes(ZM_Net,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr) +call MatSetFromOptions(ZM_Net,ierr) +call MatSetUp(ZM_Net,ierr) + +call MatCreate(PETSC_COMM_WORLD,ZM_A,ierr) +call MatSetSizes(ZM_A,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr) +call MatSetFromOptions(ZM_A,ierr) +call MatSetUp(ZM_A,ierr) + +call MatCreate(PETSC_COMM_WORLD,ZM_T,ierr) +call MatSetSizes(ZM_T,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr) +call MatSetFromOptions(ZM_T,ierr) +call MatSetUp(ZM_T,ierr) + +call MatCreate(PETSC_COMM_WORLD,ZM_TC1,ierr) +call MatSetSizes(ZM_TC1,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr) +call MatSetFromOptions(ZM_TC1,ierr) +call MatSetUp(ZM_TC1,ierr) + +call MatCreate(PETSC_COMM_WORLD,ZM_Obs,ierr) +call MatSetSizes(ZM_Obs,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr) +call MatSetFromOptions(ZM_Obs,ierr) +call MatSetUp(ZM_Obs,ierr) +!These matrices are all square of size IS_riv_bas. PETSC_DECIDE allows PETSc +!to determine the local sizes on its own. MatSetFromOptions allows to use many +!different options at runtime, such as "-mat_type aijmumps". + +call MatCreate(PETSC_COMM_WORLD,ZM_hsh_tot,ierr) +call MatSetSizes(ZM_hsh_tot,PETSC_DECIDE,PETSC_DECIDE,ncore,IS_riv_id_max,ierr) +call MatSetFromOptions(ZM_hsh_tot,ierr) +call MatSetUp(ZM_hsh_tot,ierr) + +call MatCreate(PETSC_COMM_WORLD,ZM_hsh_bas,ierr) +call MatSetSizes(ZM_hsh_bas,PETSC_DECIDE,PETSC_DECIDE,ncore,IS_riv_id_max,ierr) +call MatSetFromOptions(ZM_hsh_bas,ierr) +call MatSetUp(ZM_hsh_bas,ierr) +!These matrices are all mostly flat with size IS_riv_id_max*ncore and will store +!the same row over all columns + +!Vectors of size IS_riv_bas----------------------------------------------------- +!call VecCreateMPI(PETSC_COMM_WORLD,PETSC_DECIDE,IS_riv_bas,ZV_k,ierr) +call VecCreate(PETSC_COMM_WORLD,ZV_k,ierr) +call VecSetSizes(ZV_k,PETSC_DECIDE,IS_riv_bas,ierr) +call VecSetFromOptions(ZV_k,ierr) +!same remarks as above for sizes + +call VecDuplicate(ZV_k,ZV_x,ierr) +call VecDuplicate(ZV_k,ZV_C1,ierr) +call VecDuplicate(ZV_k,ZV_C2,ierr) +call VecDuplicate(ZV_k,ZV_C3,ierr) +call VecDuplicate(ZV_k,ZV_Cdenom,ierr) + +call VecDuplicate(ZV_k,ZV_b,ierr) +call VecDuplicate(ZV_k,ZV_babsmax,ierr) +call VecDuplicate(ZV_k,ZV_bhat,ierr) + +call VecDuplicate(ZV_k,ZV_Qext,ierr) +call VecDuplicate(ZV_k,ZV_Qfor,ierr) +call VecDuplicate(ZV_k,ZV_Qlat,ierr) +call VecDuplicate(ZV_k,ZV_Qhum,ierr) +call VecDuplicate(ZV_k,ZV_Qdam,ierr) +call VecDuplicate(ZV_k,ZV_Vext,ierr) +call VecDuplicate(ZV_k,ZV_Vfor,ierr) +call VecDuplicate(ZV_k,ZV_Vlat,ierr) + +call VecDuplicate(ZV_k,ZV_QoutinitM,ierr) +call VecDuplicate(ZV_k,ZV_QoutinitO,ierr) +call VecDuplicate(ZV_k,ZV_QoutbarO,ierr) + +call VecDuplicate(ZV_k,ZV_QoutR,ierr) +call VecDuplicate(ZV_k,ZV_QoutinitR,ierr) +call VecDuplicate(ZV_k,ZV_QoutprevR,ierr) +call VecDuplicate(ZV_k,ZV_QoutbarR,ierr) +call VecDuplicate(ZV_k,ZV_QinbarR,ierr) +call VecDuplicate(ZV_k,ZV_QoutRabsmin,ierr) +call VecDuplicate(ZV_k,ZV_QoutRabsmax,ierr) +call VecDuplicate(ZV_k,ZV_QoutRhat,ierr) + +call VecDuplicate(ZV_k,ZV_VinitM,ierr) + +call VecDuplicate(ZV_k,ZV_VR,ierr) +call VecDuplicate(ZV_k,ZV_VinitR,ierr) +call VecDuplicate(ZV_k,ZV_VprevR,ierr) +call VecDuplicate(ZV_k,ZV_VbarR,ierr) +call VecDuplicate(ZV_k,ZV_VoutR,ierr) + +call VecDuplicate(ZV_k,ZV_temp1,ierr) +call VecDuplicate(ZV_k,ZV_temp2,ierr) +call VecDuplicate(ZV_k,ZV_Qobs,ierr) +call VecDuplicate(ZV_k,ZV_kfac,ierr) +call VecDuplicate(ZV_k,ZV_Qobsbarrec,ierr) +!all the other vector objects are duplicates of the first one + + +!Vectors of parameters---------------------------------------------------------- +!call VecCreateMPI(PETSC_COMM_WORLD,PETSC_DECIDE,IS_one*2,ZV_p,ierr) +call VecCreate(PETSC_COMM_WORLD,ZV_p,ierr) +call VecSetSizes(ZV_p,PETSC_DECIDE,2*IS_one,ierr) +call VecSetFromOptions(ZV_p,ierr) +!same remarks as above for sizes + +call VecDuplicate(ZV_p,ZV_pnorm,ierr) +call VecDuplicate(ZV_p,ZV_pfac,ierr) + + +!Vectors and objects useful for PETSc programming------------------------------- +call VecDuplicate(ZV_k,ZV_one,ierr) +call VecSet(ZV_one,ZS_one,ierr) +!this is a vector with ones a each row, used for computations + +call VecScatterCreateToZero(ZV_k,vecscat,ZV_SeqZero,ierr) +!create scatter context from a distributed vector to a sequential vector on the +!zeroth processor. Also creates the vector ZV_SeqZero + + +!TAO specific------------------------------------------------------------------- +#ifndef NO_TAO +call TaoInitialize(PETSC_NULL_CHARACTER,ierr) +!Initialize TAO + +call TaoCreate(PETSC_COMM_WORLD,tao,ierr) +call TaoSetType(tao,'tao_nm',ierr) +!Create TAO App + +call VecDuplicate(ZV_p,ZV_1stIndex,ierr) +call VecSetValues(ZV_1stIndex,IS_one,0*IS_one,ZS_one,INSERT_VALUES,ierr) +call VecAssemblyBegin(ZV_1stIndex,ierr) +call VecAssemblyEnd(ZV_1stIndex,ierr) +!ZV_1stindex=[1;0] + +call VecDuplicate(ZV_p,ZV_2ndIndex,ierr) +call VecSetValues(ZV_2ndIndex,IS_one,IS_one,ZS_one,INSERT_VALUES,ierr) +call VecAssemblyBegin(ZV_2ndIndex,ierr) +call VecAssemblyEnd(ZV_2ndIndex,ierr) +!ZV_2ndindex=[0;1] +#endif + +end subroutine rapid_create_obj diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90 new file mode 100644 index 00000000..c7c77c16 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90 @@ -0,0 +1,147 @@ +!******************************************************************************* +!Subroutine - rapid_destro_obj +!******************************************************************************* +subroutine rapid_destro_obj + +!Purpose: +!All PETSc and TAO objects need be destroyed (requirement of both mathematical +!libraries). PETSc and TAO also need be finalized. This is what's done here +!Note: only finilized here, need to add destroy of vectors. +!Author: +!Cedric H. David, 2008-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_bas, & + ZM_hsh_tot,ZM_hsh_bas, & + ZM_Net,ZM_A,ZM_T,ZM_TC1, & + ZM_Obs,ZV_Qobs,ZV_temp1,ZV_temp2,ZV_kfac, & + ZV_k,ZV_x,ZV_p,ZV_pnorm,ZV_pfac, & + ZV_C1,ZV_C2,ZV_C3,ZV_Cdenom, & + ZV_b,ZV_babsmax,ZV_bhat, & + ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam, & + ZV_Vext,ZV_Vfor,ZV_Vlat, & + ZV_VinitM,ZV_QoutinitM,ZV_QoutinitO,ZV_QoutbarO, & + ZV_QoutR,ZV_QoutinitR,ZV_QoutprevR,ZV_QoutbarR,ZV_QinbarR, & + ZV_QoutRabsmin,ZV_QoutRabsmax,ZV_QoutRhat, & + ZV_VR,ZV_VinitR,ZV_VprevR,ZV_VbarR,ZV_VoutR, & + ZV_Qobsbarrec, & + ierr,ksp,vecscat,ZV_SeqZero,ZS_one,ZV_one,IS_one + +#ifndef NO_TAO +use rapid_var, only : & + tao,reason,ZV_1stIndex,ZV_2ndIndex +#endif + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + +#ifndef NO_TAO +#include "finclude/taosolver.h" +!TAO solver +#endif + + +!******************************************************************************* +!Destruct all objects and finalize PETSc and TAO +!******************************************************************************* +!TAO specific------------------------------------------------------------------- +#ifndef NO_TAO +call VecDestroy(ZV_1stIndex,ierr) +call VecDestroy(ZV_2ndIndex,ierr) +call TaoDestroy(tao,ierr) +call TaoFinalize(ierr) +#endif + +call KSPDestroy(ksp,ierr) + +call MatDestroy(ZM_hsh_tot,ierr) +call MatDestroy(ZM_hsh_bas,ierr) + +call MatDestroy(ZM_A,ierr) +call MatDestroy(ZM_Net,ierr) +call MatDestroy(ZM_T,ierr) +call MatDestroy(ZM_TC1,ierr) +call MatDestroy(ZM_Obs,ierr) + +call VecDestroy(ZV_k,ierr) +call VecDestroy(ZV_x,ierr) +call VecDestroy(ZV_C1,ierr) +call VecDestroy(ZV_C2,ierr) +call VecDestroy(ZV_C3,ierr) +call VecDestroy(ZV_Cdenom,ierr) + +call VecDestroy(ZV_b,ierr) +call VecDestroy(ZV_babsmax,ierr) +call VecDestroy(ZV_bhat,ierr) + +call VecDestroy(ZV_Qext,ierr) +call VecDestroy(ZV_Qfor,ierr) +call VecDestroy(ZV_Qlat,ierr) +call VecDestroy(ZV_Qhum,ierr) +call VecDestroy(ZV_Qdam,ierr) +call VecDestroy(ZV_Vext,ierr) +call VecDestroy(ZV_Vfor,ierr) +call VecDestroy(ZV_Vlat,ierr) + +call VecDestroy(ZV_QoutinitM,ierr) +call VecDestroy(ZV_QoutinitO,ierr) +call VecDestroy(ZV_QoutbarO,ierr) + +call VecDestroy(ZV_QoutR,ierr) +call VecDestroy(ZV_QoutinitR,ierr) +call VecDestroy(ZV_QoutprevR,ierr) +call VecDestroy(ZV_QoutbarR,ierr) +call VecDestroy(ZV_QinbarR,ierr) +call VecDestroy(ZV_QoutRabsmin,ierr) +call VecDestroy(ZV_QoutRabsmax,ierr) +call VecDestroy(ZV_QoutRhat,ierr) + +call VecDestroy(ZV_VinitM,ierr) + +call VecDestroy(ZV_VR,ierr) +call VecDestroy(ZV_VinitR,ierr) +call VecDestroy(ZV_VprevR,ierr) +call VecDestroy(ZV_VbarR,ierr) +call VecDestroy(ZV_VoutR,ierr) + +call VecDestroy(ZV_temp1,ierr) +call VecDestroy(ZV_temp2,ierr) +call VecDestroy(ZV_Qobs,ierr) +call VecDestroy(ZV_kfac,ierr) +call VecDestroy(ZV_Qobsbarrec,ierr) + +call VecDestroy(ZV_one,ierr) + +call VecDestroy(ZV_p,ierr) +call VecDestroy(ZV_pnorm,ierr) +call VecDestroy(ZV_pfac,ierr) + +call VecDestroy(ZV_SeqZero,ierr) +call VecScatterDestroy(vecscat,ierr) +!Need to be destroyed separately even though created together + +call PetscFinalize(ierr) + + +end subroutine rapid_destro_obj diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_final.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_final.F90 new file mode 100644 index 00000000..a1a2ca98 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_final.F90 @@ -0,0 +1,192 @@ +!******************************************************************************* +!Subroutine - rapid_final +!******************************************************************************* +subroutine rapid_final + +!Purpose: +!This subroutine allows to finalize RAPID for both regular runs and +!optimization runs, by performing slightly different tasks depending on what +!option is chosen. +!Finalization Initialization tasks specific to Option 1 +! -Output final instantaneous flow +! -Output babsmax, QoutRabsmin and QoutRabsmax +!Finalization Initialization tasks specific to Option 2 +! -N/A +!Finalization tasks common to all RAPID options: +! -Prints some information about the types of objects used during simulation +! -Destroy all PETSc and TAO objects +!Author: +!Cedric H. David, 2012-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_bas,JS_riv_bas, & + IS_opt_routing,IS_opt_run, & + BS_opt_Qfinal,BS_opt_influence, & + Qfinal_file,babsmax_file,QoutRabsmin_file,QoutRabsmax_file, & + ksp,vecscat,ZV_babsmax,ZV_QoutR,ZV_SeqZero,ierr, & + ZV_pointer,rank,ZV_k,temp_char, & + ZV_QoutRabsmin,ZV_QoutRabsmax, & + temp_char2,ZM_A,pc, & + IS_ksp_iter_max + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Finalization procedure for OPTION 1 +!******************************************************************************* +if (IS_opt_run==1) then + +!------------------------------------------------------------------------------- +!Output final instantaneous Q (ZV_QoutR) +!------------------------------------------------------------------------------- +if (BS_opt_Qfinal) then +call VecScatterBegin(vecscat,ZV_QoutR,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecScatterEnd(vecscat,ZV_QoutR,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr) +if (rank==0) then + open(31,file=Qfinal_file) + do JS_riv_bas=1,IS_riv_bas + write(31,*) ZV_pointer(JS_riv_bas) + end do + close(31) +end if +call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr) +end if + +!------------------------------------------------------------------------------- +!Output maximum absolute values of vector b (right-hand side of linear system) +!------------------------------------------------------------------------------- +if (BS_opt_influence) then +call VecScatterBegin(vecscat,ZV_babsmax,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecScatterEnd(vecscat,ZV_babsmax,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr) +if (rank==0) then + open(42,file=babsmax_file) + do JS_riv_bas=1,IS_riv_bas + write(42,*) ZV_pointer(JS_riv_bas) + end do + close(42) +end if +call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr) +end if + +!------------------------------------------------------------------------------- +!Output minimum absolute values of instantaneous flow +!------------------------------------------------------------------------------- +if (BS_opt_influence) then +call VecScatterBegin(vecscat,ZV_QoutRabsmin,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecScatterEnd(vecscat,ZV_QoutRabsmin,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr) +if (rank==0) then + open(43,file=QoutRabsmin_file) + do JS_riv_bas=1,IS_riv_bas + write(43,*) ZV_pointer(JS_riv_bas) + end do + close(43) +end if +call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr) +end if + +!------------------------------------------------------------------------------- +!Output maximum absolute values of instantaneous flow +!------------------------------------------------------------------------------- +if (BS_opt_influence) then +call VecScatterBegin(vecscat,ZV_QoutRabsmax,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecScatterEnd(vecscat,ZV_QoutRabsmax,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr) +if (rank==0) then + open(44,file=QoutRabsmax_file) + do JS_riv_bas=1,IS_riv_bas + write(44,*) ZV_pointer(JS_riv_bas) + end do + close(44) +end if +call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr) +end if + +!------------------------------------------------------------------------------- +!End of initialization procedure for OPTION 1 +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!Some information about types of objects used within RAPID run +!******************************************************************************* +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) +call VecGetType(ZV_k,temp_char,ierr) +call PetscPrintf(PETSC_COMM_WORLD,'type of vector: '//temp_char//char(10),ierr) +call MatGetType(ZM_A,temp_char,ierr) +call PetscPrintf(PETSC_COMM_WORLD,'type of matrix: '//temp_char//char(10),ierr) +if (IS_opt_routing==1 .or. IS_opt_routing==3) then + call KSPGetType(ksp,temp_char,ierr) +else + temp_char='No KSP' +end if +call PetscPrintf(PETSC_COMM_WORLD,'type of KSP : '//temp_char//char(10),ierr) +if (IS_opt_routing==1 .or. IS_opt_routing==3) then + call KSPGetPC(ksp,pc,ierr) + call PCGetType(pc,temp_char,ierr) +else + temp_char='No PC' +end if +call PetscPrintf(PETSC_COMM_WORLD,'type of PC : '//temp_char//char(10),ierr) +#ifdef NO_TAO +call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'RAPID compiled and run without TAO',ierr) +call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr) +#endif +write(temp_char ,'(i10)') rank +write(temp_char2,'(i10)') IS_ksp_iter_max +call PetscSynchronizedPrintf(PETSC_COMM_WORLD,'Rank :'//temp_char //', '// & + 'Max KSP :'//temp_char2// & + char(10),ierr) +call PetscSynchronizedFlush(PETSC_COMM_WORLD,ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,char(10)//char(10)//char(10)//char(10),ierr) + +!******************************************************************************* +!Destroy all objects +!******************************************************************************* +call rapid_destro_obj +!destroy PETSc and TAO objects (Mat,Vec,taoapp...), finalizes the libraries + + +!******************************************************************************* +!End subroutine +!******************************************************************************* +end subroutine rapid_final diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90 new file mode 100644 index 00000000..91e58452 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90 @@ -0,0 +1,129 @@ +!******************************************************************************* +!Subroutine - rapid_get_Qdam +!******************************************************************************* +subroutine rapid_get_Qdam + +!Purpose: +!Communicate with a dam subroutine to exchange inflows and outflows. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank,ierr,vecscat,ZV_pointer,ZV_SeqZero,ZS_one, & + ZM_Net,ZV_Qext,ZV_Qdam,ZV_QoutbarR,ZV_QinbarR, & + IS_dam_bas,IV_dam_index,IV_dam_loc2, & + IV_dam_pos + +use rapid_var, only : & + ZV_Qin_dam,ZV_Qout_dam,ZV_Qin_dam_prev,ZV_Qout_dam_prev + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Compute previous inflow from river network and outside of river network to dams +!******************************************************************************* +!------------------------------------------------------------------------------- +!Compute inflow into dams from previous river flow +!------------------------------------------------------------------------------- +call MatMult(ZM_Net,ZV_QoutbarR,ZV_QinbarR,ierr) +call VecAXPY(ZV_QinbarR,ZS_one,ZV_Qext,ierr) +!QinbarR=Net*QoutbarR+Qext + +!------------------------------------------------------------------------------- +!Set values from PETSc vector into Fortran vector +!------------------------------------------------------------------------------- +if (rank==0) ZV_Qin_dam_prev=0 +call VecScatterBegin(vecscat,ZV_QinbarR,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecScatterEnd(vecscat,ZV_QinbarR,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr) +if (rank==0) ZV_Qin_dam_prev=ZV_pointer(IV_dam_pos) +call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr) +!Get values from ZV_QinbarR (PETSc) into ZV_Qin_dam_prev (Fortran) + + +!******************************************************************************* +!Compute outflow from dams +!******************************************************************************* +!------------------------------------------------------------------------------- +!If dam module does not exist, outflow is computed from this subroutine +!------------------------------------------------------------------------------- +if (rank==0) then + ZV_Qout_dam=ZV_Qin_dam_prev +end if + +!------------------------------------------------------------------------------- +!If dam module does exist, use it +!------------------------------------------------------------------------------- +!if (rank==0) then +! call dam_linear(ZV_Qin_dam_prev,ZV_Qout_dam_prev,ZV_Qout_dam) +!end if + + +!******************************************************************************* +!Optional - Write information in stdout +!******************************************************************************* +!if (rank==0) print *, 'Qin_dam_prev =', ',', ZV_Qin_dam_prev +!if (rank==0) print *, 'Qin_dam_prev =', ',', ZV_Qin_dam_prev(1) +!if (rank==0) print *, 'Qout_dam_prev =', ',', ZV_Qout_dam_prev +!if (rank==0) print *, 'Qout_dam_prev =', ',', ZV_Qout_dam_prev(1) +!if (rank==0) print *, ZV_Qin_dam_prev(1), ',', ZV_Qout_dam_prev(1) +!call VecView(ZV_Qdam,PETSC_VIEWER_STDOUT_WORLD,ierr) + + +!******************************************************************************* +!Set values from Fortran vector into PETSc vector +!******************************************************************************* +if (rank==0) then + call VecSetValues(ZV_Qdam,IS_dam_bas,IV_dam_loc2, & + ZV_Qout_dam(IV_dam_index),INSERT_VALUES,ierr) +end if + +call VecAssemblyBegin(ZV_Qdam,ierr) +call VecAssemblyEnd(ZV_Qdam,ierr) + + +!******************************************************************************* +!Update ZV_Qout_dam_prev - After calling dam_linear to not override init. values +!******************************************************************************* +if (rank==0) then + ZV_Qout_dam_prev=ZV_Qout_dam +end if + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_get_Qdam diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90 new file mode 100644 index 00000000..c3a4fd64 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90 @@ -0,0 +1,236 @@ +!******************************************************************************* +!Subroutine - rapid_hsh_mat +!******************************************************************************* +subroutine rapid_hsh_mat + +!Purpose: +!This creates two hashtable-like sparse matrices: +! - IM_hsh_tot contains the index over the domain (JS_riv_tot) corresponding to +! each reach ID and is the same for each row +! - IM_hsh_bas contains the index over the basin (JS_riv_bas) corresponding to +! each reach ID and is the same for each row +!The choice of matrices to mimic hashtables is possible because the "keys" (i.e. +!the reach IDs) are all integers, and the sparse structure allows to keep memory +!usage minimal because the number of unique reach IDs is far inferior to the +!maximum integer value of reach ID. Implementing a C++ hashtable within Fortran +!would have required much more intrusive modifications to RAPID. +!Thank you to Chris A. Mattmann and to Si Liu who both suggested the use of +!hashtables to decrease model setup time. +!Author: +!Cedric H. David, 2015-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_tot,IS_riv_bas, & + JS_riv_tot,JS_riv_bas, & + IV_riv_tot_id,IV_riv_bas_id, & + IS_riv_id_max, & + ZM_hsh_tot,ZM_hsh_bas, & + IS_ownfirst,IS_ownlast, & + IS_one,ZS_one,temp_char,temp_char2,ierr,rank,ncore + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +PetscInt, dimension(ncore) :: IS_nz, IS_dnz, IS_onz +PetscInt, dimension(IS_riv_tot) :: IV_tot_tmp1, IV_tot_tmp2 +PetscInt, dimension(IS_riv_bas) :: IV_bas_tmp1, IV_bas_tmp2 + + +!******************************************************************************* +!Check that reach IDs are within the allowed range +!******************************************************************************* +write(temp_char2,'(i10)') IS_riv_id_max + +do JS_riv_tot=1,IS_riv_tot + if (IV_riv_tot_id(JS_riv_tot) > IS_riv_id_max) then + write(temp_char,'(i10)') IV_riv_tot_id(JS_riv_tot) + call PetscPrintf(PETSC_COMM_WORLD, & + 'ERROR: reach ID' // temp_char // ' in domain' // & + ' has an integer value greater than the maximum' // & + ' allowed of' // temp_char2 // char(10),ierr) + stop + end if + if (IV_riv_tot_id(JS_riv_tot) == 0) then + write(temp_char,'(i10)') JS_riv_tot + call PetscPrintf(PETSC_COMM_WORLD, & + 'ERROR: reach ID located at index'// temp_char// & + ' in domain has a null value for ID'//char(10),ierr) + stop + end if +end do + +do JS_riv_bas=1,IS_riv_bas + if (IV_riv_bas_id(JS_riv_bas) > IS_riv_id_max) then + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas) + call PetscPrintf(PETSC_COMM_WORLD, & + 'ERROR: reach ID' // temp_char // ' in basin' // & + ' has an integer value greater than the maximum' // & + ' allowed of' // temp_char2 // char(10),ierr) + stop + end if + if (IV_riv_bas_id(JS_riv_bas) == 0) then + write(temp_char,'(i10)') JS_riv_bas + call PetscPrintf(PETSC_COMM_WORLD, & + 'ERROR: reach ID located at index'// temp_char// & + ' in basin has a null value for ID'//char(10),ierr) + stop + end if +end do + + +!******************************************************************************* +!Matrix preallocation +!******************************************************************************* +call MatGetOwnershipRangeColumn(ZM_hsh_tot,IS_ownfirst,IS_ownlast,ierr) + +!------------------------------------------------------------------------------- +!ZM_hsh_tot +!------------------------------------------------------------------------------- +IS_nz=0 +IS_dnz=0 +IS_onz=0 + +IS_nz=IS_riv_tot +do JS_riv_tot=1,IS_riv_tot + if (IV_riv_tot_id(JS_riv_tot) -1 >= IS_ownfirst .and. & + IV_riv_tot_id(JS_riv_tot) -1 < IS_ownlast) then + IS_dnz=IS_dnz+1 + end if + IS_onz=IS_nz-IS_dnz +end do + +call MatSeqAIJSetPreallocation(ZM_hsh_tot,PETSC_NULL_INTEGER,IS_nz,ierr) +call MatMPIAIJSetPreallocation(ZM_hsh_tot, & + PETSC_NULL_INTEGER, & + IS_dnz, & + PETSC_NULL_INTEGER, & + IS_onz,ierr) +!print *, 'rank', rank, 'IS_ownfirst', IS_ownfirst, 'IS_ownlast', IS_ownlast, & +! 'IS_nz', IS_nz, 'IS_dnz', IS_dnz, 'IS_onz', IS_onz + +!------------------------------------------------------------------------------- +!ZM_hsh_bas +!------------------------------------------------------------------------------- +IS_nz=0 +IS_dnz=0 +IS_onz=0 + +IS_nz=IS_riv_bas +do JS_riv_bas=1,IS_riv_bas + if (IV_riv_bas_id(JS_riv_bas) -1 >= IS_ownfirst .and. & + IV_riv_bas_id(JS_riv_bas) -1 < IS_ownlast) then + IS_dnz=IS_dnz+1 + end if + IS_onz=IS_nz-IS_dnz +end do + +call MatSeqAIJSetPreallocation(ZM_hsh_bas,PETSC_NULL_INTEGER,IS_nz,ierr) +call MatMPIAIJSetPreallocation(ZM_hsh_bas, & + PETSC_NULL_INTEGER, & + IS_dnz, & + PETSC_NULL_INTEGER, & + IS_onz,ierr) +!print *, 'rank', rank, 'IS_ownfirst', IS_ownfirst, 'IS_ownlast', IS_ownlast, & +! 'IS_nz', IS_nz, 'IS_dnz', IS_dnz, 'IS_onz', IS_onz + +!------------------------------------------------------------------------------- +!Done with preallocation +!------------------------------------------------------------------------------- +call PetscPrintf(PETSC_COMM_WORLD,'Hashtable-like matrices preallocated' & + //char(10),ierr) + + +!******************************************************************************* +!Creates hashtable-like matrices +!******************************************************************************* + +!------------------------------------------------------------------------------- +!ZM_hsh_tot +!------------------------------------------------------------------------------- +do JS_riv_tot=1,IS_riv_tot + IV_tot_tmp1(JS_riv_tot)=IV_riv_tot_id(JS_riv_tot) + IV_tot_tmp2(JS_riv_tot)=JS_riv_tot +end do +call PetscSortIntWithArray(IS_riv_tot,IV_tot_tmp1(:),IV_tot_tmp2(:),ierr) +!Populating ZM_hsh_* below much faster w/ sorted arrays than w/ IV_riv_*_id + +do JS_riv_tot=1,IS_riv_tot + call MatSetValues(ZM_hsh_tot, & + IS_one,rank, & + IS_one,IV_tot_tmp1(JS_riv_tot)-1, & + ZS_one*IV_tot_tmp2(JS_riv_tot),INSERT_VALUES,ierr) + CHKERRQ(ierr) +end do + +!------------------------------------------------------------------------------- +!ZM_hsh_bas +!------------------------------------------------------------------------------- +do JS_riv_bas=1,IS_riv_bas + IV_bas_tmp1(JS_riv_bas)=IV_riv_bas_id(JS_riv_bas) + IV_bas_tmp2(JS_riv_bas)=JS_riv_bas +end do +call PetscSortIntWithArray(IS_riv_bas,IV_bas_tmp1(:),IV_bas_tmp2(:),ierr) +!Populating ZM_hsh_* below much faster w/ sorted arrays than w/ IV_riv_*_id + +do JS_riv_bas=1,IS_riv_bas + call MatSetValues(ZM_hsh_bas, & + IS_one,rank, & + IS_one,IV_bas_tmp1(JS_riv_bas)-1, & + ZS_one*IV_bas_tmp2(JS_riv_bas),INSERT_VALUES,ierr) + CHKERRQ(ierr) +end do + +!------------------------------------------------------------------------------- +!Assemble matrices +!------------------------------------------------------------------------------- +call MatAssemblyBegin(ZM_hsh_tot,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_hsh_tot,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyBegin(ZM_hsh_bas,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_hsh_bas,MAT_FINAL_ASSEMBLY,ierr) +!sparse matrices need be assembled once their elements have been filled +call PetscPrintf(PETSC_COMM_WORLD,'Hashtable-like matrices created'//char(10), & + ierr) + + +!******************************************************************************* +!Display matrices on stdout +!******************************************************************************* +!call PetscPrintf(PETSC_COMM_WORLD,'ZM_hsh_tot'//char(10),ierr) +!call MatView(ZM_hsh_tot,PETSC_VIEWER_STDOUT_WORLD,ierr) +! +!call PetscPrintf(PETSC_COMM_WORLD,'ZM_hsh_bas'//char(10),ierr) +!call MatView(ZM_hsh_bas,PETSC_VIEWER_STDOUT_WORLD,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + + +end subroutine rapid_hsh_mat diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 new file mode 100644 index 00000000..71766b03 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 @@ -0,0 +1,397 @@ +!******************************************************************************* +!Subroutine - rapid_init +!******************************************************************************* +subroutine rapid_init + +!Purpose: +!This subroutine allows to initialize RAPID for both regular runs and +!optimization runs, by performing slightly different tasks depending on what +!option is chosen. +!Initialization tasks common to all RAPID options: +! -Read namelist file (sizes of domain, duration, file names, options, etc.) +! -Compute number of time steps based on durations +! -Allocate Fortran arrays +! -Create all PETSc and TAO objects +! -Print information and warnings +! -Determine IDs for various computing cores +! -Compute helpful arrays +! -Compute the network matrix +! -Initialize values of flow and volume for main procedure +!Initialization tasks specific to Option 1 +! -Copy main initial flow and vol to routing initial flow and vol +! -Read k and x +! -Compute linear system matrix +!Initialization tasks specific to Option 2 +! -Copy main initial flow to optimization initial flow +! -Compute the observation matrix +! -Read kfac and Qobsbarrec +! -Set initial values for the vector pnorm +!Author: +!Cedric H. David, 2012-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_tot,IS_riv_bas, & + IV_riv_bas_id,IV_riv_index,IV_riv_loc1,IV_riv_tot_id, & + IV_down,IV_nbup,IM_up,IM_index_up,IS_max_up, & + IV_nz,IV_dnz,IV_onz, & + BS_opt_Qinit,BS_opt_Qfinal,BS_opt_influence, & + BS_opt_dam,BS_opt_for,BS_opt_hum, & + IS_opt_run,IS_opt_routing,IS_opt_phi, & + ZV_read_riv_tot,ZV_read_obs_tot,ZV_read_hum_tot, & + ZV_read_for_tot,ZV_read_dam_tot, & + ZS_TauM,ZS_TauO,ZS_TauR,ZS_dtO,ZS_dtR,ZS_dtM,ZS_dtF,ZS_dtH, & + IS_obs_tot,IS_obs_use,IS_obs_bas, & + IV_obs_tot_id,IV_obs_use_id, & + IV_obs_index,IV_obs_loc1, & + IS_hum_tot,IS_hum_use, & + IV_hum_tot_id,IV_hum_use_id, & + IS_for_tot,IS_for_use, & + IV_for_tot_id,IV_for_use_id, & + IS_dam_tot,IS_dam_use, & + IV_dam_tot_id,IV_dam_use_id, & + ZV_Qin_dam,ZV_Qout_dam,ZV_Qin_dam_prev,ZV_Qout_dam_prev, & + ZV_Qin_dam0,ZV_Qout_dam0, & + ZV_QoutinitM,ZV_QoutinitO,ZV_QoutinitR, & + ZV_VinitM,ZV_VinitR, & + ZV_babsmax,ZV_QoutRabsmin,ZV_QoutRabsmax, & + IS_M,IS_O,IS_R,IS_RpO,IS_RpM,IS_RpF,IS_RpH, & + kfac_file,x_file,k_file,Vlat_file,Qinit_file, & + Qobsbarrec_file, & + ZS_Qout0,ZS_V0, & + ZV_Qobsbarrec, & + ZV_k,ZV_x,ZV_kfac,ZV_p,ZV_pnorm,ZV_pfac, & + ZS_knorm_init,ZS_xnorm_init,ZS_kfac,ZS_xfac, & + ZV_C1,ZV_C2,ZV_C3,ZM_A, & + ierr,ksp,rank,ncore,IS_one,ZS_one + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + +!******************************************************************************* +!Initialization procedure common to all options +!******************************************************************************* + +!------------------------------------------------------------------------------- +!Read name list, allocate Fortran arrays +!------------------------------------------------------------------------------- +call rapid_read_namelist + +print *,'!!!LPR enter rapid_init' + +allocate(IV_riv_bas_id(IS_riv_bas)) +allocate(IV_riv_index(IS_riv_bas)) +allocate(IV_riv_loc1(IS_riv_bas)) + +allocate(IV_riv_tot_id(IS_riv_tot)) +allocate(IV_down(IS_riv_tot)) +allocate(IV_nbup(IS_riv_tot)) +allocate(IM_up(IS_riv_tot,IS_max_up)) +allocate(IM_index_up(IS_riv_tot,IS_max_up)) + +allocate(IV_nz(IS_riv_bas)) +allocate(IV_dnz(IS_riv_bas)) +allocate(IV_onz(IS_riv_bas)) + +allocate(ZV_read_riv_tot(IS_riv_tot)) + +print *,'!!!LPR passed several allocation' + +if (IS_opt_run==2) then + allocate(IV_obs_tot_id(IS_obs_tot)) + allocate(IV_obs_use_id(IS_obs_use)) + allocate(ZV_read_obs_tot(IS_obs_tot)) +end if + +if (BS_opt_hum) then + allocate(IV_hum_tot_id(IS_hum_tot)) + allocate(IV_hum_use_id(IS_hum_use)) + allocate(ZV_read_hum_tot(IS_hum_tot)) +end if + +if (BS_opt_for) then + allocate(IV_for_tot_id(IS_for_tot)) + allocate(IV_for_use_id(IS_for_use)) + allocate(ZV_read_for_tot(IS_for_tot)) +end if + +if (BS_opt_dam) then + allocate(IV_dam_tot_id(IS_dam_tot)) + allocate(IV_dam_use_id(IS_dam_use)) + allocate(ZV_read_dam_tot(IS_dam_tot)) + allocate(ZV_Qin_dam(IS_dam_tot)) + allocate(ZV_Qin_dam_prev(IS_dam_tot)) + allocate(ZV_Qout_dam(IS_dam_tot)) + allocate(ZV_Qout_dam_prev(IS_dam_tot)) + allocate(ZV_Qin_dam0(IS_dam_tot)) + allocate(ZV_Qout_dam0(IS_dam_tot)) +end if + +!------------------------------------------------------------------------------- +!Make sure some Fortran arrays are initialized to zero +!------------------------------------------------------------------------------- +if (BS_opt_dam) then + ZV_Qin_dam0 =0 + ZV_Qout_dam0=0 +end if +!These are not populated anywhere before being used and hold meaningless values + +!------------------------------------------------------------------------------- +!Compute number of time steps +!------------------------------------------------------------------------------- +IS_M=int(ZS_TauM/ZS_dtM) +IS_O=int(ZS_TauO/ZS_dtO) +IS_R=int(ZS_TauR/ZS_dtR) +IS_RpO=int(ZS_dtO/ZS_TauR) +IS_RpM=int(ZS_dtM/ZS_TauR) +IS_RpF=int(ZS_dtF/ZS_TauR) +IS_RpH=int(ZS_dtH/ZS_TauR) + +!------------------------------------------------------------------------------- +!Initialize libraries and create objects common to all options +!------------------------------------------------------------------------------- +print *,'!!!LPR before create obj' +call rapid_create_obj +print *,'!!!LPR after create obj' +!Initialize libraries and create PETSc and TAO objects (Mat,Vec,taoapp...) + +!------------------------------------------------------------------------------- +!Prints information about current model run based on info from namelist +!------------------------------------------------------------------------------- +if (rank==0 .and. .not. BS_opt_Qinit) print '(a70)', & + 'Not reading initial flows from a file ' +if (rank==0 .and. BS_opt_Qinit) print '(a70)', & + 'Reading initial flows from a file ' +if (rank==0 .and. .not. BS_opt_Qfinal .and. IS_opt_run==1) print '(a70)', & + 'Not writing final flows into a file ' +if (rank==0 .and. BS_opt_Qfinal .and. IS_opt_run==1) print '(a70)', & + 'Writing final flows into a file ' +if (rank==0 .and. .not. BS_opt_for) print '(a70)', & + 'Not using forcing ' +if (rank==0 .and. BS_opt_for) print '(a70)', & + 'Using forcing ' +if (rank==0 .and. .not. BS_opt_hum) print '(a70)', & + 'Not using human-induced flows ' +if (rank==0 .and. BS_opt_hum) print '(a70)', & + 'Using human-induced flows ' +if (rank==0 .and. IS_opt_routing==1) print '(a70)', & + 'Routing with matrix-based Muskingum method ' +if (rank==0 .and. IS_opt_routing==2) print '(a70)', & + 'Routing with traditional Muskingum method ' +if (rank==0 .and. IS_opt_routing==3) print '(a70)', & + 'Routing with matrix-based Muskingum method using transboundary matrix ' +if (rank==0 .and. IS_opt_run==1) print '(a70)', & + 'RAPID mode: computing flowrates ' +if (rank==0 .and. IS_opt_run==2 .and. IS_opt_phi==1) print '(a70)', & + 'RAPID mode: optimizing parameters, using phi1 ' +if (rank==0 .and. IS_opt_run==2 .and. IS_opt_phi==2) print '(a70)', & + 'RAPID mode: optimizing parameters, using phi2 ' +if (rank==0) print '(a10,a60)', & + 'Using :', Vlat_file +if (rank==0 .and. IS_opt_run==1) print '(a10,a60)', & + 'Using :',k_file +if (rank==0 .and. IS_opt_run==1) print '(a10,a60)', & + 'Using :',x_file +if (rank==0 .and. IS_opt_run==2) print '(a10,a60)', & + 'Using :',kfac_file +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + +!------------------------------------------------------------------------------- +!Calculate helpful arrays !--LPR: hash-table used to increase efficiency------- +!------------------------------------------------------------------------------- +call rapid_arrays +!print *,'!!!LPR after rapid_arrays' + +!------------------------------------------------------------------------------- +!Calculate Network matrix +!------------------------------------------------------------------------------- +call rapid_net_mat +!print *,'!!!LPR after rapid_net_mat' + +!------------------------------------------------------------------------------- +!Breaks connections in Network matrix +!------------------------------------------------------------------------------- +if (BS_opt_for .or. BS_opt_dam) call rapid_net_mat_brk + +!------------------------------------------------------------------------------- +!calculates or set initial flows and volumes +!------------------------------------------------------------------------------- +if (.not. BS_opt_Qinit) then +call VecSet(ZV_QoutinitM,ZS_Qout0,ierr) +end if + +if (BS_opt_Qinit) then +print *, 'LPR: RAPID reading its own initialization file ......' +open(30,file=Qinit_file,status='old') +read(30,*) ZV_read_riv_tot +close(30) +call VecSetValues(ZV_QoutinitM,IS_riv_bas,IV_riv_loc1, & + ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr) + !here we use the output of a simulation as the intitial + !flow rates. The simulation has to be made on the entire + !domain, the initial value is taken only for the considered + !basin thanks to the vector IV_riv_index +call VecAssemblyBegin(ZV_QoutinitM,ierr) +call VecAssemblyEnd(ZV_QoutinitM,ierr) +end if + +call VecSet(ZV_VinitM,ZS_V0,ierr) +!Set initial volumes for Main procedure + +!------------------------------------------------------------------------------- +!Initialize default values for ZV_QoutRabsmin, ZV_QoutRabsmax and ZV_babsmax +!------------------------------------------------------------------------------- +if (BS_opt_influence) then +call VecSet(ZV_babsmax ,ZS_one*0 ,ierr) +call VecSet(ZV_QoutRabsmin,ZS_one*999999999,ierr) +call VecSet(ZV_QoutRabsmax,ZS_one*0 ,ierr) +end if + + +!******************************************************************************* +!Initialization procedure for OPTION 1 +!******************************************************************************* +if (IS_opt_run==1) then + +!------------------------------------------------------------------------------- +!copy main initial values into routing initial values +!------------------------------------------------------------------------------- +call VecCopy(ZV_QoutinitM,ZV_QoutinitR,ierr) +call VecCopy(ZV_VinitM,ZV_VinitR,ierr) + +!------------------------------------------------------------------------------- +!Read/set k and x +!------------------------------------------------------------------------------- +open(20,file=k_file,status='old') +read(20,*) ZV_read_riv_tot +call VecSetValues(ZV_k,IS_riv_bas,IV_riv_loc1, & + ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr) +call VecAssemblyBegin(ZV_k,ierr) +call VecAssemblyEnd(ZV_k,ierr) +close(20) +!get values for k in a file and create the corresponding ZV_k vector + +open(21,file=x_file,status='old') +read(21,*) ZV_read_riv_tot +call VecSetValues(ZV_x,IS_riv_bas,IV_riv_loc1, & + ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr) +call VecAssemblyBegin(ZV_x,ierr) +call VecAssemblyEnd(ZV_x,ierr) +close(21) +!get values for x in a file and create the corresponding ZV_x vector + +!------------------------------------------------------------------------------- +!Compute routing parameters and linear system matrix +!------------------------------------------------------------------------------- +call rapid_routing_param(ZV_k,ZV_x,ZV_C1,ZV_C2,ZV_C3,ZM_A) +!calculate Muskingum parameters and matrix ZM_A + +call KSPSetOperators(ksp,ZM_A,ZM_A,DIFFERENT_NONZERO_PATTERN,ierr) +call KSPSetType(ksp,KSPRICHARDSON,ierr) !default=richardson +!call KSPSetInitialGuessNonZero(ksp,PETSC_TRUE,ierr) +!call KSPSetInitialGuessKnoll(ksp,PETSC_TRUE,ierr) +call KSPSetFromOptions(ksp,ierr) !if runtime options +if (IS_opt_routing==3) call KSPSetType(ksp,KSPPREONLY,ierr)!default=preonly + +!------------------------------------------------------------------------------- +!End of initialization procedure for OPTION 1 +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!Initialization procedure for OPTION 2 +!******************************************************************************* +if (IS_opt_run==2) then +#ifndef NO_TAO + +!------------------------------------------------------------------------------- +!Create observation matrix +!------------------------------------------------------------------------------- +call rapid_obs_mat +!Create observation matrix + +!------------------------------------------------------------------------------- +!copy main initial values into optimization initial values +!------------------------------------------------------------------------------- +call VecCopy(ZV_QoutinitM,ZV_QoutinitO,ierr) +!copy initial main variables into initial optimization variables + +!------------------------------------------------------------------------------- +!Read/set kfac, xfac and Qobsbarrec +!------------------------------------------------------------------------------- +open(22,file=kfac_file,status='old') +read(22,*) ZV_read_riv_tot +close(22) +call VecSetValues(ZV_kfac,IS_riv_bas,IV_riv_loc1, & + ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr) + !only looking at basin, doesn't have to be whole domain here +call VecAssemblyBegin(ZV_kfac,ierr) +call VecAssemblyEnd(ZV_kfac,ierr) +!reads kfac and assigns to ZV_kfac + +if (IS_opt_phi==2) then +open(35,file=Qobsbarrec_file,status='old') +read(35,*) ZV_read_obs_tot +close(35) +call VecSetValues(ZV_Qobsbarrec,IS_obs_bas,IV_obs_loc1, & + ZV_read_obs_tot(IV_obs_index),INSERT_VALUES,ierr) + !here we only look at the observations within the basin + !studied +call VecAssemblyBegin(ZV_Qobsbarrec,ierr) +call VecAssemblyEnd(ZV_Qobsbarrec,ierr) +!reads Qobsbarrec and assigns to ZV_Qobsbarrec +end if + +!------------------------------------------------------------------------------- +!Set pnorm, pfac and p +!------------------------------------------------------------------------------- +call VecSetValues(ZV_pnorm,IS_one,IS_one-1,ZS_knorm_init,INSERT_VALUES,ierr) +call VecSetValues(ZV_pnorm,IS_one,IS_one,ZS_xnorm_init,INSERT_VALUES,ierr) +call VecAssemblyBegin(ZV_pnorm,ierr) +call VecAssemblyEnd(ZV_pnorm,ierr) +!set pnorm to pnorm=(knorm,xnorm) + +!call VecSetValues(ZV_pfac,IS_one,IS_one-1,ZS_kfac,INSERT_VALUES,ierr) +!call VecSetValues(ZV_pfac,IS_one,IS_one,ZS_xfac,INSERT_VALUES,ierr) +!call VecAssemblyBegin(ZV_pnorm,ierr) +!call VecAssemblyEnd(ZV_pnorm,ierr) +!!set pfac to pfac=(kfac,xfac) + +!call VecPointWiseMult(ZV_p,ZV_pfac,ZV_pnorm,ierr) +!!set p to p=pfac.*pnorm + +!------------------------------------------------------------------------------- +!End of OPTION 2 +!------------------------------------------------------------------------------- +#endif +end if + + +!******************************************************************************* +!End of subroutine +!******************************************************************************* +end subroutine rapid_init diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 new file mode 100644 index 00000000..b0d78638 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 @@ -0,0 +1,299 @@ +!******************************************************************************* +!Subroutine - rapid_main +!******************************************************************************* +subroutine rapid_main(ITIME,runoff,ii,jj,Qout_nc_file) +!Purpose: +!Allows to route water through a river network, and to estimate optimal +!parameters using the inverse method +!Author: +!Cedric H. David, 2008-2015. +!Peirong Lin, modified starting from June 2014 to satisfy WRF-Hydro needs + +use netcdf + +!---LPR: added variable use from module Wrapper--------------------- +use hrldas_RAPID_wrapper, only: cnt_rapid_run,rapid_runoff_to_inflow + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + namelist_file, & + Vlat_file,Qfor_file,Qhum_file, & + Qout_file, & + IS_M,JS_M,JS_RpM,IS_RpM,IS_RpF,IS_RpH, & + ZS_TauR, & + ZV_pnorm, & + ZV_C1,ZV_C2,ZV_C3, & + ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam, & + ZV_Vlat, & + ZV_QoutR,ZV_QoutinitR,ZV_QoutbarR, & + ZV_VR,ZV_VinitR,ZV_VbarR, & + ZS_phi, & + ierr,rank,stage,temp_char,temp_char2, & + ZS_one, & + IS_riv_tot,IS_riv_bas,IS_for_bas,IS_dam_bas,IS_hum_bas, & + ZS_time1,ZS_time2,ZS_time3, & + IV_nc_start,IV_nc_count,IV_nc_count2, & + BS_opt_for,BS_opt_hum,BS_opt_dam,IS_opt_run + +#ifndef NO_TAO +use rapid_var, only : & + tao +#endif + +implicit none +external rapid_phiroutine +!because the subroutine is called by a function + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + +#ifndef NO_TAO +#include "finclude/taosolver.h" +!TAO solver +#endif + +integer ITIME +integer ii,jj +real,dimension(ii,jj) :: runoff +real,dimension(ii,jj) :: ZM_runoff +character(len=100) :: Qout_nc_file !---LPR: RAPID output file name-- + +ZM_runoff = runoff !---LPR: pass runoff calculated by WRF-Hydro to RAPID------ +Qout_file = Qout_nc_file !---LPR: new output filename defined by Wrapper------- + +!******************************************************************************* +!Initialize +!******************************************************************************* +!namelist_file='./rapid_namelist' !---LPR: initialize done in Wrapper---------- +!call rapid_init + +!******************************************************************************* +!OPTION 1 - use to calculate flows and volumes and generate output data +!******************************************************************************* +if (IS_opt_run==1) then + +!------------------------------------------------------------------------------- +!Create Qout file +!------------------------------------------------------------------------------- +call rapid_create_Qout_file(Qout_file) + +!------------------------------------------------------------------------------- +!Open files +!------------------------------------------------------------------------------- +call rapid_open_Qout_file(Qout_file) +!---LPR: IMPORTANT uncomment this sentence because runoff is NOT read from Vlat +!call rapid_open_Vlat_file(Vlat_file) +!---LPR: IMPORTANT uncomment this sentence because runoff is NOT read from Vlat +if (BS_opt_for) call rapid_open_Qfor_file(Qfor_file) +if (BS_opt_hum) call rapid_open_Qhum_file(Qhum_file) + +!------------------------------------------------------------------------------- +!Make sure the vectors potentially used for inflow to dams are initially null +!------------------------------------------------------------------------------- +call VecSet(ZV_Qext,0*ZS_one,ierr) !Qext=0 +call VecSet(ZV_QoutbarR,0*ZS_one,ierr) !QoutbarR=0 +!This should be done by PETSc but just to be safe + +!------------------------------------------------------------------------------- +!Set initial value of Qext from Qout_dam0 +!------------------------------------------------------------------------------- +if (BS_opt_dam .and. IS_dam_bas>0) then + call rapid_set_Qext0 !Qext from Qout_dam0 + !call VecView(ZV_Qext,PETSC_VIEWER_STDOUT_WORLD,ierr) +end if + +!------------------------------------------------------------------------------- +!Read, compute and write +!------------------------------------------------------------------------------- +!---LPR: IMPORTANT uncomment the next two->defined in RAPID initialization stage +!call PetscLogStageRegister('Read Comp Write',stage,ierr) +!call PetscLogStagePush(stage,ierr) + +ZS_time3=0 + +IV_nc_start=(/1,1/) +IV_nc_count=(/IS_riv_tot,1/) +IV_nc_count2=(/IS_riv_bas,1/) + +!---LPR uncomment this because loop is done within WRF-Hydro call-------------- +!do JS_M=1,IS_M +!do JS_RpM=1,IS_RpM + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Read/set surface and subsurface volumes +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!call rapid_read_Vlat_file !---LPR: do not read Vlat file, but get Vlat from WRF-Hydro + +!---LPR: IMPORTANT new subroutine added in the Wrapper----------------- +call rapid_runoff_to_inflow(ZM_runoff,ZV_Vlat,cnt_rapid_run) +!---LPR: IMPORTANT new subroutine added in the Wrapper----------------- + +call VecCopy(ZV_Vlat,ZV_Qlat,ierr) !Qlat=Vlat +call VecScale(ZV_Qlat,1/ZS_TauR,ierr) !Qlat=Qlat/TauR +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Read/set upstream forcing +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +if (BS_opt_for .and. IS_for_bas>0 & + .and. mod((JS_M-1)*IS_RpM+JS_RpM,IS_RpF)==1) then + +call rapid_read_Qfor_file + +end if + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Run dam model based on previous values of QoutbarR and Qext to get Qdam +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +if (BS_opt_dam .and. IS_dam_bas>0) then + +call rapid_get_Qdam + +end if + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Read/set human induced flows +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +if (BS_opt_hum .and. IS_hum_bas>0 & + .and. mod((JS_M-1)*IS_RpM+JS_RpM,IS_RpH)==1) then + +call rapid_read_Qhum_file + +end if + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!calculation of Qext +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call VecCopy(ZV_Qlat,ZV_Qext,ierr) !Qext=Qlat +if (BS_opt_for) call VecAXPY(ZV_Qext,ZS_one,ZV_Qfor,ierr) !Qext=Qext+1*Qfor +if (BS_opt_dam) call VecAXPY(ZV_Qext,ZS_one,ZV_Qdam,ierr) !Qext=Qext+1*Qdam +if (BS_opt_hum) call VecAXPY(ZV_Qext,ZS_one,ZV_Qhum,ierr) !Qext=Qext+1*Qhum + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Routing procedure +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call PetscTime(ZS_time1,ierr) +call rapid_routing(ZV_C1,ZV_C2,ZV_C3,ZV_Qext, & + ZV_QoutinitR,ZV_VinitR, & + ZV_QoutR,ZV_QoutbarR,ZV_VR,ZV_VbarR) +call PetscTime(ZS_time2,ierr) +ZS_time3=ZS_time3+ZS_time2-ZS_time1 + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Update variables +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call VecCopy(ZV_QoutR,ZV_QoutinitR,ierr) +call VecCopy(ZV_VR,ZV_VinitR,ierr) + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!write outputs +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call rapid_write_Qout_file + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Update netCDF location +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +if (rank==0) IV_nc_start(2)=IV_nc_start(2)+1 +!do not comment out if writing directly from the routing subroutine + +!end do +!end do !---LPR uncomment because loop if done in WRF-Hydro + +!------------------------------------------------------------------------------- +!Performance statistics +!------------------------------------------------------------------------------- +call PetscPrintf(PETSC_COMM_WORLD,'Cumulative time for routing only' & + //char(10),ierr) +write(temp_char ,'(i10)') rank +write(temp_char2,'(f10.2)') ZS_time3 +call PetscSynchronizedPrintf(PETSC_COMM_WORLD,'Rank :'//temp_char //', '// & + 'Time :'//temp_char2// & + char(10),ierr) +call PetscSynchronizedFlush(PETSC_COMM_WORLD,ierr) +!---LPR: uncomment sentence below to avoid potential PETSC Stack Empty error----- +!call PetscLogStagePop(ierr) +call PetscPrintf(PETSC_COMM_WORLD,'Output data created'//char(10),ierr) + +!------------------------------------------------------------------------------- +!Close files +!------------------------------------------------------------------------------- +call rapid_close_Qout_file +!---LPR: IMPORTANT uncomment setence below------- +!call rapid_close_Vlat_file +if (BS_opt_for) call rapid_close_Qfor_file(Qfor_file) +if (BS_opt_hum) call rapid_close_Qhum_file(Qhum_file) + + +!------------------------------------------------------------------------------- +!End of OPTION 1 +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!OPTION 2 - Optimization +!******************************************************************************* +if (IS_opt_run==2) then +#ifndef NO_TAO + +!------------------------------------------------------------------------------- +!Only one computation of phi - For testing purposes only +!------------------------------------------------------------------------------- +!call PetscLogStageRegister('One comp of phi',stage,ierr) +!call PetscLogStagePush(stage,ierr) +!!do JS_M=1,5 +!call rapid_phiroutine(tao,ZV_pnorm,ZS_phi,PETSC_NULL,ierr) +!!enddo +!call PetscLogStagePop(ierr) + +!------------------------------------------------------------------------------- +!Optimization procedure +!------------------------------------------------------------------------------- +call PetscLogStageRegister('Optimization ',stage,ierr) +call PetscLogStagePush(stage,ierr) +call TaoSetObjectiveRoutine(tao,rapid_phiroutine,PETSC_NULL_OBJECT,ierr) +call TaoSetInitialVector(tao,ZV_pnorm,ierr) +call TaoSetTolerances(tao,1.0d-4,1.0d-4,PETSC_NULL_OBJECT,PETSC_NULL_OBJECT, & + PETSC_NULL_OBJECT,ierr) +call TaoSolve(tao,ierr) + +call TaoView(tao,PETSC_VIEWER_STDOUT_WORLD,ierr) +call PetscPrintf(PETSC_COMM_WORLD,'final normalized p=(k,x)'//char(10),ierr) +call VecView(ZV_pnorm,PETSC_VIEWER_STDOUT_WORLD,ierr) +call PetscLogStagePop(ierr) + +!------------------------------------------------------------------------------- +!End of OPTION 2 +!------------------------------------------------------------------------------- +#else +if (rank==0) print '(a70)', & + 'ERROR: The optimization mode requires RAPID to be compiled with TAO ' +#endif +end if + + +!******************************************************************************* +!Finalize +!******************************************************************************* +!call rapid_final !---LPR: no need to finalize, write RAPID output each time step + +!******************************************************************************* +!End +!******************************************************************************* +end subroutine rapid_main diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_namelist b/wrfv2_fire/hydro/Rapid_routing/rapid_namelist new file mode 100644 index 00000000..fdc66821 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_namelist @@ -0,0 +1,109 @@ +&NL_namelist +!******************************************************************************* +!Runtime options +!******************************************************************************* +BS_opt_Qinit =.false. +!.false. --> no initialization .true. --> initialization + +BS_opt_forcing =.false. +!.false. --> no forcing .true. --> forcing + +IS_opt_routing =1 +!1 --> matrix-based Muskingum 2 --> traditional Muskingum + +IS_opt_run =1 +!1 --> regular run 2 --> parameter optimization + +IS_opt_phi =1 +!1 --> phi1 2 --> phi2 + +!******************************************************************************* +!Temporal information +!******************************************************************************* +ZS_TauM=252460800 +!315619200 !3600*24*3652days NASA-project !San-Gua 2004-2007 Case!3600*24*1460=126144000 +!3600*24*4527 +!ZS_TauM=26092800 !Texas 2013.12.03-2014.09.30 Case, lpr 2014-03-12 +!3600*24*302 +!ZS_dtM=86400 + +!modified on 2014/04/03 +!3600*24=86400 +ZS_dtM=86400 +!3600*3=10800 + + +ZS_TauO=315532800 !15724800 +!3600*24*182=15724800 +ZS_dtO=86400 +!ZS_dtO=10800 +!3600*24=86400 + +ZS_TauR=10800 +!3600*3=10800 +ZS_dtR=900 + +!******************************************************************************* +!Domain in which input data is available +!******************************************************************************* +IS_reachtot =68143 !for Texas; 5175 for San-Gua +modcou_connect_file='./forecast_input_tx/rapid_connect_Reg12.csv' +IS_max_up =4 +m3_nc_file ='./forecast_input_tx/m3_riv_2000_2007_NoahMP_Texas.nc' + +!******************************************************************************* +!Domain in which model runs +!******************************************************************************* +IS_reachbas =68143 !5175 +basin_id_file ='./forecast_input_tx/basin_id_Reg12_hydroseq.csv' + +!******************************************************************************* +!Initialization +!******************************************************************************* +Qinit_file ='' + +!******************************************************************************* +!Available forcing data +!******************************************************************************* +!IS_forcingtot =3 +!forcingtot_id_file ='./input_San_Guad/forcingtot_id_dam_springs.csv' +!Qfor_file ='./input_San_Guad/Qfor_dam_springs_2004_2007.csv' + +!******************************************************************************* +!Forcing data used as model runs +!******************************************************************************* +!IS_forcinguse =3 +!forcinguse_id_file ='./input_San_Guad/forcinguse_id_dam_springs.csv' + +!******************************************************************************* +!Regular model run +!******************************************************************************* +k_file ='./forecast_input_tx/k_Reg12_Noah_MP_pb0.csv' +x_file ='./forecast_input_tx/x_Reg12_Noah_MP_pb0.csv' +Qout_nc_file ='./output_forecast_tx/Texas.2000.2007.NoahMP.Calibed.nc' + +!******************************************************************************* +!Optimization +!******************************************************************************* +!ZS_phifac =0.001 +!------------------------------------------------------------------------------ +!Routing parameters +!------------------------------------------------------------------------------ +!kfac_file ='./input_tx_noahmp_00_12_opt/kfac_TX_1km_hour.csv' +!xfac_file ='' +!ZS_knorm_init =4 +!ZS_xnorm_init =1 +!------------------------------------------------------------------------------ +!Gage observations +!------------------------------------------------------------------------------ +!IS_gagetot =248 +!gagetot_id_file ='./input_tx_noahmp_00_12_opt/gage_id_Reg12_2000_2007_full.csv' +!Qobs_file ='./input_tx_noahmp_00_12_opt/Qobs_Reg12_2000_2007_full.csv' +!Qobsbarrec_file ='' +!IS_gageuse =248 +!gageuse_id_file ='./input_tx_noahmp_00_12_opt/gage_id_Reg12_2000_2007_full.csv' +!IS_strt_opt =1 +!******************************************************************************* +!End name list +!******************************************************************************* +/ diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90 new file mode 100644 index 00000000..61a9ec19 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90 @@ -0,0 +1,331 @@ +!******************************************************************************* +!Subroutine - rapid_net_mat +!******************************************************************************* +subroutine rapid_net_mat + +!Purpose: +!This creates a sparse network matrix. "1" is recorded at Net(i,j) if the reach +!in column j flows into the reach in line i. If some connections are missing +!between the subbasin and the entire domain, gives warnings. +!A transboundary matrix is also created whose elements in the diagonal blocks +!are all null and the elements in the off-diagonal blocks are equal to those of +!the network matrix. +!Author: +!Cedric H. David, 2008-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_tot,IS_riv_bas, & + JS_riv_tot,JS_riv_bas,JS_riv_bas2, & + IV_riv_bas_id,IV_riv_index,ZM_hsh_bas, & + ZM_Net,ZM_A,ZM_T,ZM_TC1,BS_logical,IV_riv_tot_id, & + IV_down,IV_nbup,IM_up,JS_up,IM_index_up, & + ierr,rank,ZS_val, & + IS_one,ZS_one,temp_char,IV_nz,IV_dnz,IV_onz, & + IS_ownfirst,IS_ownlast,IS_opt_routing + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + + +!******************************************************************************* +!Prepare for matrix preallocation +!******************************************************************************* +IS_ownfirst=0 +IS_ownlast=0 +do JS_riv_bas=1,IS_riv_bas + IV_nz(JS_riv_bas)=0 + IV_dnz(JS_riv_bas)=0 + IV_onz(JS_riv_bas)=0 +end do +!Initialize to zero + +call MatGetOwnershipRange(ZM_Net,IS_ownfirst,IS_ownlast,ierr) + +do JS_riv_bas2=1,IS_riv_bas +do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2)) +if (IM_index_up(JS_riv_bas2,JS_up)/=0) then + + JS_riv_bas=IM_index_up(JS_riv_bas2,JS_up) + !Here JS_riv_bas is determined upstream of JS_riv_bas2 + !both IS_riv_bas2 and IS_riv_bas are used here because the location + !of nonzeros depends on row and column in an parallel matrix + + IV_nz(JS_riv_bas2)=IV_nz(JS_riv_bas2)+1 + !The size of IV_nz is IS_riv_bas, IV_nz is the same across computing cores + + if ((JS_riv_bas >=IS_ownfirst+1 .and. JS_riv_bas< IS_ownlast+1) .and. & + (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then + IV_dnz(JS_riv_bas2)=IV_dnz(JS_riv_bas2)+1 + end if + if ((JS_riv_bas < IS_ownfirst+1 .or. JS_riv_bas >=IS_ownlast+1) .and. & + (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then + IV_onz(JS_riv_bas2)=IV_onz(JS_riv_bas2)+1 + end if + !The size of IV_dnz and of IV_onz is IS_riv_bas. The values of IV_dnz and + !IV_onz are not the same across computing cores. For each core, the + !only the values located in the range (IS_ownfirst+1:IS_ownlast) are + !correct but only these are used in the preallocation below. + +end if +end do +end do + +!print *, 'rank', rank, 'IV_nz(:)' , IV_nz(:) +!print *, 'rank', rank, 'IV_dnz(:)', IV_dnz(:) +!print *, 'rank', rank, 'IV_onz(:)', IV_onz(:) + + +!******************************************************************************* +!Matrix preallocation +!******************************************************************************* +!call MatSeqAIJSetPreallocation(ZM_Net,3*IS_one,PETSC_NULL_INTEGER,ierr) +!call MatMPIAIJSetPreallocation(ZM_Net,3*IS_one,PETSC_NULL_INTEGER,2*IS_one, & +! PETSC_NULL_INTEGER,ierr) +!call MatSeqAIJSetPreallocation(ZM_A,4*IS_one,PETSC_NULL_INTEGER,ierr) +!call MatMPIAIJSetPreallocation(ZM_A,4*IS_one,PETSC_NULL_INTEGER,2*IS_one, & +! PETSC_NULL_INTEGER,ierr) +!call MatSeqAIJSetPreallocation(ZM_T,4*IS_one,PETSC_NULL_INTEGER,ierr) +!call MatMPIAIJSetPreallocation(ZM_T,4*IS_one,PETSC_NULL_INTEGER,2*IS_one, & +! PETSC_NULL_INTEGER,ierr) +!call MatSeqAIJSetPreallocation(ZM_TC1,4*IS_one,PETSC_NULL_INTEGER,ierr) +!call MatMPIAIJSetPreallocation(ZM_TC1,4*IS_one,PETSC_NULL_INTEGER,2*IS_one, & +! PETSC_NULL_INTEGER,ierr) +!Very basic preallocation assuming no more than 3 upstream elements anywhere +!Not used here because proper preallocation is done below + +call MatSeqAIJSetPreallocation(ZM_Net,PETSC_NULL_INTEGER,IV_nz,ierr) +call MatMPIAIJSetPreallocation(ZM_Net, & + PETSC_NULL_INTEGER, & + IV_dnz(IS_ownfirst+1:IS_ownlast), & + PETSC_NULL_INTEGER, & + IV_onz(IS_ownfirst+1:IS_ownlast),ierr) +call MatSeqAIJSetPreallocation(ZM_A,PETSC_NULL_INTEGER,IV_nz+1,ierr) +call MatMPIAIJSetPreallocation(ZM_A, & + PETSC_NULL_INTEGER, & + IV_dnz(IS_ownfirst+1:IS_ownlast)+1, & + PETSC_NULL_INTEGER, & + IV_onz(IS_ownfirst+1:IS_ownlast),ierr) +call MatSeqAIJSetPreallocation(ZM_T,PETSC_NULL_INTEGER,0*IV_nz,ierr) +call MatMPIAIJSetPreallocation(ZM_T, & + PETSC_NULL_INTEGER, & + 0*IV_dnz(IS_ownfirst+1:IS_ownlast), & + PETSC_NULL_INTEGER, & + IV_onz(IS_ownfirst+1:IS_ownlast),ierr) +call MatSeqAIJSetPreallocation(ZM_TC1,PETSC_NULL_INTEGER,0*IV_nz,ierr) +call MatMPIAIJSetPreallocation(ZM_TC1, & + PETSC_NULL_INTEGER, & + 0*IV_dnz(IS_ownfirst+1:IS_ownlast), & + PETSC_NULL_INTEGER, & + IV_onz(IS_ownfirst+1:IS_ownlast),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'Network matrix preallocated'//char(10),ierr) + + +!******************************************************************************* +!Creates network matrix +!******************************************************************************* +if (rank==0) then +!only first processor sets values + +do JS_riv_bas2=1,IS_riv_bas +do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2)) +if (IM_index_up(JS_riv_bas2,JS_up)/=0) then + + JS_riv_bas=IM_index_up(JS_riv_bas2,JS_up) + !Here JS_riv_bas is determined upstream of JS_riv_bas2 + !both IS_riv_bas2 and IS_riv_bas are used here because the location + !of nonzeros depends on row and column in a parallel matrix + + call MatSetValues(ZM_Net,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !Actual values used for ZM_Net + + call MatSetValues(ZM_A ,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + 0*ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !zeros (instead of -C1is) are used here on the off-diagonal of ZM_A because + !C1is are not yet computed, because ZM_A will later be populated based on + !ZM_Net, and because ZM_Net may be later modified for forcing or dams. + !Also when running RAPID in optimization mode, it is necessary to recreate + !ZM_A from scratch every time the parameters C1is are updated + +end if +end do +call MatSetValues(ZM_A ,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas2-1, & + 0*ZS_one,INSERT_VALUES,ierr) +CHKERRQ(ierr) +!zeros (instead of ones) are used on the main diagonal of ZM_A because ZM_A will +!be diagonally scaled by ZV_C1 before the diagonal is populated by ones. +end do + +end if + +call MatAssemblyBegin(ZM_Net,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_Net,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyBegin(ZM_A ,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_A ,MAT_FINAL_ASSEMBLY,ierr) +!sparse matrices need be assembled once their elements have been filled +call PetscPrintf(PETSC_COMM_WORLD,'Network matrix created'//char(10),ierr) + + +!******************************************************************************* +!Creates transboundary matrix +!******************************************************************************* +if (IS_opt_routing==3) then + +do JS_riv_bas2=1,IS_riv_bas +do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2)) +if (IM_index_up(JS_riv_bas2,JS_up)/=0) then + + JS_riv_bas=IM_index_up(JS_riv_bas2,JS_up) + !Here JS_riv_bas is determined upstream of JS_riv_bas2 + !both IS_riv_bas2 and IS_riv_bas are used here because the location + !of nonzeros depends on row and column in a parallel matrix + + if ((JS_riv_bas < IS_ownfirst+1 .or. JS_riv_bas >=IS_ownlast+1) .and. & + (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then + + call MatSetValues(ZM_T,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !Actual values (ones) used for ZM_T + + call MatSetValues(ZM_TC1,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + 0*ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !zeros (instead of C1is) are used here everywhere in ZM_TC1 because + !C1is are not yet computed, because ZM_TC1 will later be populated based on + !ZM_T, and because ZM_T may be later modified for forcing or dams. + !Also when running RAPID in optimization mode, it is necessary to recreate + !ZM_TC1 from scratch every time the parameters C1is are updated + + end if + +end if +end do +end do + +call MatAssemblyBegin(ZM_T,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_T,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyBegin(ZM_TC1,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_TC1,MAT_FINAL_ASSEMBLY,ierr) +call PetscPrintf(PETSC_COMM_WORLD,'Transboundary matrix created'//char(10),ierr) + +end if + + +!******************************************************************************* +!Checks for missing connections and gives warning +!******************************************************************************* +do JS_riv_tot=1,IS_riv_tot + ZS_val=-999 + call MatGetValues(ZM_hsh_bas, & + IS_one,rank, & + IS_one,IV_riv_tot_id(JS_riv_tot)-1, & + ZS_val,ierr) + CHKERRQ(ierr) + JS_riv_bas2=int(ZS_val) + if (JS_riv_bas2>0) then + !print *, 'Reach ID', IV_riv_tot_id(JS_riv_tot), 'is in basin' + else + !print *, 'Reach ID', IV_riv_tot_id(JS_riv_tot), 'is not in basin' + +!------------------------------------------------------------------------------- +!Looking for missing upstream connections +!------------------------------------------------------------------------------- +ZS_val=-999 +call MatGetValues(ZM_hsh_bas, & + IS_one,rank, & + IS_one,IV_down(JS_riv_tot)-1, & + ZS_val,ierr) +CHKERRQ(ierr) +JS_riv_bas=int(ZS_val) +if(JS_riv_bas>0) then + write(temp_char,'(i10)') IV_riv_tot_id(JS_riv_tot) + call PetscPrintf(PETSC_COMM_WORLD, & + 'WARNING: reach ID' // temp_char,ierr) + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas) + call PetscPrintf(PETSC_COMM_WORLD, & + ' should be connected upstream of reach ID' & + // temp_char // char(10),ierr) + call PetscPrintf(PETSC_COMM_WORLD, & + ' Make sure upstream forcing is available' & + // char(10),ierr) +end if +!------------------------------------------------------------------------------- +!Looking for missing upstream connections +!------------------------------------------------------------------------------- +do JS_up=1,IV_nbup(JS_riv_tot) +ZS_val=-999 +call MatGetValues(ZM_hsh_bas, & + IS_one,rank, & + IS_one,IM_up(JS_riv_tot,JS_up)-1, & + ZS_val,ierr) +CHKERRQ(ierr) +JS_riv_bas=int(ZS_val) +if (JS_riv_bas>0) then + write(temp_char,'(i10)') IV_riv_tot_id(JS_riv_tot) + call PetscPrintf(PETSC_COMM_WORLD, & + 'WARNING: reach ID' // temp_char,ierr) + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas) + call PetscPrintf(PETSC_COMM_WORLD, & + ' should be connected downstream of reach ID' & + // temp_char // char(10),ierr) +end if +end do +!------------------------------------------------------------------------------- +!Done looking +!------------------------------------------------------------------------------- + + end if +end do +call PetscPrintf(PETSC_COMM_WORLD,'Checked for missing connections between '// & + 'basin studied and rest of domain'//char(10),ierr) + + +!******************************************************************************* +!Display matrices on stdout +!******************************************************************************* +!call PetscPrintf(PETSC_COMM_WORLD,'ZM_Net'//char(10),ierr) +!call MatView(ZM_Net,PETSC_VIEWER_STDOUT_WORLD,ierr) +! +!call PetscPrintf(PETSC_COMM_WORLD,'ZM_A'//char(10),ierr) +!call MatView(ZM_A,PETSC_VIEWER_STDOUT_WORLD,ierr) +! +!if (IS_opt_routing==3) then +! call PetscPrintf(PETSC_COMM_WORLD,'ZM_T'//char(10),ierr) +! call MatView(ZM_T,PETSC_VIEWER_STDOUT_WORLD,ierr) +! +! call PetscPrintf(PETSC_COMM_WORLD,'ZM_TC1'//char(10),ierr) +! call MatView(ZM_TC1,PETSC_VIEWER_STDOUT_WORLD,ierr) +!end if + + +!******************************************************************************* +!End +!******************************************************************************* +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + + +end subroutine rapid_net_mat diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90 new file mode 100644 index 00000000..2e3b2719 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90 @@ -0,0 +1,286 @@ +!******************************************************************************* +!Subroutine - rapid_net_mat_brk +!******************************************************************************* +subroutine rapid_net_mat_brk + +!Purpose: +!This subroutine modifies the network and transboundary matrices based on a list +!of river IDs. +!The connectivity is broken between each given river ID and its downstream +!river. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_bas,JS_riv_bas,JS_riv_bas2, & + IV_riv_bas_id,IV_riv_index, & + ZM_Net,ZM_T,IV_down,IV_nbup,JS_up,IM_index_up, & + IS_for_bas,JS_for_bas,IV_for_bas_id, & + IS_dam_bas,JS_dam_bas,IV_dam_bas_id, & + ierr,rank, & + IS_one,ZS_one,temp_char, & + IS_ownfirst,IS_ownlast, & + BS_opt_for,BS_opt_dam,IS_opt_routing + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + + +!******************************************************************************* +!If forcing is used +!******************************************************************************* +if (BS_opt_for) then + +!------------------------------------------------------------------------------- +!Breaks Net matrix connectivity in case forcing used is inside basin studied +!------------------------------------------------------------------------------- +if (IS_for_bas>0) then +call PetscPrintf(PETSC_COMM_WORLD,'Modifying network matrix'//char(10),ierr) +end if + +if (rank==0) then +!only first processor sets values +do JS_for_bas=1,IS_for_bas + do JS_riv_bas=1,IS_riv_bas + if (IV_for_bas_id(JS_for_bas)==IV_riv_bas_id(JS_riv_bas)) then + + do JS_riv_bas2=1,IS_riv_bas + if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then + !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas + !and the connection between both needs be broken + + call MatSetValues(ZM_Net,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + 0*ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !Breaks connection for matrix-based Muskingum method + + do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2)) + if (IM_index_up(JS_riv_bas2,JS_up)==JS_riv_bas) then + IM_index_up(JS_riv_bas2,JS_up)=0 + end if + end do + !Breaks connection for traditional Muskingum method + + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas) + call PetscPrintf(PETSC_COMM_WORLD, & + ' connection broken downstream of reach ID' & + // temp_char,ierr) + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas2) + call PetscPrintf(PETSC_COMM_WORLD, & + ' forcing data will be used for reach ID' & + // temp_char // char(10),ierr) + !Writes information on connection that was just broken in stdout + + end if + end do + + end if + end do +end do +end if +call MatAssemblyBegin(ZM_Net,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_Net,MAT_FINAL_ASSEMBLY,ierr) +!!sparse matrices need be assembled once their elements have been filled +call PetscPrintf(PETSC_COMM_WORLD,'Network matrix modified for forcing'// & + char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + +!------------------------------------------------------------------------------- +!Breaks T matrix connectivity in case forcing is used inside basin studied +!------------------------------------------------------------------------------- +if (IS_opt_routing==3) then + +if (IS_for_bas>0) then +call PetscPrintf(PETSC_COMM_WORLD,'Modifying transboundary matrix'// & + char(10),ierr) +end if + +do JS_for_bas=1,IS_for_bas + do JS_riv_bas=1,IS_riv_bas + if (IV_for_bas_id(JS_for_bas)==IV_riv_bas_id(JS_riv_bas)) then + + do JS_riv_bas2=1,IS_riv_bas + if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then + !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas + !and the connection between both needs be broken + +if ((JS_riv_bas < IS_ownfirst+1 .or. JS_riv_bas >=IS_ownlast+1) .and. & + (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then + + call MatSetValues(ZM_T,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + 0*ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !Breaks connection of transboundary matrix + +end if + + end if + end do + + end if + end do +end do +call MatAssemblyBegin(ZM_T,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_T,MAT_FINAL_ASSEMBLY,ierr) +!!sparse matrices need be assembled once their elements have been filled +call PetscPrintf(PETSC_COMM_WORLD,'Transboundary matrix modified for forcing'//& + char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + +end if + +!------------------------------------------------------------------------------- +!End if forcing is used +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!If dam model is used +!******************************************************************************* +if (BS_opt_dam) then + +!------------------------------------------------------------------------------- +!Breaks matrix connectivity in case dam model is used inside basin studied +!------------------------------------------------------------------------------- +if (IS_dam_bas>0) then +call PetscPrintf(PETSC_COMM_WORLD,'Modifying network matrix'//char(10),ierr) +end if + +if (rank==0) then +!only first processor sets values +do JS_dam_bas=1,IS_dam_bas + do JS_riv_bas=1,IS_riv_bas + if (IV_dam_bas_id(JS_dam_bas)==IV_riv_bas_id(JS_riv_bas)) then + + do JS_riv_bas2=1,IS_riv_bas + if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then + !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas + !and the connection between both needs be broken + + call MatSetValues(ZM_Net,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + 0*ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !Breaks connection for matrix-based Muskingum method + + do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2)) + if (IM_index_up(JS_riv_bas2,JS_up)==JS_riv_bas) then + IM_index_up(JS_riv_bas2,JS_up)=0 + end if + end do + !Breaks connection for traditional Muskingum method + + + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas) + call PetscPrintf(PETSC_COMM_WORLD, & + ' connection broken downstream of reach ID' & + // temp_char,ierr) + write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas2) + call PetscPrintf(PETSC_COMM_WORLD, & + ' dam data will be used for reach ID' & + // temp_char // char(10),ierr) + !Writes information on connection that was just broken in stdout + + end if + end do + + end if + end do +end do +end if +call MatAssemblyBegin(ZM_Net,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_Net,MAT_FINAL_ASSEMBLY,ierr) +!sparse matrices need be assembled once their elements have been filled +call PetscPrintf(PETSC_COMM_WORLD,'Network matrix modified for dams'// & + char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + +!------------------------------------------------------------------------------- +!Breaks T matrix connectivity in case dam model is used inside basin studied +!------------------------------------------------------------------------------- +if (IS_opt_routing==3) then + +if (IS_dam_bas>0) then +call PetscPrintf(PETSC_COMM_WORLD,'Modifying transboundary matrix'// & + char(10),ierr) +end if + +do JS_dam_bas=1,IS_dam_bas + do JS_riv_bas=1,IS_riv_bas + if (IV_dam_bas_id(JS_dam_bas)==IV_riv_bas_id(JS_riv_bas)) then + + do JS_riv_bas2=1,IS_riv_bas + if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then + !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas + !and the connection between both needs be broken + +if ((JS_riv_bas < IS_ownfirst+1 .or. JS_riv_bas >=IS_ownlast+1) .and. & + (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then + + call MatSetValues(ZM_T,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1, & + 0*ZS_one,INSERT_VALUES,ierr) + CHKERRQ(ierr) + !Breaks connection of transboundary matrix + +end if + + end if + end do + + end if + end do +end do +call MatAssemblyBegin(ZM_T,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_T,MAT_FINAL_ASSEMBLY,ierr) +!!sparse matrices need be assembled once their elements have been filled +call PetscPrintf(PETSC_COMM_WORLD,'Transboundary matrix modified for dams'// & + char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + +end if + +!------------------------------------------------------------------------------- +!End if dam model is used +!------------------------------------------------------------------------------- +end if + + +!******************************************************************************* +!Display matrix on stdout +!******************************************************************************* +!call PetscPrintf(PETSC_COMM_WORLD,'ZM_Net'//char(10),ierr) +!call MatView(ZM_Net,PETSC_VIEWER_STDOUT_WORLD,ierr) +! +!if (IS_opt_routing==3) then +! call PetscPrintf(PETSC_COMM_WORLD,'ZM_T'//char(10),ierr) +! call MatView(ZM_T,PETSC_VIEWER_STDOUT_WORLD,ierr) +!end if + + +!******************************************************************************* +!End +!******************************************************************************* + + +end subroutine rapid_net_mat_brk diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90 new file mode 100644 index 00000000..4c6b7f0b --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90 @@ -0,0 +1,106 @@ +!******************************************************************************* +!Subroutine - rapid_obs_mat +!******************************************************************************* +subroutine rapid_obs_mat + +!Purpose: +!Creates a kronecker-type diagonal sparse matrix. "1" is recorded at the row +!and column where observations are available. +!Author: +!Cedric H. David, 2008-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + IS_riv_bas,JS_riv_bas, & + IS_obs_bas,JS_obs_bas, & + IV_riv_bas_id,IV_obs_tot_id, & + IV_obs_index, & + ZM_Obs,ZS_norm, & + ierr, & + IS_one,ZS_one,temp_char + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + + +!******************************************************************************* +!Preallocation of the observation matrix +!******************************************************************************* +call MatSeqAIJSetPreallocation(ZM_Obs,1*IS_one,PETSC_NULL_INTEGER,ierr) +call MatMPIAIJSetPreallocation(ZM_Obs,1*IS_one,PETSC_NULL_INTEGER,0*IS_one, & + PETSC_NULL_INTEGER,ierr) +!Very basic preallocation assuming that all reaches have one gage. Cannot use +!IV_obs_loc1 for preallocation because it is of size IS_obs_bas and not +!IS_riv_bas. To do a better preallocation one needs to count the diagonal +!elements in a new vector + +!call PetscPrintf(PETSC_COMM_WORLD,'Observation matrix preallocated'//char(10), & +! ierr) + + +!******************************************************************************* +!Creation of the observation matrix +!******************************************************************************* +do JS_riv_bas=1,IS_riv_bas + do JS_obs_bas=1,IS_obs_bas + +if (IV_obs_tot_id(IV_obs_index(JS_obs_bas))==IV_riv_bas_id(JS_riv_bas)) then + call MatSetValues(ZM_Obs,IS_one,JS_riv_bas-1,IS_one,JS_riv_bas-1, & + ZS_one,INSERT_VALUES,ierr) +end if + + enddo +enddo + +call MatAssemblyBegin(ZM_Obs,MAT_FINAL_ASSEMBLY,ierr) +call MatAssemblyEnd(ZM_Obs,MAT_FINAL_ASSEMBLY,ierr) +!sparse matrices need be assembled once their elements have been filled + + +!******************************************************************************* +!Optional: calculation of number of gaging stations used in subbasin +!******************************************************************************* +call MatNorm(ZM_Obs,NORM_FROBENIUS,ZS_norm,ierr) +ZS_norm=ZS_norm*ZS_norm +write(temp_char,'(f10.1)') ZS_norm +call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in ' // & + 'this simulation (based on norm):' // temp_char // char(10), & + ierr) + + +!******************************************************************************* +!Display matrix on stdout +!******************************************************************************* +!call PetscPrintf(PETSC_COMM_WORLD,'ZM_Obs:'//char(10),ierr) +!call MatView(ZM_Obs,PETSC_VIEWER_STDOUT_WORLD,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* +call PetscPrintf(PETSC_COMM_WORLD,'Observation matrix created'//char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + + +end subroutine rapid_obs_mat diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90 new file mode 100644 index 00000000..e95db532 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90 @@ -0,0 +1,43 @@ +!******************************************************************************* +!Subroutine - rapid_open_Qfor +!******************************************************************************* +subroutine rapid_open_Qfor_file(Qfor_file) + +!Purpose: +!Open Qfor_file from Fortran. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +character(len=100), intent(in):: Qfor_file + + +!******************************************************************************* +!Open file +!******************************************************************************* +if (rank==0) open(34,file=Qfor_file,status='old') + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_open_Qfor_file + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90 new file mode 100644 index 00000000..9d418086 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90 @@ -0,0 +1,43 @@ +!******************************************************************************* +!Subroutine - rapid_open_Qhum +!******************************************************************************* +subroutine rapid_open_Qhum_file(Qhum_file) + +!Purpose: +!Open Qhum_file from Fortran. +!Author: +!Cedric H. David, 2014-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +character(len=100), intent(in):: Qhum_file + + +!******************************************************************************* +!Open file +!******************************************************************************* +if (rank==0) open(36,file=Qhum_file,status='old') + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_open_Qhum_file + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90 new file mode 100644 index 00000000..97bd509b --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90 @@ -0,0 +1,43 @@ +!******************************************************************************* +!Subroutine - rapid_open_Qobs +!******************************************************************************* +subroutine rapid_open_Qobs_file(Qobs_file) + +!Purpose: +!Open Qobs_file from Fortran. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +character(len=100), intent(in):: Qobs_file + + +!******************************************************************************* +!Open file +!******************************************************************************* +if (rank==0) open(33,file=Qobs_file,status='old') + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_open_Qobs_file + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90 new file mode 100644 index 00000000..00736f72 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90 @@ -0,0 +1,50 @@ +!******************************************************************************* +!Subroutine - rapid_open_Qout_file +!******************************************************************************* +subroutine rapid_open_Qout_file(Qout_file) + +!Purpose: +!Open Qout_file from Fortran/netCDF. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + rank,IS_nc_status,IS_nc_id_fil_Qout,IS_nc_id_var_Qout + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +character(len=100), intent(in):: Qout_file + + +!******************************************************************************* +!Open file +!******************************************************************************* +if (rank==0) then + close(99) + open(99,file=Qout_file,status='old') + close(99) + IS_nc_status=NF90_OPEN(Qout_file,NF90_WRITE,IS_nc_id_fil_Qout) + IS_nc_status=NF90_INQ_VARID(IS_nc_id_fil_Qout,'Qout',IS_nc_id_var_Qout) +end if + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_open_Qout_file + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90 new file mode 100644 index 00000000..fbe06485 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90 @@ -0,0 +1,49 @@ +!******************************************************************************* +!Subroutine - rapid_open_Vlat_file +!******************************************************************************* +subroutine rapid_open_Vlat_file(Vlat_file) + +!Purpose: +!Open Vlat_file from Fortran/netCDF. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + rank,IS_nc_status,IS_nc_id_fil_Vlat,IS_nc_id_var_Vlat + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +character(len=100), intent(in):: Vlat_file + + +!******************************************************************************* +!Open file +!******************************************************************************* +if (rank==0) then + open(99,file=Vlat_file,status='old') + close(99) + IS_nc_status=NF90_OPEN(Vlat_file,NF90_NOWRITE,IS_nc_id_fil_Vlat) + IS_nc_status=NF90_INQ_VARID(IS_nc_id_fil_Vlat,'m3_riv',IS_nc_id_var_Vlat) +end if + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_open_Vlat_file + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90 new file mode 100644 index 00000000..d2f1a159 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90 @@ -0,0 +1,277 @@ +!******************************************************************************* +!Subroutine - rapid_phiroutine +!******************************************************************************* +#ifndef NO_TAO +subroutine rapid_phiroutine(tao,ZV_pnorm,ZS_phi,IS_dummy,ierr) + +!Purpose: +!Calculates a cost function phi as a function of model parameters, using means +!over a given period of time. The cost function represents the square error +!between calculated flows and observed flows where observations are available. +!Author: +!Cedric H. David, 2008-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + Vlat_file,Qobs_file,Qfor_file,Qhum_file, & + JS_O,IS_O,JS_RpO,IS_RpO,ZS_TauR,IS_RpF,IS_RpH, & + ZM_Obs,ZV_Qobs, & + ZV_temp1,ZV_temp2,ZS_phitemp,ZS_phifac,ZV_kfac, & + IS_riv_tot,IS_for_bas,IS_hum_bas, & + ZS_knorm,ZS_xnorm,ZV_k,ZV_x,ZS_xfac, & + ZV_1stIndex,ZV_2ndIndex, & + ZV_C1,ZV_C2,ZV_C3,ZM_A, & + ZV_QoutinitO,ZV_QoutinitR, & + ZV_QoutbarO,ZV_VinitR,ZV_VR,ZV_VbarR, & + ZV_QoutR,ZV_QoutbarR, & + ZV_Vlat,ZV_Qlat,ZV_Qfor,ZV_Qext, & + ZV_Qobsbarrec, & + ksp, & + ZS_one,temp_char, & + IV_nc_start,IV_nc_count, & + IS_opt_phi,BS_opt_for,IS_strt_opt,IS_opt_routing, & + BS_opt_dam,IS_dam_bas,ZV_Qdam,BS_opt_hum,ZV_Qhum + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/taosolver.h" +!TAO solver + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +Vec, intent(in) :: ZV_pnorm +TaoSolver, intent(inout) :: tao +PetscErrorCode, intent(out) :: ierr +PetscScalar, intent(out):: ZS_phi +PetscInt, intent (in) :: IS_dummy + + +!******************************************************************************* +!Set linear system corresponding to current ZV_pnorm and set initial flowrates +!******************************************************************************* +ZS_phi=0 +!initialize phi to zero + +call VecDot(ZV_pnorm,ZV_1stIndex,ZS_knorm,ierr) +call VecDot(ZV_pnorm,ZV_2ndIndex,ZS_xnorm,ierr) +call VecCopy(ZV_kfac,ZV_k,ierr) +call VecScale(ZV_k,ZS_knorm,ierr) +call VecSet(ZV_x,ZS_xfac,ierr) +call VecScale(ZV_x,ZS_xnorm,ierr) +!compute ZV_k and ZV_x based on ZV_pnorm and ZV_kfac + +call rapid_routing_param(ZV_k,ZV_x,ZV_C1,ZV_C2,ZV_C3,ZM_A) +!calculate Muskingum parameters and matrix ZM_A + +call KSPSetOperators(ksp,ZM_A,ZM_A,DIFFERENT_NONZERO_PATTERN,ierr) +call KSPSetType(ksp,KSPRICHARDSON,ierr) !default=richardson +call KSPSetFromOptions(ksp,ierr) !if runtime options +!Set KSP to use matrix ZM_A +if (IS_opt_routing==3) call KSPSetType(ksp,KSPPREONLY,ierr)!default=preonly + + +!******************************************************************************* +!Set initial values to assure subroutine always starts from same conditions +!******************************************************************************* + +!------------------------------------------------------------------------------- +!Set initial value of instantaneous flow +!------------------------------------------------------------------------------- +call VecCopy(ZV_QoutinitO,ZV_QoutinitR,ierr) +!copy initial optimization variables into initial routing variables + +!------------------------------------------------------------------------------- +!Make sure the vectors potentially used for inflow to dams are initially null +!------------------------------------------------------------------------------- +call VecSet(ZV_Qext,0*ZS_one,ierr) !Qext=0 +call VecSet(ZV_QoutbarR,0*ZS_one,ierr) !QoutbarR=0 +!This matters only if rapid_get_Qdam is called because it uses these values + +!------------------------------------------------------------------------------- +!Set initial value of Qext from Qout_dam0 +!------------------------------------------------------------------------------- +if (BS_opt_dam .and. IS_dam_bas>0) then + call rapid_set_Qext0 !Qext from Qout_dam0 + !call VecView(ZV_Qext,PETSC_VIEWER_STDOUT_WORLD,ierr) +end if + + +!******************************************************************************* +!Calculate objective function for the whole period ZS_TauO +!******************************************************************************* + +!------------------------------------------------------------------------------- +!Open files +!------------------------------------------------------------------------------- +call rapid_open_Vlat_file(Vlat_file) +call rapid_open_Qobs_file(Qobs_file) +if (BS_opt_for) call rapid_open_Qfor_file(Qfor_file) +if (BS_opt_hum) call rapid_open_Qhum_file(Qhum_file) + + +!------------------------------------------------------------------------------- +!Read and compute +!------------------------------------------------------------------------------- +IV_nc_start=(/1,IS_strt_opt/) +IV_nc_count=(/IS_riv_tot,1/) + + +do JS_O=1,IS_O + +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +!calculate mean daily flow +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +call VecSet(ZV_QoutbarO,0*ZS_one,ierr) !QoutbarO=0 + +do JS_RpO=1,IS_RpO !loop needed here since Vlat is more frequent than Qobs + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Read/set surface and subsurface volumes +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call rapid_read_Vlat_file + +call VecCopy(ZV_Vlat,ZV_Qlat,ierr) !Qlat=Vlat +call VecScale(ZV_Qlat,1/ZS_TauR,ierr) !Qlat=Qlat/TauR + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Read/set upstream forcing +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +if (BS_opt_for .and. IS_for_bas>0 & + .and. mod((JS_O-1)*IS_RpO+JS_RpO,IS_RpF)==1) then + +call rapid_read_Qfor_file + +end if + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Run dam model based on previous values of QoutbarR and Qext to get Qdam +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +if (BS_opt_dam .and. IS_dam_bas>0) then + +call rapid_get_Qdam + +end if + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Read/set human induced flows +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +if (BS_opt_hum .and. IS_hum_bas>0 & + .and. mod((JS_O-1)*IS_RpO+JS_RpO,IS_RpH)==1) then + +call rapid_read_Qhum_file + +end if + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!calculation of Qext +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call VecCopy(ZV_Qlat,ZV_Qext,ierr) !Qext=Qlat +if (BS_opt_for) call VecAXPY(ZV_Qext,ZS_one,ZV_Qfor,ierr) !Qext=Qext+1*Qfor +if (BS_opt_dam) call VecAXPY(ZV_Qext,ZS_one,ZV_Qdam,ierr) !Qext=Qext+1*Qdam +if (BS_opt_hum) call VecAXPY(ZV_Qext,ZS_one,ZV_Qhum,ierr) !Qext=Qext+1*Qhum + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Routing procedure +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call rapid_routing(ZV_C1,ZV_C2,ZV_C3,ZV_Qext, & + ZV_QoutinitR,ZV_VinitR, & + ZV_QoutR,ZV_QoutbarR,ZV_VR,ZV_VbarR) + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Update variables +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +call VecCopy(ZV_QoutR,ZV_QoutinitR,ierr) + +call VecAXPY(ZV_QoutbarO,ZS_one/IS_RpO,ZV_QoutbarR,ierr) +!Qoutbar=QoutbarO+QoutbarR/IS_RpO + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!Update netCDF location +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +IV_nc_start(2)=IV_nc_start(2)+1 + + +enddo !end of loop to account for forcing more frequent than obs + +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +!Calculate objective function for current day +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +call rapid_read_Qobs_file + +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +!Objective function #1 - for current day - square error +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +if (IS_opt_phi==1) then +call VecWAXPY(ZV_temp1,-ZS_one,ZV_Qobs,ZV_QoutbarO,ierr) !temp1=Qoutbar-Qobs +call VecScale(ZV_temp1,ZS_phifac,ierr) !if phi too big +call MatMult(ZM_Obs,ZV_temp1,ZV_temp2,ierr) !temp2=Obs*temp1 +call VecDot(ZV_temp1,ZV_temp2,ZS_phitemp,ierr) !phitemp=temp1.temp2 +!result phitemp=(Qoutbar-Qobs)^T*Obs*(Qoutbar-Qobs) +end if + +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +!Objective function #2 - for current day - square error normalized by avg flow +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +if (IS_opt_phi==2) then +call VecWAXPY(ZV_temp1,-ZS_one,ZV_Qobs,ZV_QoutbarO,ierr) !temp1=Qoutbar-Qobs +call VecPointWiseMult(ZV_temp1,ZV_temp1,ZV_Qobsbarrec,ierr)!temp1=temp1.*Qobsbarrec +call MatMult(ZM_Obs,ZV_temp1,ZV_temp2,ierr) !temp2=Obs*temp1 +call VecDot(ZV_temp1,ZV_temp2,ZS_phitemp,ierr) !phitemp=temp1.temp2 +!result phitemp=[(Qoutbar-Qobs).*Qobsbarrec]^T*Obs*[(Qoutbar-Qobs).*Qobsbarrec] +end if + +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +!adds daily objective function to total objective function +!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + +ZS_phi=ZS_phi+ZS_phitemp +!increments phi for each time step during the desired period of optimization + +enddo + +!------------------------------------------------------------------------------- +!Close files +!------------------------------------------------------------------------------- +call rapid_close_Vlat_file +call rapid_close_Qobs_file +call rapid_close_Qfor_file +call rapid_close_Qhum_file + + +!******************************************************************************* +!Write outputs (parameters and calculated objective function) +!******************************************************************************* +call PetscPrintf(PETSC_COMM_WORLD,'current normalized p=(k,x)',ierr) +call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr) +call VecView(ZV_pnorm,PETSC_VIEWER_STDOUT_WORLD,ierr) +call PetscPrintf(PETSC_COMM_WORLD,'corresponding value of phi',ierr) +call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr) +write(temp_char,'(f10.3)') ZS_phi +call PetscPrintf(PETSC_COMM_WORLD,temp_char // char(10),ierr) +call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr) + + +end subroutine rapid_phiroutine +#endif diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90 new file mode 100644 index 00000000..cb391ecc --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90 @@ -0,0 +1,74 @@ +!******************************************************************************* +!Subroutine - rapid_read_Qfor_file +!******************************************************************************* +subroutine rapid_read_Qfor_file + +!Purpose: +!Read Qfor_file from Fortran. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank,ierr,ZV_read_for_tot, & + ZV_Qfor,IS_for_bas,IV_for_loc2,IV_for_index,ZV_read_for_tot + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Read file +!******************************************************************************* +if (rank==0) read(34,*) ZV_read_for_tot + + +!******************************************************************************* +!Set values in PETSc vector +!******************************************************************************* +if (rank==0) then +call VecSetValues(ZV_Qfor,IS_for_bas,IV_for_loc2, & + ZV_read_for_tot(IV_for_index),INSERT_VALUES,ierr) + !here we only look at the forcing within the basin studied +end if + +!******************************************************************************* +!Assemble PETSc vector +!******************************************************************************* +call VecAssemblyBegin(ZV_Qfor,ierr) +call VecAssemblyEnd(ZV_Qfor,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_read_Qfor_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90 new file mode 100644 index 00000000..9c0c0af2 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90 @@ -0,0 +1,75 @@ +!******************************************************************************* +!Subroutine - rapid_read_Qhum_file +!******************************************************************************* +subroutine rapid_read_Qhum_file + +!Purpose: +!Read Qhum_file from Fortran. +!Author: +!Cedric H. David, 2014-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank,ierr,ZV_read_hum_tot, & + ZV_Qhum,IS_hum_bas,IV_hum_loc1,IV_hum_index,ZV_read_hum_tot + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Read file +!******************************************************************************* +if (rank==0) read(36,*) ZV_read_hum_tot + + +!******************************************************************************* +!Set values in PETSc vector +!******************************************************************************* +if (rank==0) then +call VecSetValues(ZV_Qhum,IS_hum_bas,IV_hum_loc1, & + ZV_read_hum_tot(IV_hum_index),INSERT_VALUES,ierr) + !here we only look at the human-induced flows within the basin + !studied +end if + +!******************************************************************************* +!Assemble PETSc vector +!******************************************************************************* +call VecAssemblyBegin(ZV_Qhum,ierr) +call VecAssemblyEnd(ZV_Qhum,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_read_Qhum_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90 new file mode 100644 index 00000000..e6333dac --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90 @@ -0,0 +1,75 @@ +!******************************************************************************* +!Subroutine - rapid_read_Qobs_file +!******************************************************************************* +subroutine rapid_read_Qobs_file + +!Purpose: +!Read Qobs_file from Fortran. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use rapid_var, only : & + rank,ierr, & + ZV_Qobs,IS_obs_bas,IV_obs_loc1,IV_obs_index,ZV_read_obs_tot + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Read file +!******************************************************************************* +if (rank==0) read(33,*) ZV_read_obs_tot + + +!******************************************************************************* +!Set values in PETSc vector +!******************************************************************************* +if (rank==0) then +call VecSetValues(ZV_Qobs,IS_obs_bas,IV_obs_loc1, & + ZV_read_obs_tot(IV_obs_index),INSERT_VALUES,ierr) + !here we only look at the observations within the basin + !studied +end if + + +!******************************************************************************* +!Assemble PETSc vector +!******************************************************************************* +call VecAssemblyBegin(ZV_Qobs,ierr) +call VecAssemblyEnd(ZV_Qobs,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_read_Qobs_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90 new file mode 100644 index 00000000..64d3e30c --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90 @@ -0,0 +1,79 @@ +!******************************************************************************* +!Subroutine - rapid_read_Vlat_file +!******************************************************************************* +subroutine rapid_read_Vlat_file + +!Purpose: +!Read Vlat_file from Fortran. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + rank,ierr, & + IS_nc_status,IS_nc_id_fil_Vlat,IS_nc_id_var_Vlat, & + IV_nc_start,IV_nc_count, & + IS_riv_bas,IV_riv_loc1,IV_riv_index,ZV_read_riv_tot,ZV_Vlat + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Read file +!******************************************************************************* +if (rank==0) then + IS_nc_status=NF90_GET_VAR(IS_nc_id_fil_Vlat,IS_nc_id_var_Vlat, & + ZV_read_riv_tot,IV_nc_start,IV_nc_count) +end if + + +!******************************************************************************* +!Set values in PETSc vector +!******************************************************************************* +if (rank==0) then + call VecSetValues(ZV_Vlat,IS_riv_bas,IV_riv_loc1, & + ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr) +end if + + +!******************************************************************************* +!Assemble PETSc vector +!******************************************************************************* +call VecAssemblyBegin(ZV_Vlat,ierr) +call VecAssemblyEnd(ZV_Vlat,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_read_Vlat_file diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90 new file mode 100644 index 00000000..69ac97cd --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90 @@ -0,0 +1,38 @@ +!******************************************************************************* +!Subroutine - rapid_read_namelist +!******************************************************************************* +subroutine rapid_read_namelist + +!Purpose: +!This subroutine allows to read the RAPID namelist and hence to run the model +!multiple times without ever have to recompile. Some information on the options +!used is also printed in the stdout. +!Author: +!Cedric H. David, 2011-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + NL_namelist,namelist_file + + +implicit none + + +!******************************************************************************* +!Read namelist file +!******************************************************************************* +open(88,file=namelist_file,status='old',form='formatted') +read(88, NL_namelist) +close(88) + + +!******************************************************************************* +!Optional prints what was read +!******************************************************************************* +!print *, namelist_file + + +end subroutine rapid_read_namelist diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90 new file mode 100644 index 00000000..34e860e7 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90 @@ -0,0 +1,268 @@ +!******************************************************************************* +!Subroutine - rapid_routing +!******************************************************************************* +subroutine rapid_routing(ZV_C1,ZV_C2,ZV_C3,ZV_Qext, & + ZV_QoutinitR,ZV_VinitR, & + ZV_QoutR,ZV_QoutbarR,ZV_VR,ZV_VbarR) + +!Purpose: +!Performs flow calculation in each reach of a river network using the Muskingum +!method (McCarthy 1938). Also calculates the volume of each reach using a +!simple first order approximation +!Author: +!Cedric H. David, 2008-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + ZS_dtR,IS_R,JS_R, & + ZM_Net,ZM_TC1, & + ZV_b,ZV_babsmax,ZV_bhat, & + ZV_QoutprevR,ZV_VprevR,ZV_QoutRabsmin,ZV_QoutRabsmax, & + ZV_QoutRhat, & + ZV_VoutR,ZV_Vext, & + ierr,ksp, & + ZS_one,IS_ksp_iter,IS_ksp_iter_max, & + vecscat,ZV_SeqZero,ZV_pointer,rank, & + IS_nc_status,IS_nc_id_fil_Qout,IS_nc_id_var_Qout, & + IV_nc_start,IV_nc_count2, & + IS_riv_bas,JS_riv_bas,IM_index_up, & + IS_opt_routing,IV_nbup,IV_riv_index, & + BS_opt_influence + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +Vec, intent(in) :: ZV_C1,ZV_C2,ZV_C3,ZV_Qext, & + ZV_QoutinitR,ZV_VinitR +Vec, intent(out) :: ZV_QoutR,ZV_QoutbarR +Vec :: ZV_VR,ZV_VbarR + +PetscInt :: IS_localsize,JS_localsize +PetscScalar, pointer :: ZV_QoutR_p(:),ZV_QoutprevR_p(:),ZV_QoutinitR_p(:), & + ZV_QoutbarR_p(:),ZV_Qext_p(:),ZV_C1_p(:),ZV_C2_p(:), & + ZV_C3_p(:),ZV_b_p(:), & + ZV_babsmax_p(:),ZV_QoutRabsmin_p(:),ZV_QoutRabsmax_p(:) + + +!******************************************************************************* +!Get local sizes for vectors +!******************************************************************************* +call VecGetLocalSize(ZV_QoutR,IS_localsize,ierr) + + +!******************************************************************************* +!Set mean values to zero initialize QoutprevR with QoutinitR +!******************************************************************************* +call VecSet(ZV_QoutbarR,0*ZS_one,ierr) !Qoutbar=0 +!call VecSet(ZV_VbarR,0*ZS_one,ierr) !Vbar=0 +!set the means to zero at beginning of iterations over routing time step + +call VecCopy(ZV_QoutinitR,ZV_QoutprevR,ierr) !QoutprevR=QoutinitR +!call VecCopy(ZV_VinitR,ZV_VprevR,ierr) !VprevR=VinitR +!set the previous value to the initial value given as input to subroutine + + +!******************************************************************************* +!Temporal loop +!******************************************************************************* +call VecGetArrayF90(ZV_C1,ZV_C1_p,ierr) +call VecGetArrayF90(ZV_C2,ZV_C2_p,ierr) +call VecGetArrayF90(ZV_C3,ZV_C3_p,ierr) +call VecGetArrayF90(ZV_Qext,ZV_Qext_p,ierr) + +do JS_R=1,IS_R +!------------------------------------------------------------------------------- +!Update mean +!------------------------------------------------------------------------------- +call VecAXPY(ZV_QoutbarR,ZS_one/IS_R,ZV_QoutprevR,ierr) +!Qoutbar=Qoutbar+Qoutprev/IS_R + +!call VecAXPY(ZV_VbarR,ZS_one/IS_R,ZV_VprevR,ierr) +!Vbar=Vbar+Vprev/IS_R + +!------------------------------------------------------------------------------- +!Calculation of the right hand size, b +!------------------------------------------------------------------------------- +call MatMult(ZM_Net,ZV_QoutprevR,ZV_b,ierr) !b2=Net*Qoutprev + +call VecGetArrayF90(ZV_b,ZV_b_p,ierr) +call VecGetArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr) + +do JS_localsize=1,IS_localsize + ZV_b_p(JS_localsize)=ZV_b_p(JS_localsize)*ZV_C2_p(JS_localsize) & + +(ZV_C1_p(JS_localsize)+ZV_C2_p(JS_localsize)) & + *ZV_Qext_p(JS_localsize) & + +ZV_C3_p(JS_localsize)*ZV_QoutprevR_p(JS_localsize) +end do + +call VecRestoreArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr) +call VecRestoreArrayF90(ZV_b,ZV_b_p,ierr) + +!------------------------------------------------------------------------------- +!Routing with PETSc using a matrix method +!------------------------------------------------------------------------------- +if (IS_opt_routing==1) then + +call KSPSolve(ksp,ZV_b,ZV_QoutR,ierr) !solves A*Qout=b +call KSPGetIterationNumber(ksp,IS_ksp_iter,ierr) +if (IS_ksp_iter>IS_ksp_iter_max) IS_ksp_iter_max=IS_ksp_iter + +end if + +!------------------------------------------------------------------------------- +!Routing with Fortran using the traditional Muskingum method +!------------------------------------------------------------------------------- +if (IS_opt_routing==2) then + +call VecGetArrayF90(ZV_QoutR,ZV_QoutR_p,ierr) +call VecGetArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr) +call VecGetArrayF90(ZV_b,ZV_b_p,ierr) + +do JS_riv_bas=1,IS_riv_bas + ZV_QoutR_p(JS_riv_bas)=ZV_b_p(JS_riv_bas) & + +sum(ZV_C1_p(JS_riv_bas) & + *ZV_QoutR_p(IM_index_up(JS_riv_bas,1: & + IV_nbup(IV_riv_index(JS_riv_bas))))) +end do +!Taking into account the knowledge of how many upstream locations exist. +!Similar to exact preallocation of network matrix + +call VecRestoreArrayF90(ZV_QoutR,ZV_QoutR_p,ierr) +call VecRestoreArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr) +call VecRestoreArrayF90(ZV_b,ZV_b_p,ierr) +end if + +!------------------------------------------------------------------------------- +!Routing with PETSc using a matrix method with transboundary matrix +!------------------------------------------------------------------------------- +if (IS_opt_routing==3) then + +call KSPSolve(ksp,ZV_b,ZV_QoutRhat,ierr) !solves A*Qouthat=b +call KSPGetIterationNumber(ksp,IS_ksp_iter,ierr) +if (IS_ksp_iter>IS_ksp_iter_max) IS_ksp_iter_max=IS_ksp_iter + +call MatMult(ZM_TC1,ZV_QoutRhat,ZV_bhat,ierr) +call VecAYPX(ZV_bhat,ZS_one,ZV_b,ierr) + +call KSPSolve(ksp,ZV_bhat,ZV_QoutR,ierr) !solves A*Qout=bhat +call KSPGetIterationNumber(ksp,IS_ksp_iter,ierr) +if (IS_ksp_iter>IS_ksp_iter_max) IS_ksp_iter_max=IS_ksp_iter + +end if + + +!------------------------------------------------------------------------------- +!Calculation of babsmax, QoutRabsmin and QoutRabsmax +!------------------------------------------------------------------------------- +if (BS_opt_influence) then + +call VecGetArrayF90(ZV_b,ZV_b_p,ierr) +call VecGetArrayF90(ZV_babsmax,ZV_babsmax_p,ierr) +do JS_localsize=1,IS_localsize + if (ZV_babsmax_p(JS_localsize)<=abs(ZV_b_p(JS_localsize))) then + ZV_babsmax_p(JS_localsize) =abs(ZV_b_p(JS_localsize)) + end if +end do +call VecRestoreArrayF90(ZV_b,ZV_b_p,ierr) +call VecRestoreArrayF90(ZV_babsmax,ZV_babsmax_p,ierr) + +call VecGetArrayF90(ZV_QoutR,ZV_QoutR_p,ierr) +call VecGetArrayF90(ZV_QoutRabsmin,ZV_QoutRabsmin_p,ierr) +call VecGetArrayF90(ZV_QoutRabsmax,ZV_QoutRabsmax_p,ierr) +do JS_localsize=1,IS_localsize + if (ZV_QoutRabsmin_p(JS_localsize)>=abs(ZV_QoutR_p(JS_localsize))) then + ZV_QoutRabsmin_p(JS_localsize) =abs(ZV_QoutR_p(JS_localsize)) + end if + if (ZV_QoutRabsmax_p(JS_localsize)<=abs(ZV_QoutR_p(JS_localsize))) then + ZV_QoutRabsmax_p(JS_localsize) =abs(ZV_QoutR_p(JS_localsize)) + end if +end do +call VecRestoreArrayF90(ZV_QoutR,ZV_QoutR_p,ierr) +call VecRestoreArrayF90(ZV_QoutRabsmin,ZV_QoutRabsmin_p,ierr) +call VecRestoreArrayF90(ZV_QoutRabsmax,ZV_QoutRabsmax_p,ierr) + +end if + +!------------------------------------------------------------------------------- +!Calculation of V (this part can be commented to accelerate parameter +!estimation in calibration mode) +!------------------------------------------------------------------------------- +!call VecCopy(ZV_QoutR,ZV_VoutR,ierr) !Vout=Qout +!call VecScale(ZV_VoutR,ZS_dtR,ierr) !Vout=Vout*dt +!!result Vout=Qout*dt +! +!call VecCopy(ZV_Qext,ZV_Vext,ierr) !Vext=Qext +!call VecScale(ZV_Vext,ZS_dtR,ierr) !Vext=Vext*dt +!!result Vext=Qext*dt +! +!call MatMult(ZM_Net,ZV_VoutR,ZV_VR,ierr) !V=Net*Vout +!call VecAXPY(ZV_VR,ZS_one,ZV_Vext,ierr) !V=V+Vext +!call VecAXPY(ZV_VR,-ZS_one,ZV_VoutR,ierr) !V=V-Vout +!call VecAXPY(ZV_VR,ZS_one,ZV_VprevR,ierr) !V=V+Vprev +!!result V=Vprev+(Net*Vout+Vext)-Vout + + +!------------------------------------------------------------------------------- +!Reset previous +!------------------------------------------------------------------------------- +call VecCopy(ZV_QoutR,ZV_QoutprevR,ierr) !Qoutprev=Qout +!call VecCopy(ZV_VR,ZV_VprevR,ierr) !Vprev=V +!reset previous + + +!------------------------------------------------------------------------------- +!optional write outputs +!------------------------------------------------------------------------------- +!call VecScatterBegin(vecscat,ZV_QoutR,ZV_SeqZero, & +! INSERT_VALUES,SCATTER_FORWARD,ierr) +!call VecScatterEnd(vecscat,ZV_QoutR,ZV_SeqZero, & +! INSERT_VALUES,SCATTER_FORWARD,ierr) +!call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr) +!!if (rank==0) write (99,'(10e10.3)') ZV_pointer +!if (rank==0) IS_nc_status=NF90_PUT_VAR(IS_nc_id_fil_Qout,IS_nc_id_var_Qout, & +! ZV_pointer, & +! [IV_nc_start(1),(IV_nc_start(2)-1)*IS_R+JS_R],IV_nc_count2) +!call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr) + + +!------------------------------------------------------------------------------- +!End temporal loop +!------------------------------------------------------------------------------- +end do + +call VecRestoreArrayF90(ZV_C1,ZV_C1_p,ierr) +call VecRestoreArrayF90(ZV_C2,ZV_C2_p,ierr) +call VecRestoreArrayF90(ZV_C3,ZV_C3_p,ierr) +call VecRestoreArrayF90(ZV_Qext,ZV_Qext_p,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* +end subroutine rapid_routing diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90 new file mode 100644 index 00000000..96ba7fab --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90 @@ -0,0 +1,100 @@ +!******************************************************************************* +!Subroutine - rapid_routing_param +!******************************************************************************* +subroutine rapid_routing_param(ZV_k,ZV_x, & + ZV_C1,ZV_C2,ZV_C3,ZM_A) + +!Purpose: +!Calculates the Muskingum method (McCarthy 1938) parameters C1, C2 and C3. +!Also calculates the matrix A used for linear system solver. +!Author: +!Cedric H. David, 2010-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only : & + ZM_Net,ZM_T,ZM_TC1, & + ZV_Cdenom,ZS_dtR, & + ierr,ZS_one,ZV_one,IS_opt_routing + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* +Vec, intent(in) :: ZV_k,ZV_x +Vec, intent(out) :: ZV_C1,ZV_C2,ZV_C3,ZM_A + + +!******************************************************************************* +!Calculation of the Muskingum method constants (C1,C2,C3) and of the matrix A +!used in the linear system A*Qout=b +!******************************************************************************* +call VecCopy(ZV_x,ZV_Cdenom,ierr) +call VecScale(ZV_Cdenom,-ZS_one,ierr) +call VecShift(ZV_Cdenom,ZS_one,ierr) +call VecPointwiseMult(ZV_Cdenom,ZV_Cdenom,ZV_k,ierr) +call VecShift(ZV_Cdenom,ZS_dtR/2,ierr) +!Cdenom=k*(1-x)+dtR/2 + +call VecPointwiseMult(ZV_C1,ZV_k,ZV_x,ierr) +call VecScale(ZV_C1,-ZS_one,ierr) +call VecShift(ZV_C1,ZS_dtR/2,ierr) +call VecPointwiseDivide(ZV_C1,ZV_C1,ZV_Cdenom,ierr) +!C1=(-k*x+dtR/2)/Cdenom + +call VecPointwiseMult(ZV_C2,ZV_k,ZV_x,ierr) +call VecShift(ZV_C2,ZS_dtR/2,ierr) +call VecPointwiseDivide(ZV_C2,ZV_C2,ZV_Cdenom,ierr) +!C2=(k*x+dtR/2)/Cdenom + +call VecCopy(ZV_x,ZV_C3,ierr) +call VecScale(ZV_C3,-ZS_one,ierr) +call VecShift(ZV_C3,ZS_one,ierr) +call VecPointwiseMult(ZV_C3,ZV_C3,ZV_k,ierr) +call VecShift(ZV_C3,-ZS_dtR/2,ierr) +call VecPointwiseDivide(ZV_C3,ZV_C3,ZV_Cdenom,ierr) +!C3=(k*(1-x)-dtR/2)/Cdenom +!C1, C2 and C3 completed + + +call MatCopy(ZM_Net,ZM_A,DIFFERENT_NONZERO_PATTERN,ierr) !A=Net +call MatDiagonalScale(ZM_A,ZV_C1,ZV_one,ierr) !A=diag(C1)*A +call MatScale(ZM_A,-ZS_one,ierr) !A=-A +call MatShift(ZM_A,ZS_one,ierr) !A=A+1*I +!Result:A=I-diag(C1)*Net + +if (IS_opt_routing==3) then +call MatCopy(ZM_T,ZM_TC1,DIFFERENT_NONZERO_PATTERN,ierr) !TC1=T +call MatDiagonalScale(ZM_TC1,ZV_C1,ZV_one,ierr) !TC1=diag(C1)*TC1 +!Result:TC1=T*diag(C1) +end if + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_routing_param + diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_script.sh b/wrfv2_fire/hydro/Rapid_routing/rapid_script.sh new file mode 100644 index 00000000..35753daf --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_script.sh @@ -0,0 +1,11 @@ +FILE=$(date +"%Y-%m-%d_%H-%M-%S_rapid_stdout.txt") +/usr/bin/time mpiexec \ + -n 1 \ + ./rapid \ + -ksp_type richardson \ + 1>$FILE 2>>$FILE + +#FILE is a name created based on the time when the model started running +#FILE contains stdout from running the model (through 1), but also stderr +#(through 2). The output of the time function is also included because +#it is located in located in 2. diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90 new file mode 100644 index 00000000..768fb7a6 --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90 @@ -0,0 +1,103 @@ +!******************************************************************************* +!Subroutine - rapid_set_Qext0 +!******************************************************************************* +subroutine rapid_set_Qext0 + +!Purpose: +!This subroutine is only useful if a dam model is used and its goal is to +!properly initialize the flow of water into the dams. +!The inflow of water ZV_Qin_dam_prev from the river network and from outside of +!the river network into the dams is computed based on ZV_QoutbarR and ZV_Qext +!in the subroutine rapid_get_Qdam.F90. +!Therefore, one has to inject the initial value of ZV_Qin_dam_prev (ZV_Qin_dam0) +!into either ZV_QoutbarR or ZV_Qext otherwise the initial value will be +!overwritten in rapid_get_Qdam.F90. The latter is used here (through ZV_Qdam) +!since the modifications made on the network matrix make it difficult to use +!ZV_Qin_dam_prev without creating a new variable. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Declaration of variables +!******************************************************************************* +use rapid_var, only: & + rank,ierr,IS_one,ZS_one, & + ZV_Qdam,ZV_Qext, & + IS_dam_tot,JS_dam_tot,IV_dam_pos + +use rapid_var, only: & + ZV_Qin_dam_prev,ZV_Qin_dam0, & + ZV_Qout_dam_prev,ZV_Qout_dam0 + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Set Qdam to zero, because this is called at the beginning of every phiroutine +!******************************************************************************* +call VecSet(ZV_Qdam,0*ZS_one,ierr) !Qdam=0 +!call VecView(ZV_Qdam,PETSC_VIEWER_STDOUT_WORLD,ierr) + + +!******************************************************************************* +!Set values of Qin_dam0 into Qdam to allow proper initialization +!******************************************************************************* +if (rank==0) then + do JS_dam_tot=1,IS_dam_tot + +if (IV_dam_pos(JS_dam_tot)/=0) then + call VecSetValues(ZV_Qdam,IS_one,IV_dam_pos(JS_dam_tot)-1, & + ZV_Qin_dam0(JS_dam_tot),INSERT_VALUES,ierr) + !print *, IV_dam_pos(JS_dam_tot)-1, ZV_Qin_dam0(JS_dam_tot) +end if + + end do +end if + +call VecAssemblyBegin(ZV_Qdam,ierr) +call VecAssemblyEnd(ZV_Qdam,ierr) +!call VecView(ZV_Qdam,PETSC_VIEWER_STDOUT_WORLD,ierr) +!the values of Qindam0 are set here where the dams are, not downstream of them + + +!******************************************************************************* +!Copy Qdam into Qext and reset Qdam to zero +!******************************************************************************* +call VecCopy(ZV_Qdam,ZV_Qext,ierr) !Qext=Qdam +call VecSet(ZV_Qdam,0*ZS_one,ierr) !Qdam=0 +!call VecView(ZV_Qext,PETSC_VIEWER_STDOUT_WORLD,ierr) + + +!******************************************************************************* +!Initialize Qout_dam_prev again or its values differ with each phiroutine call +!******************************************************************************* +if (rank==0) then + ZV_Qout_dam_prev=ZV_Qout_dam0 +end if + +!******************************************************************************* +!End +!******************************************************************************* +end subroutine rapid_set_Qext0 diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 new file mode 100644 index 00000000..e8017c6d --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 @@ -0,0 +1,538 @@ +!******************************************************************************* +!Module - rapid_var +!******************************************************************************* +module rapid_var + +!Purpose: +!Module where all the variables are defined. +!Author: +!Cedric H. David, 2008-2015. + + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and Fortran90-specific vectors +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +!#include "finclude/petsclog.h" +!Profiling log + +#ifndef NO_TAO +#include "finclude/taosolver.h" +!TAO solver +#endif + + +!******************************************************************************* +!Declaration of variables - runtime options +!******************************************************************************* +logical :: BS_opt_Qinit +!.false. --> no read initial flow .true. --> read initial flow +logical :: BS_opt_Qfinal +!.false. --> no write final flow .true. --> write final flow +logical :: BS_opt_hum +!.false. --> no human-induced flows .true. --> human-induced flows +logical :: BS_opt_for +!.false. --> no forcing .true. --> forcing +logical :: BS_opt_dam +!.false. --> no dam model used .true. --> dam model used +logical :: BS_opt_influence +!.false. --> no output influence .true. --> output influence +PetscInt :: IS_opt_routing +!1 --> matrix-based Muskingum 2 --> traditional Muskingum +!3 --> Transbnd. matrix-based +PetscInt :: IS_opt_run +!1 --> regular run 2 --> parameter optimization +PetscInt :: IS_opt_phi +!1 --> phi1 2 --> phi2 + + +!! LPR: add the path for coupling file in NAMELIST +!character(len=120) :: rapid_coupling_file +!unit 88 - file that contains coupling information for WRF-Hydro +!******************************************************************************* +!Declaration of variables - input and output files +!******************************************************************************* +character(len=120) :: rapid_connect_file +!unit 10 - file with connectivity information using RAPID connectivity format +character(len=120) :: riv_bas_id_file +!unit 11 - file with all the IDs of the reaches in _riv considered +character(len=120) :: obs_tot_id_file +!unit 12 - file with all the IDs of the all reaches with gage measurements +character(len=120) :: obs_use_id_file +!unit 13 - file with all the IDs of the reaches used +character(len=120) :: hum_tot_id_file +!unit 14 - file with all the IDs of the reaches with human-induced flow added +character(len=120) :: hum_use_id_file +!unit 15 - file with all the IDs of the reaches used +character(len=120) :: for_tot_id_file +!unit 16 - file with all the IDs where flows can be used as forcing to their +!corresponding downstream reach +character(len=120) :: for_use_id_file +!unit 17 - file with all the IDs of the reaches used +character(len=120) :: dam_tot_id_file +!unit 18 - file with all the IDs of the reaches where the dam model runs and +!flows to their corresponding downstream reach +character(len=120) :: dam_use_id_file +!unit 19 - file with all the IDs of the reaches used + +character(len=120) :: k_file +!unit 20 - file with values for k (possibly from previous param. estim.) +character(len=120) :: x_file +!unit 21 - file with values for x (possibly from previous param. estim.) +character(len=120) :: kfac_file +!unit 22 - file with kfac for all reaches of the domain +character(len=120) :: xfac_file +!unit 23 - file with xfac for all reaches of the domain + +character(len=120) :: Qinit_file +!unit 30 - file where initial flowrates can be stored to run the model with them +character(len=120) :: Qfinal_file +!unit 31 - file where final flowrates can be stored at the end of model run +character(len=120) :: Vlat_file + +character(len=120) :: Qobs_file +!unit 33 - file where the flowrates observations are given +character(len=120) :: Qfor_file +!unit 34 - file where forcing flowrates are stored. Forcing is taken as the +!flow coming from upstream reach. +character(len=120) :: Qobsbarrec_file +!unit 35 - file where the reciprocal (1/xi) of the average obs are stored. +character(len=120) :: Qhum_file +!unit 36 - file where human-induced flowrates are stored. These flows are added +!upstream. + +character(len=120) :: V_file +!unit 41 - file where model-calculated volumes are stored +character(len=120) :: babsmax_file +!unit 42 - file where the maximum of the absolute values of the right-hand-side +!are stored +character(len=120) :: QoutRabsmin_file +!unit 43 - file where the minimum of the absolute values of the instantaneous +!flows are stored +character(len=120) :: QoutRabsmax_file +!unit 44 - file where the maximum of the absolute values of the instantaneous +!flows are stored +character(len=120) :: Qout_file + + +!******************************************************************************* +!Declaration of variables - temporal parameters +!******************************************************************************* +PetscScalar :: ZS_TauM +!Duration of main procedure, in seconds +PetscScalar :: ZS_dtM +!Time step of main procedure, in seconds +PetscInt :: IS_M +!Number of time steps within the main precedure +PetscInt :: JS_M +!Index of main procedure + +PetscScalar :: ZS_TauO +!Duration of optimization procedure, in seconds +PetscScalar :: ZS_dtO +!Time step of optimization procedure, in seconds +PetscInt :: IS_O +!Number of time steps within the optimization precedure +PetscInt :: JS_O +!Index of optimization procedure + +PetscScalar :: ZS_TauR +!Duration of river routing procedure, in seconds +PetscScalar :: ZS_dtR +!Time step of river routing procedure, in seconds +PetscInt :: IS_R +!Number of time steps within the river routing procedure +PetscInt :: JS_R +!Index of river routing procedure + +PetscScalar :: ZS_dtF +!Time step of forcing data, in seconds +PetscScalar :: ZS_dtH +!Time step of human-induced data, in seconds + +PetscInt :: IS_RpO, JS_RpO +!Number routing procedures needed per optimization time step, and index +PetscInt :: IS_RpM, JS_RpM +!Number routing procedures needed per main time step, and index +PetscInt :: IS_RpF +!Number routing procedures needed per forcing time step +PetscInt :: IS_RpH +!Number routing procedures needed per human-induced time step + + +!******************************************************************************* +!Declaration of variables - River flow variables +!******************************************************************************* +PetscInt :: IS_riv_tot,JS_riv_tot,JS_riv_tot2 +!total number of river reaches, corresponds to the size of rapid_connect_file +PetscInt :: IS_riv_bas,JS_riv_bas,JS_riv_bas2 +!size of the matrix and the vectors in this _riv, corresponds to the number of +!reaches in the _riv +PetscInt, dimension(:), allocatable :: IV_riv_tot_id +!unique IDs of reaches in rapid_connect_file +PetscInt, dimension(:), allocatable :: IV_down +!vector of the downstream river reach of each river reach +PetscInt, dimension(:), allocatable :: IV_nbup +!vector of the number of direct upstream river reach of each river reach +PetscInt :: IS_max_up +!maximum number of upstream river reaches for each river reach +PetscInt, dimension(:,:), allocatable :: IM_up +!matrix with the ID of the upstream river reaches of each river reach +PetscInt :: JS_up +!JS_up for the corresponding upstream reaches +PetscInt :: IS_row,IS_col +!index of rows and columns used to fill up the network matrix +PetscInt,dimension (:,:), allocatable :: IM_index_up +!matrix with the index of the upstream river reaches of each river reach +!index goes from 1 to IS_riv_bas +PetscInt, dimension(:),allocatable :: IV_riv_bas_id +!unique IDs in riv_bas_id_file, of length IS_riv_bas +PetscInt, dimension(:), allocatable :: IV_riv_index +!indexes (Fortran, 1-based) of the reaches in the _riv within the whole network +!size IS_riv_bas +PetscInt,dimension(:), allocatable :: IV_riv_loc1 +!vector giving the zero-base index corresponding to the river reaches within +!the _riv studied only, to be used in VecSetValues. size IS_riv_bas +Mat :: ZM_hsh_tot +!flat matrix with size IS_riv_id_max*ncore that serves a hashtable-like purpose +!in which the index over the domain (JS_riv_tot) is stored at the location of +!each reach ID. Each row contains the exact same data. +Mat :: ZM_hsh_bas +!flat matrix with size IS_riv_id_max*ncore that serves a hashtable-like purpose +!in which the index over the basin (JS_riv_bas) is stored at the location of +!each reach ID. Each row contains the exact same data. +PetscInt :: IS_riv_id_max=1000000000 +!Maximum value allowed for the unique integer IDs corresponding to each reach + +!******************************************************************************* +!Declaration of variables - Observation flow variables +!******************************************************************************* +PetscInt :: IS_obs_tot, JS_obs_tot +!total number of reaches that have observations (gaged reaches), corresponds to +!the number of lines in obs_tot_id_file +PetscInt :: IS_obs_use, JS_obs_use +!Number of gages available in obs_use_id_file +PetscInt :: IS_obs_bas, JS_obs_bas +!Number of gages within _riv studied. Will be calculated based on +!obs_tot_id_file, obs_use_id_file and riv_bas_id_file +PetscInt, dimension(:), allocatable :: IV_obs_tot_id +!vector where are stored the river ID of each gage available +PetscInt, dimension(:), allocatable :: IV_obs_use_id +!vector where are stored the river ID of each gage used in current run +PetscInt, allocatable, dimension(:) :: IV_obs_index +!vector where the Fortran 1-based indexes of the gages within the Qobs_file. +!Will be allocated size IS_obs_bas +PetscInt, allocatable, dimension(:) :: IV_obs_loc1 +!vector where the C (0-based) vector indexes of where gages are. This is +!within the _riv only, not all domain. Will be used in VecSet. Will be +!allocated size IS_obs_bas + + +!******************************************************************************* +!Declaration of variables - Human-induced flow variables +!******************************************************************************* +PetscInt :: IS_hum_tot, JS_hum_tot +!total number of reaches where human-induced flow data are available. +PetscInt :: IS_hum_use, JS_hum_use +!total number of reaches where human-induced will be used if in sub_riv +PetscInt :: IS_hum_bas, JS_hum_bas +!number of reaches with human-induced flow, within _riv. Calculated on the fly +!from hum_tot_if_file, hum_use_id_file and riv_bas_id_file +PetscInt, dimension(:), allocatable :: IV_hum_tot_id +!IDs of the reaches where human-induced flow data are available +PetscInt, dimension(:), allocatable :: IV_hum_use_id +!IDs of the reaches where human-induced flow data will be used if in sub_riv +PetscInt, dimension(:), allocatable :: IV_hum_bas_id +!IDs of the reaches where human-indeced flow data to be used is in sub_riv +PetscInt, allocatable, dimension(:) :: IV_hum_index +!vector where the Fortran 1-based indexes of the human-induced flow data are +!stored. This is of size IS_hum_bas and its elements belong to [1,IS_hum_tot]. +PetscInt, allocatable, dimension(:) :: IV_hum_loc1 +!vector where the C (0-based) vector indexes of where the above human-induced +!flow data are going to be applied. This is of size IS_hum_bas and its elements +!belong to [0,IS_riv_bas-1]. Applied on the river ID itself. + + +!******************************************************************************* +!Declaration of variables - Forcing flow variables +!******************************************************************************* +PetscInt :: IS_for_tot, JS_for_tot +!total number of reaches where forcing flow data are available. +PetscInt :: IS_for_use, JS_for_use +!total number of reaches where forcing will be used if in sub_riv +PetscInt :: IS_for_bas, JS_for_bas +!number of reaches forced by observations, within _riv. Calculated on the fly +!from for_tot_id_file, for_use_id_file and riv_bas_id_file +PetscInt, dimension(:), allocatable :: IV_for_tot_id +!IDs of the reaches where forcing flow data are available +PetscInt, dimension(:), allocatable :: IV_for_use_id +!IDs of the reaches where forcing flow data will be used if in sub_riv +PetscInt, dimension(:), allocatable :: IV_for_bas_id +!IDs of the reaches where forcing flow data to be used is in sub_riv +PetscInt, allocatable, dimension(:) :: IV_for_index +!vector where the Fortran 1-based indexes of the forcing flow data are +!available. This is of size IS_for_bas and its elements belong to [1,IS_for_tot] +PetscInt, allocatable, dimension(:) :: IV_for_loc2 +!vector where the C (0-based) vector indexes of where the above forcing +!flow data are going to be applied. This is of size IS_for_bas and its elements +!belong to [0,IS_riv_bas-1]. Applied on the river ID downstream. + + +!******************************************************************************* +!Declaration of variables - dam model flow variables +!******************************************************************************* +PetscInt :: IS_dam_tot, JS_dam_tot +!total number of reaches where dam model flow data are available. +PetscInt :: IS_dam_use, JS_dam_use +!total number of reaches where dam model will be used if in sub_riv +PetscInt :: IS_dam_bas, JS_dam_bas +!number of reaches forced by observations, within _riv. Calculated on the fly +!from dam_tot_id_file, dam_use_id_file and riv_bas_id_file. +PetscInt, dimension(:), allocatable :: IV_dam_tot_id +!IDs of the reaches where dam model flow data are available +PetscInt, dimension(:), allocatable :: IV_dam_use_id +!IDs of the reaches where dam model flow data will be used if in sub_riv +PetscInt, dimension(:), allocatable :: IV_dam_bas_id +!IDs of the reaches where dam model flow data to be used is in sub_riv +PetscInt, allocatable, dimension(:) :: IV_dam_index +!vector where the Fortran 1-based indexes of the dam model flow data are +!available. This is of size IS_dam_bas and its elements belong to [1,IS_dam_tot] +PetscInt, allocatable, dimension(:) :: IV_dam_loc2 +!vector where the C (0-based) vector indexes of where the above dam model +!flow data are going to be applied. This is of size IS_dam_bas and its elements +!belong to [0,IS_riv_bas-1]. Applied on the river ID downstream. +PetscInt, allocatable, dimension(:) :: IV_dam_pos +!vector where the Fortran 1-based vector indexes of where flows will be given to +!the above dam model. This is of size IS_dam_tot and its elements belong to +![1,IS_riv_bas] except when a dam ID is outside of basin studied where it is 0. +!Applied on the river ID itself. + +PetscScalar, allocatable, dimension(:) :: ZV_Qin_dam,ZV_Qin_dam_prev +PetscScalar, allocatable, dimension(:) :: ZV_Qout_dam,ZV_Qout_dam_prev +PetscScalar, allocatable, dimension(:) :: ZV_Qin_dam0,ZV_Qout_dam0 +!Fortran vectors where the inflows and outflows for the dam module are saved. +!These will be allocated to size IS_dam_tot + + +!******************************************************************************* +!Declaration of variables - Network matrix variables and routing variables +!******************************************************************************* +Mat :: ZM_Net +!Network matrix +Mat :: ZM_A +!Matrix used to solve linear system +Mat :: ZM_T +!Transboundary matrix +Mat :: ZM_TC1 +!Matrix used as a trick to solve linear system faster +Logical :: BS_logical +!Boolean used during network matrix creation to give warnings if connectivity pb + +Vec :: ZV_k,ZV_x +!Muskingum expression constants vectors, k in seconds, x has no dimension +Vec :: ZV_p, ZV_pnorm,ZV_pfac +!vector of the problem parameters, p=(k,x). normalized version and +!corresponding factors p=pnorm*pfac +Vec :: ZV_C1,ZV_C2,ZV_C3,ZV_Cdenom +!Muskingum method constants (last is the common denominator, for calculations) +Vec :: ZV_b,ZV_babsmax,ZV_bhat +!Used for linear system A*Qout=b + +!Input variables (contribution) +Vec :: ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam +!flowrates Qext is the sum of forced and lateral +Vec :: ZV_Vext,ZV_Vfor,ZV_Vlat +!volumes (same as above) + +!Main only variables +Vec :: ZV_QoutM,ZV_QoutinitM,ZV_QoutprevM,ZV_QoutbarM +Vec :: ZV_VM,ZV_VinitM,ZV_VprevM,ZV_VbarM + +!Optimization only variables +Vec :: ZV_QoutO,ZV_QoutinitO,ZV_QoutprevO,ZV_QoutbarO +Vec :: ZV_VO,ZV_VinitO,ZV_VprevO,ZV_VbarO + +!Routing only variables +Vec :: ZV_QoutR,ZV_QoutinitR,ZV_QoutprevR,ZV_QoutbarR,ZV_QoutRhat,ZV_QinbarR +Vec :: ZV_QoutRabsmin,ZV_QoutRabsmax +Vec :: ZV_VR,ZV_VinitR,ZV_VprevR,ZV_VbarR +Vec :: ZV_VoutR + + +!******************************************************************************* +!Declaration of variables - Observation matrix and optimization variables +!******************************************************************************* +Mat :: ZM_Obs +!Observation matrix +Vec :: ZV_Qobs +!Observation vector +PetscScalar :: ZS_norm +!norm of matrix ZM_Obs, used to calculate the number of gaging stations used + +PetscScalar :: ZS_phi,ZS_phitemp +!cost function +PetscInt :: IS_Iter +!number of iterations needed for optimization procedure to end +Vec :: ZV_temp1,ZV_temp2 +!temporary vectors, used for calculations +PetscScalar :: ZS_phifac +PetscInt :: IS_strt_opt +!first time step at which Vlat data is read during optimization + +Vec :: ZV_kfac +!Vector of size IS_riv_bas a multiplication factor for k for all river reaches +!in _riv +Vec :: ZV_Qobsbarrec +!Vector with the reciprocal (1/xi) of the average observations + +PetscScalar :: ZS_knorm, ZS_xnorm +!constants (k,x) in Muskingum expression, normalized +PetscScalar :: ZS_knorm_init, ZS_xnorm_init +!constants (k,x) in Muskingum expression, normalized, initial values for opt. +PetscScalar, parameter :: ZS_kfac=3600,ZS_xfac=0.1 +!corresponding factors, k in seconds, x has no dimension +PetscScalar :: ZS_k,ZS_x +!constants (k,x) in Muskingum expression. k in seconds, x has no dimension + + +!******************************************************************************* +!Declaration of variables - routing parameters and initial values +!******************************************************************************* +PetscScalar :: ZS_V0=10000,ZS_Qout0=0 +!values to be used in the intitial state of V and Qout for river routing +!initial volume for each reach (m^3), initial outflow for each reach (m^3/s) + + +!******************************************************************************* +!Declaration of variables - PETSc specific objects and variables +!******************************************************************************* +PetscErrorCode :: ierr +!needed for error check of PETSc functions +KSP :: ksp +!object used for linear system solver +PC :: pc +!preconditioner object +PetscMPIInt :: rank +!integer where the number of each processor is stored, 0 will be main processor +PetscMPIInt :: ncore +!integer where the number of cores used is stored +VecScatter :: vecscat +!Allows for scattering and gathering vectors from in parallel environement +PetscLogEvent :: stage +!Stage for investigating performance + +PetscInt :: IS_ksp_iter, IS_ksp_iter_max +!integer where the number of iterations in KSP is solved +PetscInt :: IS_one=1 +!integer of value 1. to be used in MatSetValues and VecSet. Directly using +!the value 1 in the functions crashes PETSc +PetscScalar :: ZS_one=1 +!Scalars of values 1 and 0, same remark as above +PetscScalar :: ZS_val +!Temporary scalar used to store the results of MatGetValues() +Vec :: ZV_one +!vector with only ones, useful for creation of matrices here +Vec :: ZV_SeqZero +!Sequential vector of size IS_riv_bas, allows for gathering data on zeroth +!precessor before writing in file + +PetscScalar,dimension(:), allocatable :: ZV_read_riv_tot +!temp vector that stores information from a 'read', before setting the value +!in the object, this vector has the size of the total number of reaches +PetscScalar,dimension(:), allocatable :: ZV_read_obs_tot +!same as previous, with size IS_obs_tot +PetscScalar,dimension(:), allocatable :: ZV_read_hum_tot +!same as previous, with size IS_hum_tot +PetscScalar,dimension(:), allocatable :: ZV_read_for_tot +!same as previous, with size IS_for_tot +PetscScalar,dimension(:), allocatable :: ZV_read_dam_tot +!same as previous, with size IS_dam_tot +PetscScalar :: ZS_time1, ZS_time2, ZS_time3 +!to estimate computing time + +PetscScalar, pointer :: ZV_pointer(:) +!used to point to a PETSc vector and to output formatted as needed in a file +character(len=10) :: temp_char,temp_char2 +!usefull to print variables on output. write a variable in this character and +!then use PetscPrintf + +PetscInt, dimension(:), allocatable :: IV_nz, IV_dnz, IV_onz +!number of nonzero elements per row for network matrix. nz for sequential, dnz +!and onz for distributed matrix (diagonal and off-diagonal elements) +PetscInt :: IS_ownfirst, IS_ownlast +!Ownership of each processor + + +!******************************************************************************* +!Declaration of variables - TAO specific objects and variables +!******************************************************************************* +#ifndef NO_TAO +TaoSolver :: tao +!TAO solver object +TaoSolverTerminationReason :: reason +!TAO terminate reason object +Vec :: ZV_1stIndex, ZV_2ndIndex +!ZV_1stIndex=[1;0], ZV_2ndIndex=[0,1]. Used with VecDot to extract first and +!second indexes of the vector of parameter +#endif + + +!******************************************************************************* +!Declaration of variables - netCDF variables +!******************************************************************************* +PetscInt :: IS_nc_status +PetscInt :: IS_nc_id_fil_Vlat,IS_nc_id_fil_Qout +PetscInt :: IS_nc_id_var_Vlat,IS_nc_id_var_Qout,IS_nc_id_var_comid +PetscInt :: IS_nc_id_dim_comid,IS_nc_id_dim_time +PetscInt, parameter :: IS_nc_ndim=2 +PetscInt, dimension(IS_nc_ndim) :: IV_nc_id_dim, IV_nc_start, IV_nc_count, & + IV_nc_count2 + + +!******************************************************************************* +!Namelist +!******************************************************************************* +namelist /NL_namelist/ & + BS_opt_Qinit,BS_opt_Qfinal, & + BS_opt_hum,BS_opt_for,BS_opt_dam,BS_opt_influence, & + IS_opt_routing,IS_opt_run,IS_opt_phi, & + IS_riv_tot,rapid_connect_file,Vlat_file,IS_max_up, & + iS_riv_bas,riv_bas_id_file, & + Qinit_file,Qfinal_file, & + Qhum_file, & + IS_hum_tot,hum_tot_id_file, & + IS_hum_use,hum_use_id_file, & + IS_for_tot,for_tot_id_file, & + Qfor_file, & + IS_for_use,for_use_id_file, & + IS_dam_tot,dam_tot_id_file, & + IS_dam_use,dam_use_id_file, & + babsmax_file,QoutRabsmin_file,QoutRabsmax_file, & + k_file,x_file,Qout_file, & + kfac_file,xfac_file,ZS_knorm_init,ZS_xnorm_init, & + IS_obs_tot,obs_tot_id_file,IS_obs_use,obs_use_id_file, & + Qobs_file,Qobsbarrec_file, & + ZS_TauM,ZS_dtM,ZS_TauO,ZS_dtO,ZS_TauR,ZS_dtR, & + ZS_dtF,ZS_dtH, & + ZS_phifac,IS_strt_opt + +character(len=120) :: namelist_file +!unit 88 - Namelist + + +end module rapid_var diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90 new file mode 100644 index 00000000..4f0a457e --- /dev/null +++ b/wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90 @@ -0,0 +1,82 @@ +!******************************************************************************* +!Subroutine - rapid_write_Qout_file +!******************************************************************************* +subroutine rapid_write_Qout_file + +!Purpose: +!Write into Qout_file from Fortran/netCDF. +!Author: +!Cedric H. David, 2013-2015. + + +!******************************************************************************* +!Global variables +!******************************************************************************* +use netcdf +use rapid_var, only : & + rank,ierr,vecscat,ZV_SeqZero,ZV_pointer, & + IS_nc_status,IS_nc_id_fil_Qout,IS_nc_id_var_Qout, & + IV_nc_start,IV_nc_count2, & + ZV_QoutbarR + +implicit none + + +!******************************************************************************* +!Includes +!******************************************************************************* +#include "finclude/petscsys.h" +!base PETSc routines +#include "finclude/petscvec.h" +#include "finclude/petscvec.h90" +!vectors, and vectors in Fortran90 +#include "finclude/petscmat.h" +!matrices +#include "finclude/petscksp.h" +!Krylov subspace methods +#include "finclude/petscpc.h" +!preconditioners +#include "finclude/petscviewer.h" +!viewers (allows writing results in file for example) +#include "finclude/petsclog.h" +!PETSc log + + +!******************************************************************************* +!Intent (in/out), and local variables +!******************************************************************************* + + +!******************************************************************************* +!Gather PETSc vector on processor zero +!******************************************************************************* +call VecScatterBegin(vecscat,ZV_QoutbarR,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) +call VecScatterEnd(vecscat,ZV_QoutbarR,ZV_SeqZero, & + INSERT_VALUES,SCATTER_FORWARD,ierr) + + +!******************************************************************************* +!Get array from PETSc vector +!******************************************************************************* +if (rank==0) call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr) + + +!******************************************************************************* +!Write data +!******************************************************************************* +if (rank==0) IS_nc_status=NF90_PUT_VAR(IS_nc_id_fil_Qout,IS_nc_id_var_Qout, & + ZV_pointer,IV_nc_start,IV_nc_count2) + + +!******************************************************************************* +!Restore array to PETSc vector +!******************************************************************************* +if (rank==0) call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr) + + +!******************************************************************************* +!End +!******************************************************************************* + +end subroutine rapid_write_Qout_file diff --git a/wrfv2_fire/hydro/Routing/Makefile b/wrfv2_fire/hydro/Routing/Makefile new file mode 100644 index 00000000..b20304ef --- /dev/null +++ b/wrfv2_fire/hydro/Routing/Makefile @@ -0,0 +1,99 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = \ + module_date_utilities_rt.o \ + module_UDMAP.o \ + module_HYDRO_utils.o \ + module_noah_chan_param_init_rt.o \ + module_GW_baseflow.o \ + module_gw_gw2d.o \ + module_HYDRO_io.o \ + module_RT.o \ + Noah_distr_routing.o \ + module_channel_routing.o \ + module_lsm_forcing.o \ + module_date_utilities_rt.o + +all: $(OBJS) + +#module_RT.o: module_RT.F +# @echo "" +# $(CPP) $(CPPFLAGS) $(*).F > $(*).f +# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f +# $(RMD) $(*).f +# @echo "" +# cp *.mod ../mod + +.F.o: + @echo "Routing Makefile:" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f +# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).f +# $(RMD) $(*).f + @echo "" + ar -r ../lib/libHYDRO.a $(@) + cp *.mod ../mod + +# +# Dependencies: +# +module_gw_gw2d.o: ../Data_Rec/module_gw_gw2d_data.o module_HYDRO_io.o + +ifneq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING) +module_HYDRO_io.o: module_HYDRO_utils.o \ + module_date_utilities_rt.o \ + ../Data_Rec/module_namelist.o \ + ../Data_Rec/module_RT_data.o +else +module_HYDRO_io.o: module_HYDRO_utils.o \ + module_date_utilities_rt.o \ + ../nudging/module_date_utils_nudging.o \ + ../nudging/module_nudging_io.o \ + ../Data_Rec/module_namelist.o \ + ../Data_Rec/module_RT_data.o +endif + +module_HYDRO_utils.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o + +module_lsm_forcing.o: module_HYDRO_io.o + +ifneq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING) +module_RT.o: module_GW_baseflow.o \ + module_HYDRO_utils.o \ + module_HYDRO_io.o \ + module_noah_chan_param_init_rt.o \ + module_UDMAP.o \ + ../Data_Rec/module_namelist.o \ + ../Data_Rec/module_RT_data.o \ + ../Data_Rec/module_gw_gw2d_data.o +else +module_RT.o: module_GW_baseflow.o \ + module_HYDRO_utils.o \ + module_HYDRO_io.o \ + module_noah_chan_param_init_rt.o \ + module_UDMAP.o \ + ../Data_Rec/module_namelist.o \ + ../Data_Rec/module_RT_data.o \ + ../Data_Rec/module_gw_gw2d_data.o \ + ../nudging/module_date_utils_nudging.o \ + ../nudging/module_nudging_io.o +endif + +module_UDMAP.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o + +ifneq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING) +module_channel_routing.o: module_UDMAP.o +else +module_channel_routing.o: module_UDMAP.o\ + ../nudging/module_date_utils_nudging.o \ + ../nudging/module_nudging_utils.o \ + ../nudging/module_stream_nudging.o +endif + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Routing/Noah_distr_routing.F b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F new file mode 100644 index 00000000..07f62414 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F @@ -0,0 +1,3007 @@ +! Program Name: +! 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: + +!DJG ------------------------------------------------ +!DJG SUBROUTINE RT_PARM +!DJG ------------------------------------------------ + + SUBROUTINE RT_PARM(IX,JY,IXRT,JXRT,VEGTYP,RETDP,OVRGH, & + AGGFACTR) +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real,MPP_LAND_UB_COM, & + MPP_LAND_LR_COM,mpp_land_com_integer +#endif + + IMPLICIT NONE + +!DJG -------- DECLARATIONS ----------------------- + + INTEGER, INTENT(IN) :: IX,JY,IXRT,JXRT,AGGFACTR + + INTEGER, INTENT(IN), DIMENSION(IX,JY) :: VEGTYP + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: RETDP + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH + + +!DJG Local Variables + + INTEGER :: I,J,IXXRT,JYYRT + INTEGER :: AGGFACYRT,AGGFACXRT + + +!DJG Assign RETDP and OVRGH based on VEGTYP... + + do J=1,JY + do I=1,IX + + do AGGFACYRT=AGGFACTR-1,0,-1 + do AGGFACXRT=AGGFACTR-1,0,-1 + + IXXRT=I*AGGFACTR-AGGFACXRT + JYYRT=J*AGGFACTR-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + +! if(AGGFACTR .eq. 1) then +! IXXRT=I +! JYYRT=J +! endif + + + +!DJG Urban, rock, playa, snow/ice... + IF (VEGTYP(I,J).EQ.1.OR.VEGTYP(I,J).EQ.26.OR. & + VEGTYP(I,J).EQ.26.OR.VEGTYP(I,J).EQ.24) THEN + RETDP(IXXRT,JYYRT)=1.3 + OVRGH(IXXRT,JYYRT)=0.1 +!DJG Wetlands and water bodies... + ELSE IF (VEGTYP(I,J).EQ.17.OR.VEGTYP(I,J).EQ.18.OR. & + VEGTYP(I,J).EQ.19.OR.VEGTYP(I,J).EQ.16) THEN + RETDP(IXXRT,JYYRT)=10.0 + OVRGH(IXXRT,JYYRT)=0.2 +!DJG All other natural covers... + ELSE + RETDP(IXXRT,JYYRT)=5.0 + OVRGH(IXXRT,JYYRT)=0.2 + END IF + + end do + end do + + end do + end do +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(RETDP,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(OVRGH,IXRT,JXRT,99) +#endif + +!DJG ---------------------------------------------------------------- + END SUBROUTINE RT_PARM +!DJG ---------------------------------------------------------------- + + + + + +!DJG ------------------------------------------------ +!DJG SUBROUTINE SUBSFC_RTNG +!DJG ------------------------------------------------ + + SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT, & + SOYRT,LATKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT, & + NSOIL,SMCRT,INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT, & + SMCWLTRT,SO8RT,SO8RT_D, rt_option,SLDPTH,junk4,CWATAVAIL, & + SATLYRCHK) + +! use module_mpp_land, only: write_restart_rt_3, write_restart_rt_2, & +! my_id +#ifdef MPP_LAND + use module_mpp_land, only: MPP_LAND_COM_REAL, sum_real1, & + my_id, io_id, numprocs +#endif + IMPLICIT NONE + +!DJG -------- DECLARATIONS ------------------------ + + INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,junk4 + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LATKSATRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOLDEPRT + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ZWATTABLRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: CWATAVAIL + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: SATLYRCHK + + + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT + + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) + REAL, INTENT(IN) :: DT + REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL + REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH + REAL, INTENT(INOUT) :: QSUBBDRYTRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: INFXSUBRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT + + REAL, DIMENSION(IXRT,JXRT) :: ywtmp +!DJG Local Variables + + INTEGER :: I,J,KK +!djg INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK + + REAL :: GRDAREA + REAL :: SUBFLO + REAL :: WATAVAIL + + INTEGER :: SO8RT_D(IXRT,JXRT,3) + REAL :: SO8RT(IXRT,JXRT,8) + integer :: rt_option, index + + INTEGER :: DT_STEPS !-- number of timestep in routing + REAL :: SUBDT !-- subsurface routing timestep + INTEGER :: KRT !-- routing counter + REAL, DIMENSION(IXRT,JXRT,NSOIL) :: SMCTMP !--temp store of SMC + REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRTTMP ! temp store of ZWAT + REAL, DIMENSION(IXRT,JXRT) :: INFXSUBRTTMP ! temp store of infilx +!djg REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL ! temp specif. of wat avial + + + +!DJG Debug Variables... + REAL :: qsubchk,qsubbdrytmp + REAL :: junk1,junk2,junk3,junk5,junk6,junk7 + INTEGER, PARAMETER :: double=8 + REAL (KIND=double) :: smctot1a,smctot2a + INTEGER :: kx,count + +#ifdef HYDRO_D +! ADCHANGE: Water balance variables + real :: smctot1,smctot2 + real :: suminfxsrt1,suminfxsrt2 + real :: qbdry1,qbdry2 + real :: sumqsubrt1, sumqsubrt2 +#endif + +!DJG ----------------------------------------------------------------- +!DJG SUBSURFACE ROUTING LOOP +!DJG - SUBSURFACE ROUTING RUN ON NOAH TIMESTEP +!DJG - SUBSURFACE ROUITNG ONLY PERFORMED ON SATURATED LAYERS +!DJG ----------------------------------------------------------------- + +#ifdef HYDRO_D +! ADCHANGE: START Initial water balance variables +! ALL VARS in MM + suminfxsrt1 = 0. + qbdry1 = 0. + smctot1 = 0. + sumqsubrt1 = 0. + do i=1,IXRT + do j=1,JXRT + suminfxsrt1 = suminfxsrt1 + INFXSUBRT(I,J) / float(IXRT*JXRT) + qbdry1 = qbdry1 + QSUBBDRYRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT) + sumqsubrt1 = sumqsubrt1 + QSUBRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT) + do kk=1,NSOIL + smctot1 = smctot1 + SMCRT(I,J,KK)*SLDPTH(KK)*1000. / float(IXRT*JXRT) + end do + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxsrt1) + CALL sum_real1(qbdry1) + CALL sum_real1(sumqsubrt1) + CALL sum_real1(smctot1) + suminfxsrt1 = suminfxsrt1/float(numprocs) + qbdry1 = qbdry1/float(numprocs) + sumqsubrt1 = sumqsubrt1/float(numprocs) + smctot1 = smctot1/float(numprocs) +#endif +! END Initial water balance variables +#endif + + + !yw GRDAREA=DXRT*DXRT + ! GRDAREA=dist(i,j,9) + + +!DJG debug subsfc... + subflo = 0.0 + +!DJG Set up mass balance checks... +! CWATAVAIL = 0. !-- initialize subsurface watavail + SUBDT = DT !-- initialize the routing timestep to DT + + +!!!! Find saturated layer depth... +! Loop through domain to determine sat. layers and assign wat tbl depth... +! and water available for subsfc routing (CWATAVAIL)... +! +! CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & +! SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & +! CWATAVAIL,SLDPTH) + + + + +!DJG debug variable... + +!DJG Courant check temp variable setup... + ZWATTABLRTTMP = ZWATTABLRT !-- temporary storage of water table level + + + + +!!!! Call subsurface routing subroutine... +#ifdef HYDRO_D + print *, "calling subsurface routing subroutine...Opt. ",rt_option +#endif + + + if(rt_option .eq. 1) then + CALL ROUTE_SUBSURFACE1(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & + LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & + SO8RT,SO8RT_D,CWATAVAIL,SUBDT) + else + CALL ROUTE_SUBSURFACE2(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & + LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & + CWATAVAIL,SUBDT) + end if + +#ifdef HYDRO_D + write(6,*) "finish calling ROUTE_SUBSURFACE ", rt_option +#endif + + +!!!! Update soil moisture fields with subsurface flow... + +!!!! Loop through subsurface routing domain... + DO I=1,IXRT + DO J=1,JXRT + +!!DJG Check for courant condition violation...put limit on qsub +!!DJG QSUB HAS units of m^3/s SUBFLO has units of m + +! ADCHANGE: Moved this constraint to the ROUTE_SUBSURFACE routines + !IF (CWATAVAIL(i,j).le.ABS(qsubrt(i,j))/dist(i,j,9)*SUBDT) THEN + ! QSUBRT(i,j) = -1.0*CWATAVAIL(i,j) + ! SUBFLO = QSUBRT(i,j) !Units of qsubrt converted via CWATAVAIL + !ELSE + SUBFLO=QSUBRT(I,J)/dist(i,j,9)*SUBDT !Convert qsubrt from m^3/s to m + !END IF + + WATAVAIL=0. !Initialize to 0. for every cell... + + +!!DJG Begin loop through soil profile to adjust soil water content +!!DJG based on subsfc flow (SUBFLO)... + + IF (SUBFLO.GT.0) THEN ! Increase soil moist for +SUBFLO (Inflow) + +! Loop through soil layers from bottom to top + DO KK=NSOIL,1,-1 + + +! Check for saturated layers + IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK)) THEN + IF (SMCRT(I,J,KK).GT.SMCMAXRT(I,J,KK)) THEN + print *, "FATAL ERROR: Subsfc acct. SMCMAX exceeded...", & + SMCRT(I,J,KK), SMCMAXRT(I,J,KK),KK,i,j + call hydro_stop("In SUBSFC_RTNG() - SMCMAX exceeded") + ELSE + END IF + ELSE + WATAVAIL = (SMCMAXRT(I,J,KK)-SMCRT(I,J,KK))*SLDPTH(KK) + IF (WATAVAIL.GE.SUBFLO) THEN + SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) + SUBFLO = 0. + ELSE + SUBFLO = SUBFLO - WATAVAIL + SMCRT(I,J,KK) = SMCMAXRT(I,J,KK) + END IF + END IF + + IF (SUBFLO.EQ.0.) EXIT +! IF (SUBFLO.EQ.0.) goto 669 + + END DO ! END DO FOR SOIL LAYERS + +669 continue + +! If all layers sat. add remaining subflo to infilt. excess... + IF (KK.eq.0.AND.SUBFLO.gt.0.) then + INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO*1000. !Units = mm + SUBFLO=0. + END IF + +!DJG Error trap... + if (subflo.ne.0.) then +#ifdef HYDRO_D + print *, "Subflo (+) not expired...:",subflo,i,j,kk,SMCRT(i,j,1), & + SMCRT(i,j,2),SMCRT(i,j,3),SMCRT(i,j,4),SMCRT(i,j,5), & + SMCRT(i,j,6),SMCRT(i,j,7),SMCRT(i,j,8),"SMCMAX",SMCMAXRT(i,j,1) +#endif + end if + + + ELSE IF (SUBFLO.LT.0) THEN ! Decrease soil moist for -SUBFLO (Drainage) + + +!DJG loop from satlyr back down and subtract out subflo as necess... +! now set to SMCREF, 8/24/07 +!DJG and then using unsat cond as opposed to Ksat... + + DO KK=SATLYRCHK(I,J),NSOIL + WATAVAIL = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) + IF (WATAVAIL.GE.ABS(SUBFLO)) THEN +!?yw mod IF (WATAVAIL.GE.(ABS(SUBFLO)+0.000001) ) THEN + SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) + SUBFLO=0. + ELSE ! Since subflo is small on a time-step following is unlikely... + SMCRT(I,J,KK)=SMCREFRT(I,J,KK) + SUBFLO=SUBFLO+WATAVAIL + END IF + IF (SUBFLO.EQ.0.) EXIT +! IF (SUBFLO.EQ.0.) goto 668 + + END DO ! END DO FOR SOIL LAYERS +668 continue + + +!DJG Error trap... + if(abs(subflo) .le. 1.E-7 ) subflo = 0.0 !truncate residual to 1E-7 prec. + + if (subflo.ne.0.) then +#ifdef HYDRO_D + print *, "Subflo (-) not expired:",i,j,subflo,CWATAVAIL(i,j) + print *, "zwatabl = ", ZWATTABLRT(I,J) + print *, "QSUBRT(I,J)=",QSUBRT(I,J) + print *, "WATAVAIL = ",WATAVAIL, "kk=",kk + print * +#endif + end if + + + + END IF ! end if for +/- SUBFLO soil moisture accounting... + + + + + END DO ! END DO X dim + END DO ! END DO Y dim +!!!! End loop through subsurface routing domain... + +#ifdef MPP_LAND + do i = 1, NSOIL + call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) + end DO +#endif + +#ifdef HYDRO_D +! ADCHANGE: START Final water balance variables +! ALL VARS in MM + suminfxsrt2 = 0. + qbdry2 = 0. + smctot2 = 0. + sumqsubrt2 = 0. + do i=1,IXRT + do j=1,JXRT + suminfxsrt2 = suminfxsrt2 + INFXSUBRT(I,J) / float(IXRT*JXRT) + qbdry2 = qbdry2 + QSUBBDRYRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT) + sumqsubrt2 = sumqsubrt2 + QSUBRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT) + do kk=1,NSOIL + smctot2 = smctot2 + SMCRT(I,J,KK)*SLDPTH(KK)*1000. / float(IXRT*JXRT) + end do + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxsrt2) + CALL sum_real1(qbdry2) + CALL sum_real1(sumqsubrt2) + CALL sum_real1(smctot2) + suminfxsrt2 = suminfxsrt2/float(numprocs) + qbdry2 = qbdry2/float(numprocs) + sumqsubrt2 = sumqsubrt2/float(numprocs) + smctot2 = smctot2/float(numprocs) +#endif + +#ifdef MPP_LAND + if (my_id .eq. IO_id) then +#endif + print *, "SUBSFC Routing Mass Bal: " + print *, "WB_SUB!QsubDiff", sumqsubrt2-sumqsubrt1 + print *, "WB_SUB!Qsub1", sumqsubrt1 + print *, "WB_SUB!Qsub2", sumqsubrt2 + print *, "WB_SUB!InfxsDiff", suminfxsrt2-suminfxsrt1 + print *, "WB_SUB!Infxs1", suminfxsrt1 + print *, "WB_SUB!Infxs2", suminfxsrt2 + print *, "WB_SUB!QbdryDiff", qbdry2-qbdry1 + print *, "WB_SUB!Qbdry1", qbdry1 + print *, "WB_SUB!Qbdry2", qbdry2 + print *, "WB_SUB!SMCDiff", smctot2-smctot1 + print *, "WB_SUB!SMC1", smctot1 + print *, "WB_SUB!SMC2", smctot2 + print *, "WB_SUB!Residual", sumqsubrt1 - ( (suminfxsrt2-suminfxsrt1) & + + (smctot2-smctot1) ) +#ifdef MPP_LAND + endif +#endif +! END Final water balance variables +#endif + + +!DJG ---------------------------------------------------------------- + END SUBROUTINE SUBSFC_RTNG +!DJG ---------------------------------------------------------------- + + +!DJG ------------------------------------------------------------------------ +!DJG SUBSURFACE FINDZWAT +!DJG ------------------------------------------------------------------------ + SUBROUTINE FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & + SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT,CWATAVAIL,& + SLDPTH) + + IMPLICIT NONE + +!DJG -------- DECLARATIONS ------------------------ + + INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT + REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL + REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: ZWATTABLRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CWATAVAIL + INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SATLYRCHK + +!DJG Local Variables + INTEGER :: KK,i,j + + +!!!! Find saturated layer depth... +! Loop through domain to determine sat. layers and assign wat tbl depth... + + + SATLYRCHK = 0 !set flag for sat. layers + CWATAVAIL = 0. !set wat avail for subsfc rtng = 0. + + DO J=1,JXRT + DO I=1,IXRT + +! Loop through soil layers from bottom to top + DO KK=NSOIL,1,-1 + +! Check for saturated layers +! Add additional logical check to ensure water is 'available' for routing, +! (i.e. not 'frozen' or otherwise immobile) +! IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK).AND.SMCMAXRT(I,J,KK) & +! .GT.SMCWLTRT(I,J,KK)) THEN + IF ( (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK)).AND.(SMCREFRT(I,J,KK) & + .GT.SMCWLTRT(I,J,KK)) ) THEN +! Add additional check to ensure saturation from bottom up only...8/8/05 + IF((SATLYRCHK(I,J).EQ.KK+1) .OR. (KK.EQ.NSOIL) ) SATLYRCHK(I,J) = KK + END IF + + END DO + + +! Designate ZWATTABLRT based on highest sat. layer and +! Define amount of water avail for subsfc routing on each gridcell (CWATAVAIL) +! note: using a 'field capacity' value of SMCREF as lower limit... + + IF (SATLYRCHK(I,J).ne.0) then + IF (SATLYRCHK(I,J).ne.1) then ! soil column is partially sat. + ZWATTABLRT(I,J) = -ZSOIL(SATLYRCHK(I,J)-1) +!DJG 2/16/2016 fix DO KK=SATLYRCHK(I,J),NSOIL +!old CWATAVAIL(I,J) = (SMCRT(I,J,SATLYRCHK(I,J))-& +!old SMCREFRT(I,J,SATLYRCHK(I,J))) * & +!old (ZSOIL(SATLYRCHK(I,J)-1)-ZSOIL(NSOIL)) +!DJG 2/16/2016 fix CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- & +!DJG 2/16/2016 fix SMCREFRT(I,J,KK))*SLDPTH(KK) +!DJG 2/16/2016 fix END DO + + + ELSE ! soil column is fully saturated to sfc. + ZWATTABLRT(I,J) = 0. +!DJG 2/16/2016 fix DO KK=SATLYRCHK(I,J),NSOIL +!DJG 2/16/2016 fix CWATAVAIL(I,J) = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) +!DJG 2/16/2016 fix END DO + END IF +!DJG 2/16/2016 fix accumulation of CWATAVAIL... + DO KK=SATLYRCHK(I,J),NSOIL + CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- & + SMCREFRT(I,J,KK))*SLDPTH(KK) + END DO + ELSE ! no saturated layers... + ZWATTABLRT(I,J) = -ZSOIL(NSOIL) + SATLYRCHK(I,J) = NSOIL + 1 + END IF + + + END DO + END DO + + +!DJG ---------------------------------------------------------------- + END SUBROUTINE FINDZWAT +!DJG ---------------------------------------------------------------- + + +!DJG ---------------------------------------------------------------- +!DJG ---------------------------------------------------------------- +!DJG SUBROUTINE ROUTE_SUBSURFACE2 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_SUBSURFACE2( & + dist,z,qsub,sox,soy, & + latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,CWATAVAIL, & + SUBDT) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route subsurface flow through the watershed +!DJG ---------------------------------------------------------------- +! +! Called from: main.f (Noah_router_driver) +! +! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. +! +! Created: D. Gochis 3/27/03 +! Adaptded from Wigmosta, 1994 +! +! Modified: D. Gochis 1/05/04 +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real,MPP_LAND_UB_COM, & + MPP_LAND_LR_COM,mpp_land_com_integer +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + INTEGER, INTENT(IN) :: XX,YY + +!! Declare passed arrays + + REAL, INTENT(IN), DIMENSION(XX,YY) :: z + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat + REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL + REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep + REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY + REAL, INTENT(INOUT) :: QSUBDRYT + REAL, INTENT(IN) :: SUBDT + real, intent(in), dimension(xx,yy,9) :: dist + +!!! Declare Local Variables + + REAL :: dzdx,dzdy,beta,gamma + REAL :: qqsub,hh,ksat, gsize + + INTEGER :: i,j +!!! Initialize variables + REAL, PARAMETER :: nexp=1.0 ! local power law exponent + qsub = 0. ! initialize flux = 0. !DJG 5 May 2014 + +!yw soldep = 2. + + +! Begin Subsurface routing + +!!! Loop to route water in x-direction + do j=1,YY + do i=1,XX +! check for boundary grid point? + if (i.eq.XX) GOTO 998 + gsize = dist(i,j,3) + + dzdx= (z(i,j) - z(i+1,j))/gsize + beta=sox(i,j) + dzdx + 1E-30 + if (abs(beta) .lt. 1E-20) beta=1E-20 + if (beta.lt.0) then +!yw hh=(1-(z(i+1,j)/soldep(i,j)))**nexp + hh=(1-(z(i+1,j)/soldep(i+1,j)))**nexp +! Change later to use mean Ksat of two cells + ksat=latksat(i+1,j) + else + hh=(1-(z(i,j)/soldep(i,j)))**nexp + ksat=latksat(i,j) + end if + + if (hh .lt. 0.) then + print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & + soldep(i,j),nexp + call hydro_stop("In ROUTE_SUBSURFACE2() - hsub<0 at gridcell") + end if + +!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) +!AD_CHANGE: beta is already a slope so no tan (consistent with ROUTE_SUBSURFACE1) + gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta +!DJG lacks tan(beta) of original Wigmosta version gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta + + qqsub = gamma * hh + qsub(i,j) = qsub(i,j) + qqsub + qsub(i+1,j) = qsub(i+1,j) - qqsub + +! Boundary adjustments +#ifdef MPP_LAND + if ((i.eq.1).AND.(beta.lt.0.).and.(left_id.lt.0)) then +#else + if ((i.eq.1).AND.(beta.lt.0.)) then +#endif + qsub(i,j) = qsub(i,j) - qqsub + QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub + QSUBDRYT = QSUBDRYT - qqsub +#ifdef MPP_LAND + else if ((i.eq.(xx-1)).AND.(beta.gt.0.) & + .and.(right_id.lt.0) ) then +#else + else if ((i.eq.(xx-1)).AND.(beta.gt.0.)) then +#endif + qsub(i+1,j) = qsub(i+1,j) + qqsub + QSUBDRY(i+1,j) = QSUBDRY(i+1,j) + qqsub + QSUBDRYT = QSUBDRYT + qqsub + end if + +998 continue + +!! End loop to route sfc water in x-direction + end do + end do + +#ifdef MPP_LAND + call MPP_LAND_LR_COM(qsub,XX,YY,99) + call MPP_LAND_LR_COM(QSUBDRY,XX,YY,99) +#endif + + +!!! Loop to route water in y-direction + do j=1,YY + do i=1,XX +! check for boundary grid point? + if (j.eq.YY) GOTO 999 + gsize = dist(i,j,1) + + dzdy= (z(i,j) - z(i,j+1))/gsize + beta=soy(i,j) + dzdy + 1E-30 + if (abs(beta) .lt. 1E-20) beta=1E-20 + if (beta.lt.0) then +!yw hh=(1-(z(i,j+1)/soldep(i,j)))**nexp + hh=(1-(z(i,j+1)/soldep(i,j+1)))**nexp + ksat=latksat(i,j+1) + else + hh=(1-(z(i,j)/soldep(i,j)))**nexp + ksat=latksat(i,j) + end if + + if (hh .lt. 0.) GOTO 999 + +!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) + gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta + + qqsub = gamma * hh + qsub(i,j) = qsub(i,j) + qqsub + qsub(i,j+1) = qsub(i,j+1) - qqsub + +! Boundary adjustments + +#ifdef MPP_LAND + if ((j.eq.1).AND.(beta.lt.0.).and.(down_id.lt.0)) then +#else + if ((j.eq.1).AND.(beta.lt.0.)) then +#endif + qsub(i,j) = qsub(i,j) - qqsub + QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub + QSUBDRYT = QSUBDRYT - qqsub +#ifdef MPP_LAND + else if ((j.eq.(yy-1)).AND.(beta.gt.0.) & + .and. (up_id.lt.0) ) then +#else + else if ((j.eq.(yy-1)).AND.(beta.gt.0.)) then +#endif + qsub(i,j+1) = qsub(i,j+1) + qqsub + QSUBDRY(i,j+1) = QSUBDRY(i,j+1) + qqsub + QSUBDRYT = QSUBDRYT + qqsub + end if + +999 continue + +!! End loop to route sfc water in y-direction + end do + end do + +#ifdef MPP_LAND + call MPP_LAND_UB_COM(qsub,XX,YY,99) + call MPP_LAND_UB_COM(QSUBDRY,XX,YY,99) +#endif + + return +!DJG------------------------------------------------------------ + end subroutine ROUTE_SUBSURFACE2 +!DJG------------------------------------------------------------ + + + +!DJG ------------------------------------------------ +!DJG SUBROUTINE OV_RTNG +!DJG ------------------------------------------------ + + SUBROUTINE OV_RTNG(DT,DTRT_TER,IXRT,JXRT,INFXSUBRT, & + SFCHEADSUBRT,DHRT,CH_NETRT,RETDEPRT,OVROUGHRT, & + QSTRMVOLRT,QBDRYRT,QSTRMVOLTRT,QBDRYTRT,SOXRT, & + SOYRT,dist,LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT, & + SO8RT,SO8RT_D,rt_option,q_sfcflx_x,q_sfcflx_y) + +!yyww +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id, & + up_id,mpp_land_com_real, my_id, & + mpp_land_sync +#endif + + IMPLICIT NONE + +!DJG --------DECLARATIONS---------------------------- + + INTEGER, INTENT(IN) :: IXRT,JXRT + REAL, INTENT(IN) :: DT,DTRT_TER + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: RETDEPRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: OVROUGHRT + + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: DHRT + + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_INFLORT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QBDRYRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: q_sfcflx_x,q_sfcflx_y + REAL, INTENT(INOUT) :: QSTRMVOLTRT,QBDRYTRT,LAKE_INFLOTRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT + +!DJG Local Variables + + INTEGER :: KRT,I,J,ct + + REAL, DIMENSION(IXRT,JXRT) :: INFXS_FRAC + REAL :: DT_FRAC,SUM_INFXS,sum_head + INTEGER SO8RT_D(IXRT,JXRT,3), rt_option + + + + +!DJG ---------------------------------------------------------------------- +! DJG BEGIN 1-D or 2-D OVERLAND FLOW ROUTING LOOP +!DJG --------------------------------------------------------------------- +!DJG Loop over 'routing time step' +!DJG Compute the number of time steps based on NOAH DT and routing DTRT_TER + + DT_FRAC=INT(DT/DTRT_TER) + +#ifdef HYDRO_D + write(6,*) "OV_RTNG DT_FRAC, DT, DTRT_TER",DT_FRAC, DT, DTRT_TER + write(6,*) "IXRT, JXRT = ",ixrt,jxrt +#endif + +!DJG NOTE: Applying all infiltration excess water at once then routing +!DJG Pre-existing SFHEAD gets combined with Precip. in the +!DJG calculation of INFXS1 during subroutine SRT.f. +!DJG debug + + +!DJG Assign all infiltration excess to surface head... + SFCHEADSUBRT=INFXSUBRT + +!DJG Divide infiltration excess over all routing time-steps +! INFXS_FRAC=INFXSUBRT/(DT/DTRT_TER) + +!DJG Set flux accumulation fields to 0. before each loop... + q_sfcflx_x = 0. + q_sfcflx_y = 0. + ct =0 + + +!DJG Execute routing time-step loop... + + + DO KRT=1,DT_FRAC + + DO J=1,JXRT + DO I=1,IXRT + +!DJG Removed 4_29_05, sfhead now updated in route_overland subroutine... +! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J) +!! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)+INFXS_FRAC(I,J) +! DHRT(I,J)=0. + +!DJG ERROR Check... + + IF (SFCHEADSUBRT(I,J).lt.0.) THEN +#ifdef HYDRO_D + print *, "ywcheck 2 ERROR!!!: Neg. Surface Head Value at (i,j):", & + i,j,SFCHEADSUBRT(I,J) + print *, "RETDEPRT(I,J) = ",RETDEPRT(I,J), "KRT=",KRT + print *, "INFXSUBRT(i,j)=",INFXSUBRT(i,j) + print *, "jxrt=",jxrt," ixrt=",ixrt +#endif + END IF + +!DJG Remove surface water from channel cells +!DJG Channel inflo cells specified as nonzeros from CH_NET +!DJG 9/16/04 Channel Extractions Removed until stream model implemented... + + + +!yw IF (CH_NETRT(I,J).ne.-9999) THEN + IF (CH_NETRT(I,J).ge.0) THEN + ct = ct +1 + +!DJG Temporary test to up the retention depth of channel grid cells to 'soak' +!more water into valleys....set retdep = retdep*100 (=5 mm) + +! RETDEPRT(I,J) = RETDEPRT(I,J) * 100.0 !DJG TEMP HARDWIRE!!!! +! RETDEPRT(I,J) = 10.0 !DJG TEMP HARDWIRE!!!! + + IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN +!! QINFLO(CH_NET(I,J)=QINFLO(CH_NET(I,J)+SFCHEAD(I,J) - RETDEPRT(I,J) + QSTRMVOLTRT = QSTRMVOLTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) + QSTRMVOLRT(I,J) = QSTRMVOLRT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) + + ! if(QSTRMVOLRT(I,J) .gt. 0) then + ! print *, "QSTRVOL GT 0", QSTRMVOLRT(I,J),I,J + ! endif + + SFCHEADSUBRT(I,J) = RETDEPRT(I,J) + END IF + END IF + +!DJG Lake inflow withdrawl from surface head...(4/29/05) + + + IF (LAKE_MSKRT(I,J).gt.0) THEN + IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN + LAKE_INFLOTRT = LAKE_INFLOTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) + LAKE_INFLORT(I,J) = LAKE_INFLORT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) + SFCHEADSUBRT(I,J) = RETDEPRT(I,J) + + END IF + END IF + + + + END DO + END DO + +!yw check call MPP_LAND_COM_REAL(QSTRMVOLRT,IXRT,JXRT,99) +!DJG---------------------------------------------------------------------- +!DJG CALL OVERLAND FLOW ROUTING SUBROUTINE +!DJG---------------------------------------------------------------------- + +!DJG Debug... + + + if(rt_option .eq. 1) then + CALL ROUTE_OVERLAND1(DTRT_TER,dist,SFCHEADSUBRT,DHRT,SOXRT, & + SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & + SO8RT,SO8RT_D,q_sfcflx_x,q_sfcflx_y) + else + CALL ROUTE_OVERLAND2(DTRT_TER,dist,SFCHEADSUBRT,DHRT,SOXRT, & + SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & + q_sfcflx_x,q_sfcflx_y) + end if + + END DO ! END routing time steps + +#ifdef HYDRO_D + print *, "End of OV_routing call..." +#endif + +!---------------------------------------------------------------------- +! END OVERLAND FLOW ROUTING LOOP +! CHANNEL ROUTING TO FOLLOW +!---------------------------------------------------------------------- + +!DJG ---------------------------------------------------------------- + END SUBROUTINE OV_RTNG +!DJG ---------------------------------------------------------------- + +!DJG SUBROUTINE ROUTE_OVERLAND1 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_OVERLAND1(dt, & + & gsize,h,qsfc,sox,soy, & + & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,SO8RT,SO8RT_D, & + & q_sfcflx_x,q_sfcflx_y) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route excess rainfall over the watershed +! using a 2d diffusion routing scheme. +! +! Called from: main.f +! +! Will try to formulate this to be called from NOAH +! +! Returns: qsfc=DQOV which in turn becomes DH in head calc. +! +! Created: Adaptded from CASC2D source code +! NOTE: dh from original code has been replaced by qsfc +! dhh replaced by qqsfc +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id, & + up_id,mpp_land_com_real, my_id, mpp_land_com_real8,& + mpp_land_sync +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + INTEGER, INTENT(IN) :: XX,YY + REAL, INTENT(IN) :: dt, gsize(xx,yy,9) + +!! Declare passed arrays + + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h + REAL, INTENT(IN), DIMENSION(XX,YY) :: qsfc + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep + REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x, q_sfcflx_y + REAL, INTENT(INOUT) :: QBDRYT + REAL, INTENT(IN), DIMENSION(XX,YY,8) :: SO8RT + REAL*8, DIMENSION(XX,YY) :: QBDRY_tmp, DH + REAL*8, DIMENSION(XX,YY) :: DH_tmp + +!!! Declare Local Variables + + REAL :: dhdx,dhdy,alfax,alfay + REAL :: hh53,qqsfc,hh,dt_new,hmax + REAL :: sfx,sfy + REAL :: tmp_adjust + + INTEGER :: i,j + REAL IXX8,IYY8 + INTEGER IXX0,JYY0,index, SO8RT_D(XX,YY,3) + REAL tmp_gsize,hsum + +!!! Initialize variables + + + +!!! Begin Routing of Excess Rainfall over the Watershed + + DH=0. + DH_tmp=0. + QBDRY_tmp =0. + +!!! Loop to route water + do j=2,YY-1 + do i=2,XX-1 + if (h(I,J).GT.retent_dep(I,J)) then + IXX0 = SO8RT_D(i,j,1) + JYY0 = SO8RT_D(i,j,2) + index = SO8RT_D(i,j,3) + tmp_gsize = 1.0/gsize(i,j,index) + sfx = so8RT(i,j,index)-(h(IXX0,JYY0)-h(i,j))*0.001*tmp_gsize + hmax = h(i,j)*0.001 !Specify max head for mass flux limit... + if(sfx .lt. 1E-20) then + call GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,so8rt,gsize(i,j,:),sfx,XX,YY) + end if + if(IXX0 > 0) then ! do the rest if the lowest grid can be found. + if(sfx .lt. 1E-20) then +#ifdef HYDRO_D + print*, "Message: sfx reset to 1E-20. sfx =",sfx + print*, "i,j,index,IXX0,JYY0",i,j,index,IXX0,JYY0 + print*, "so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) ", & + so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) +#endif + sfx = 1E-20 + end if + alfax = sqrt(sfx) / dist_rough(i,j) + hh=(h(i,j)-retent_dep(i,j)) * 0.001 + hh53=hh**(5./3.) + +! Calculate q-flux... + qqsfc = alfax*hh53*dt * tmp_gsize + +!Courant check (simple mass limit on overland flow)... + if (qqsfc.ge.(hmax*dt*tmp_gsize)) qqsfc = hmax*dt*tmp_gsize + +! Accumulate directional fluxes on routing subgrid... + if (IXX0.gt.i) then + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc * & + (1.0 - 0.5 * (ABS(j-JYY0))) + else if (IXX0.lt.i) then + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) - 1.0 * & + qqsfc * (1.0 - 0.5 * (ABS(j-JYY0))) + else + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + 0. + end if + if (JYY0.gt.j) then + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc * & + (1.0 - 0.5 * (ABS(i-IXX0))) + elseif (JYY0.lt.j) then + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) - 1.0 * & + qqsfc * (1.0 - 0.5 * (ABS(i-IXX0))) + else + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + 0. + end if + + +!DJG put adjustment in for (h) due to qqsfc + +!yw changed as following: + tmp_adjust=qqsfc*1000 + if((h(i,j) - tmp_adjust) <0 ) then +#ifdef HYDRO_D + print*, "Error Warning: surface head is negative: ",i,j,ixx0,jyy0, & + h(i,j) - tmp_adjust +#endif + tmp_adjust = h(i,j) + end if + DH(i,j) = DH(i,j)-tmp_adjust + DH_tmp(ixx0,jyy0) = DH_tmp(ixx0,jyy0) + tmp_adjust + !yw end change + + !DG Boundary adjustments here + !DG Constant Flux Condition +#ifdef MPP_LAND + if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & + ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & + ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & + ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then +! QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000. +#else + if ((ixx0.eq.XX).or.(ixx0.eq.1).or.(jyy0.eq.1) & + .or.(JYY0.eq.YY )) then +! QBDRY(IXX0,JYY0)=QBDRY(IXX0,JYY0) - qqsfc*1000. +#endif + QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000. + QBDRYT=QBDRYT - qqsfc + DH_tmp(IXX0,JYY0)= DH_tmp(IXX0,JYY0)-tmp_adjust + end if + end if +!! End loop to route sfc water + end if + end do + end do + +#ifdef MPP_LAND +! use double precision to solve the underflow problem. + call MPP_LAND_COM_REAL8(DH_tmp,XX,YY,1) + call MPP_LAND_COM_REAL8(QBDRY_tmp,XX,YY,1) +#endif + QBDRY = QBDRY + QBDRY_tmp + DH = DH+DH_tmp + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL8(DH,XX,YY,99) + call MPP_LAND_COM_REAL(QBDRY,XX,YY,99) +#endif + + H = H + DH + + return + +!DJG ---------------------------------------------------------------------- + end subroutine ROUTE_OVERLAND1 + + +!DJG ---------------------------------------------------------------- + SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY) + implicit none + INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY + INTEGER, INTENT(IN) :: I,J + + REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY,8),tmp_gsize(9) + REAL max + IXX0 = -1 + max = 0 + if (h(I,J).LE.retent_dep(I,J)) return + + IXX8 = I + JYY8 = J+1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) + + IXX8 = I+1 + JYY8 = J+1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) + + IXX8 = I+1 + JYY8 = J + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) + + IXX8 = I+1 + JYY8 = J-1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) + + IXX8 = I + JYY8 = J-1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) + + IXX8 = I-1 + JYY8 = J-1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) + + IXX8 = I-1 + JYY8 = J + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) + + IXX8 = I-1 + JYY8 = J+1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) + RETURN + END SUBROUTINE GETMAX8DIR + + SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox & + ,IXX0,JYY0,max,tmp_gsize,XX,YY) + implicit none + integer,INTENT(INOUT) ::IXX0,JYY0 + INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY + REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY) + REAL, INTENT(INOUT) ::max + real, INTENT(IN) :: tmp_gsize + real :: sfx + + sfx = sox(i,j)-(h(IXX8,JYY8)-h(i,j))*0.001/tmp_gsize + if(sfx .le. 0 ) return + if(max < sfx ) then + IXX0 = IXX8 + JYY0 = JYY8 + max = sfx + end if + + END SUBROUTINE GET8DIR +!DJG ---------------------------------------------------------------- +!DJG SUBROUTINE ROUTE_SUBSURFACE1 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_SUBSURFACE1( & + dist,z,qsub,sox,soy, & + latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,SO8RT,SO8RT_D, & + CWATAVAIL,SUBDT) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route subsurface flow through the watershed +! +! Called from: main.f (Noah_router_driver) +! +! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. +! +! Created: D. Gochis 3/27/03 +! Adaptded from Wigmosta, 1994 +! +! Modified: D. Gochis 1/05/04 +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real8,my_id,mpp_land_com_real +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + INTEGER, INTENT(IN) :: XX,YY + +!! Declare passed arrays + + REAL, INTENT(IN), DIMENSION(XX,YY) :: z + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat + REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL + REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep + REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY + REAL, INTENT(INOUT) :: QSUBDRYT + REAL*8, DIMENSION(XX,YY) :: qsub_tmp,QSUBDRY_tmp +!yw INTEGER, INTENT(OUT) :: flag + REAL, INTENT(IN) :: dist(xx,yy,9),SUBDT + +!!! Declare Local Variables + + REAL :: dzdx,dzdy,beta,gamma + REAL :: qqsub,hh,ksat + + REAL :: SO8RT(XX,YY,8) + INTEGER :: SO8RT_D(XX,YY,3), rt_option + + +!!! Initialize variables + + REAL, PARAMETER :: nexp=1.0 ! local power law exponent + integer IXX0,JYY0,index,i,j + real tmp_gsize + +! temporary set it to be 2. Should be passed in. +!yw soldep = 2. +! Begin Subsurface routing + + + +!!! Loop to route water in x-direction + qsub_tmp = 0. + QSUBDRY_tmp = 0. + +#ifdef HYDRO_D + write(6,*) "call subsurface routing xx= , yy =", yy, xx +#endif + + do j=2,YY-1 + do i=2,XX-1 + + + if(i.ge.2.AND.i.le.XX-1.AND.j.ge.2.AND.j.le.YY-1) then !if grdcl chk +! check for boundary grid point? + IXX0 = SO8RT_D(i,j,1) + JYY0 = SO8RT_D(i,j,2) + + index = SO8RT_D(i,j,3) + + if(dist(i,j,index) .le. 0) then + write(6,*) "FATAL ERROR: dist(i,j,index) is <= zero " + call hydro_stop("In ROUTE_SUBSURFACE1() - dist(i,j,index) is <= zero ") + endif + if(soldep(i,j) .eq. 0) then + call hydro_stop("In ROUTE_SUBSURFACE1() - soldep is = zero") + endif + + tmp_gsize = 1.0/dist(i,j,index) + + + dzdx= (z(i,j) - z(IXX0,JYY0) )* tmp_gsize + beta=so8RT(i,j,index) + dzdx + + if(beta .lt. 1E-20 ) then !if-then for direction... + call GETSUB8(IXX0,JYY0,I,J,Z,so8rt,dist(i,j,:),beta,XX,YY) + end if + if(beta .gt. 0) then !if-then for flux calc + if(beta .lt. 1E-20 ) then +#ifdef HYDRO_D + print*, "Message: beta need to be reset to 1E-20. beta = ",beta +#endif + beta = 1E-20 + end if + +! do the rest if the lowest grid can be found. + hh=(1-(z(i,j)/soldep(i,j)))**nexp + ksat=latksat(i,j) + + if (hh .lt. 0.) then + print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & + soldep(i,j) + call hydro_stop("In ROUTE_SUBSURFACE1() - hsub<0 at gridcell ") + end if + +!err. tan slope gamma=-1.0*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) + gamma=-1.0*((dist(i,j,index)*ksat*soldep(i,j))/nexp)*beta + qqsub = gamma * hh + +! ADCHANGE: Moved this water available constraint from outside qsub calc loop to inside +! to better account for adjustments to adjacent cells + if( qqsub .le. 0 .and. CWATAVAIL(i,j).lt.ABS(qqsub)/dist(i,j,9)*SUBDT) THEN + qqsub = -1.0*CWATAVAIL(i,j)*dist(i,j,9)/SUBDT + end if + + qsub(i,j) = qsub(i,j) + qqsub + qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) - qqsub + +!!DJG Error Checks... + if(qqsub .gt. 0) then + print*, "FATAL ERROR: qqsub should be negative, qqsub =",qqsub,& + "gamma=",gamma,"hh=",hh,"beta=",beta,"dzdx=",dzdx,& + "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 + call hydro_stop("In ROUTE_SUBSURFACE1() - qqsub should be negative") + end if + + + + +! Boundary adjustments +#ifdef MPP_LAND + if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & + ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & + ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & + ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then +#else + if ((ixx0.eq.1).or.(ixx0.eq.xx).or.(jyy0.eq.1).or.(jyy0.eq.yy)) then +#endif + qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) + qqsub + QSUBDRY_tmp(ixx0,jyy0) = QSUBDRY_tmp(ixx0,jyy0) + qqsub + + QSUBDRYT = QSUBDRYT + qqsub + end if + +998 continue + +!! End loop to route sfc water in x-direction + end if !endif for flux calc + + endif !! Endif for gridcell check... + + + end do !endif for i-dim +!CRNT debug if(flag.eq.-99) exit !exit loop for courant violation... + end do !endif for j-dim + +#ifdef MPP_LAND + + call MPP_LAND_COM_REAL8(qsub_tmp,XX,YY,1) + call MPP_LAND_COM_REAL8(QSUBDRY_tmp,XX,YY,1) +#endif + qsub = qsub + qsub_tmp + QSUBDRY= QSUBDRY + QSUBDRY_tmp + +!ADNOTE: Moved this check to inside qsub calc loop, so no need for additional loop +! do j=2,YY-1 +! do i=2,XX-1 +! if(dist(i,j,9) .le. 0) then +! call hydro_stop("In ROUTE_SUBSURFACE1() - dist(i,j,9) is <= zero") +! endif +!!DJG Feb 16, 2016...comment out to debug...line is identical to line 255 +!! if(CWATAVAIL(i,j).lt.ABS(qsub(i,j))/dist(i,j,9)*SUBDT) THEN +!! qsub(i,j) = -1.0*CWATAVAIL(i,j) +!! end if +! end do +! end do + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(qsub,XX,YY,99) + call MPP_LAND_COM_REAL(QSUBDRY,XX,YY,99) +#endif + + + return +!DJG------------------------------------------------------------ + end subroutine ROUTE_SUBSURFACE1 +!DJG------------------------------------------------------------ + +!DJG------------------------------------------------------------ + + + SUBROUTINE GETSUB8(IXX0,JYY0,I,J,Z,sox,tmp_gsize,max,XX,YY) + implicit none + INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY + INTEGER, INTENT(IN) :: I,J + + REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY,8),tmp_gsize(9) + REAL max + max = -1 + + IXX8 = I + JYY8 = J+1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) + + IXX8 = I+1 + JYY8 = J+1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) + + IXX8 = I+1 + JYY8 = J + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) + + IXX8 = I+1 + JYY8 = J-1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) + + IXX8 = I + JYY8 = J-1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) + + IXX8 = I-1 + JYY8 = J-1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) + + IXX8 = I-1 + JYY8 = J + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) + + IXX8 = I-1 + JYY8 = J+1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) + RETURN + END SUBROUTINE GETSUB8 + + SUBROUTINE GETSUB8DIR(IXX8,JYY8,I,J,Z,sox,IXX0,JYY0,max,tmp_gsize,XX,YY) + implicit none + integer,INTENT(INOUT) ::IXX0,JYY0 + INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY + REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY) + REAL, INTENT(INOUT) ::max + real, INTENT(IN) :: tmp_gsize + real :: beta , dzdx + + dzdx= (z(i,j) - z(IXX0,JYY0) )/tmp_gsize + beta=sox(i,j) + dzdx + if(max < beta ) then + IXX0 = IXX8 + JYY0 = JYY8 + max = beta + end if + + END SUBROUTINE GETSUB8DIR +!DJG ---------------------------------------------------------------------- + +!DJG SUBROUTINE ROUTE_OVERLAND2 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_OVERLAND2 (dt, & + & dist,h,qsfc,sox,soy, & + & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT, & + & q_sfcflx_x,q_sfcflx_y) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route excess rainfall over the watershed +! using a 2d diffusion routing scheme. +! +! Called from: main.f +! +! Will try to formulate this to be called from NOAH +! +! Returns: qsfc=DQOV which in turn becomes DH in head calc. +! +! Created: Adaptded from CASC2D source code +! NOTE: dh from original code has been replaced by qsfc +! dhh replaced by qqsfc +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real,MPP_LAND_UB_COM, & + MPP_LAND_LR_COM,mpp_land_com_integer +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + real :: gsize + INTEGER, INTENT(IN) :: XX,YY + REAL, INTENT(IN) :: dt , dist(XX,YY,9) + +!! Declare passed arrays + + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: qsfc + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep + REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x,q_sfcflx_y + REAL, INTENT(INOUT) :: QBDRYT + REAL :: DH(XX,YY) + +!!! Declare Local Variables + + REAL :: dhdx,dhdy,alfax,alfay + REAL :: hh53,qqsfc,hh,dt_new + REAL :: sfx,sfy + REAL :: tmp_adjust + + INTEGER :: i,j + +!!! Initialize variables + + + + +!!! Begin Routing of Excess Rainfall over the Watershed + + + DH = 0 +!!! Loop to route water in x-direction + do j=1,YY + do i=1,XX + + +! check for boundary gridpoint? + if (i.eq.XX) GOTO 998 + gsize = dist(i,j,3) + + +! check for detention storage? + if (h(i,j).lt.retent_dep(i,j).AND. & + h(i+1,j).lt.retent_dep(i+1,j)) GOTO 998 + + dhdx = (h(i+1,j)/1000. - h(i,j)/1000.) / gsize ! gisze-(m),h-(mm) + + sfx = (sox(i,j)-dhdx+1E-30) + if (abs(sfx).lt.1E-20) sfx=1E-20 + alfax = ((abs(sfx))**0.5)/dist_rough(i,j) + if (sfx.lt.0.) then + hh=(h(i+1,j)-retent_dep(i+1,j))/1000. + else + hh=(h(i,j)-retent_dep(i,j))/1000. + end if + + if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 998 + if (hh.lt.0.) then + GOTO 998 + end if + + hh53=hh**(5./3.) + + +! Calculate q-flux... (units (m)) + qqsfc = (sfx/abs(sfx))*alfax*hh53*dt/gsize + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc + +!DJG put adjustment in for (h) due to qqsfc + +!yw changed as following: + tmp_adjust=qqsfc*1000 + if(tmp_adjust .le. 0 ) GOTO 998 + if((h(i,j) - tmp_adjust) <0 ) then +#ifdef HYDRO_D + print*, "WARNING: surface head is negative: ",i,j +#endif + tmp_adjust = h(i,j) + end if + if((h(i+1,j) + tmp_adjust) <0) then +#ifdef HYDRO_D + print*, "WARNING: surface head is negative: ",i+1,j +#endif + tmp_adjust = -1*h(i+1,j) + end if + Dh(i,j) = Dh(i,j)-tmp_adjust + Dh(i+1,j) = Dh(i+1,j) + tmp_adjust +!yw end change + + + +!DG Boundary adjustments here +!DG Constant Flux Condition +#ifdef MPP_LAND + if ((i.eq.1).AND.(sfx.lt.0).and. & + (left_id .lt. 0) ) then +#else + if ((i.eq.1).AND.(sfx.lt.0)) then +#endif + Dh(i,j) = Dh(i,j) + qqsfc*1000. + QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. + QBDRYT=QBDRYT + qqsfc*1000. +#ifdef MPP_LAND + else if ( (i.eq.(XX-1)).AND.(sfx.gt.0) & + .and. (right_id .lt. 0) ) then +#else + else if ((i.eq.(XX-1)).AND.(sfx.gt.0)) then +#endif + tmp_adjust = qqsfc*1000. + if(h(i+1,j).lt.tmp_adjust) tmp_adjust = h(i+1,j) + Dh(i+1,j) = Dh(i+1,j) - tmp_adjust +!DJG Re-assign h(i+1) = 0.0 when <0.0 (from rounding/truncation error) + QBDRY(I+1,J)=QBDRY(I+1,J) - tmp_adjust + QBDRYT=QBDRYT - tmp_adjust + end if + + +998 continue + +!! End loop to route sfc water in x-direction + end do + end do + + H = H + DH +#ifdef MPP_LAND + call MPP_LAND_LR_COM(H,XX,YY,99) + call MPP_LAND_LR_COM(QBDRY,XX,YY,99) +#endif + + + DH = 0 +!!!! Loop to route water in y-direction + do j=1,YY + do i=1,XX + +!! check for boundary grid point? + if (j.eq.YY) GOTO 999 + gsize = dist(i,j,1) + + +!! check for detention storage? + if (h(i,j).lt.retent_dep(i,j).AND. & + h(i,j+1).lt.retent_dep(i,j+1)) GOTO 999 + + dhdy = (h(i,j+1)/1000. - h(i,j)/1000.) / gsize + + sfy = (soy(i,j)-dhdy+1E-30) + if (abs(sfy).lt.1E-20) sfy=1E-20 + alfay = ((abs(sfy))**0.5)/dist_rough(i,j) + if (sfy.lt.0.) then + hh=(h(i,j+1)-retent_dep(i,j+1))/1000. + else + hh=(h(i,j)-retent_dep(i,j))/1000. + end if + + if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 999 + if (hh.lt.0.) then + GOTO 999 + end if + + hh53=hh**(5./3.) + +! Calculate q-flux... + qqsfc = (sfy/abs(sfy))*alfay*hh53*dt / gsize + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc + + +!DJG put adjustment in for (h) due to qqsfc +!yw h(i,j) = h(i,j)-qqsfc*1000. +!yw h(i,j+1) = h(i,j+1) + qqsfc*1000. +!yw changed as following: + tmp_adjust=qqsfc*1000 + if(tmp_adjust .le. 0 ) GOTO 999 + + if((h(i,j) - tmp_adjust) <0 ) then +#ifdef HYDRO_D + print *, "WARNING: surface head is negative: ",i,j +#endif + tmp_adjust = h(i,j) + end if + if((h(i,j+1) + tmp_adjust) <0) then +#ifdef HYDRO_D + print *, "WARNING: surface head is negative: ",i,j+1 +#endif + tmp_adjust = -1*h(i,j+1) + end if + Dh(i,j) = Dh(i,j)-tmp_adjust + Dh(i,j+1) = Dh(i,j+1) + tmp_adjust +!yw end change + +! qsfc(i,j) = qsfc(i,j)-qqsfc +! qsfc(i,j+1) = qsfc(i,j+1) + qqsfc +!!DG Boundary adjustments here +!!DG Constant Flux Condition +#ifdef MPP_LAND + if ((j.eq.1).AND.(sfy.lt.0) & + .and. (down_id .lt. 0) ) then +#else + if ((j.eq.1).AND.(sfy.lt.0)) then +#endif + Dh(i,j) = Dh(i,j) + qqsfc*1000. + QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. + QBDRYT=QBDRYT + qqsfc*1000. +#ifdef MPP_LAND + else if ((j.eq.(YY-1)).AND.(sfy.gt.0) & + .and. (up_id .lt. 0) ) then +#else + else if ((j.eq.(YY-1)).AND.(sfy.gt.0)) then +#endif + tmp_adjust = qqsfc*1000. + if(h(i,j+1).lt.tmp_adjust) tmp_adjust = h(i,j+1) + Dh(i,j+1) = Dh(i,j+1) - tmp_adjust +!DJG Re-assign h(j+1) = 0.0 when <0.0 (from rounding/truncation error) + QBDRY(I,J+1)=QBDRY(I,J+1) - tmp_adjust + QBDRYT=QBDRYT - tmp_adjust + end if + +999 continue + +!!!! End loop to route sfc water in y-direction + end do + end do + + H = H +DH +#ifdef MPP_LAND + call MPP_LAND_UB_COM(H,XX,YY,99) + call MPP_LAND_UB_COM(QBDRY,XX,YY,99) +#endif + return + +!DJG ---------------------------------------------------------------------- + end subroutine ROUTE_OVERLAND2 + + + + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE TER_ADJ_SOL - Terrain adjustment of incoming solar radiation +!DJG----------------------------------------------------------------------- + SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) + +#ifdef MPP_LAND + use module_mpp_land, only: my_id, io_id, & + mpp_land_bcast_int1 +#endif + implicit none + integer,INTENT(IN) :: IX,JX + INTEGER,INTENT(in), DIMENSION(IX,JX,3) :: SO8LD_D + real,INTENT(IN), DIMENSION(IX,JX) :: XLAT,XLONG + real,INTENT(IN) :: DT + real,INTENT(INOUT), DIMENSION(IX,JX) :: SHORT + character(len=19) :: olddate + +! Local Variables... + real, dimension(IX,JX) ::TSLP,TAZI + real, dimension(IX,JX) ::SOLDN + real :: SOLDEC,DGRD,ITIME2,HRANGLE + real :: BINSH,SOLZANG,SOLAZI,INCADJ + real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ + integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0 + integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD + integer :: I,J + + +!---------------------------------------------------------------------- +! SPECIFY PARAMETERS and VARIABLES +!---------------------------------------------------------------------- + + JULDAY = 0 + SOLDN = SHORT + DGRD = 3.14159/180. + +! Set up time variables... +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT) + read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT) + read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT) + read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT) + read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(YYYY0) + call mpp_land_bcast_int1(MM0) + call mpp_land_bcast_int1(DD0) + call mpp_land_bcast_int1(HHTIME0) + call mpp_land_bcast_int1(MMTIME0) +#endif + + +! Set up terrain variables...(returns TSLP&TAZI in radians) + call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) + +!---------------------------------------------------------------------- +! BEGIN LOOP THROUGH GRID +!---------------------------------------------------------------------- + DO J=1,JX + DO I=1,IX + YYYY = YYYY0 + MM = MM0 + DD = DD0 + HHTIME = HHTIME0 + MMTIME = MMTIME0 + call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT) + call JULDAY_CALC(YYYY,MM,DD,JULDAY) + +! Convert to radians... + LATR = XLAT(I,J) !send solsub local lat in deg + LONR = XLONG(I,J) !send solsub local lon in deg + TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg + TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg + +!Call SOLSUB to return terrain adjusted incoming solar radiation... +! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software. + + call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM, & + DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ) + + SOLDN(I,J)=SOLDNADJ + + ENDDO + ENDDO + + SHORT = SOLDN + + return + end SUBROUTINE TER_ADJ_SOL +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE TER_ADJ_SOL +!DJG----------------------------------------------------------------------- + + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE GMT2LOCAL +!DJG----------------------------------------------------------------------- + subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) + + implicit none + +!!! Declare Passed Args. + + INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min + INTEGER, INTENT(IN) :: IX,JX + REAL,INTENT(IN), DIMENSION(IX,JX) :: XLONG + REAL,INTENT(IN) :: DT + +!!! Declare local variables + + integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag + integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh + real, dimension(IX,JX) :: TDIFF + real :: tmp + integer :: yyinit,mminit,ddinit,hhinit,mininit + +!!! Initialize flags + hhflag=0 + ddflag=0 + mmflag=0 + yyflag=0 + +!!! Set up constants... + yyinit = yy + mminit = mm + ddinit = dd + hhinit = hh + mininit = min + + +! Loop through data... + do j=1,JX + do i=1,IX + +! Reset yy,mm,dd... + yy = yyinit + mm = mminit + dd = ddinit + hh = hhinit + min = mininit + +!!! Set up adjustments... +! - assumes +E , -W longitude and 0.06667 hr/deg (=24/360) + TDIFF(I,J) = XLONG(I,J)*0.06667 ! time offset in hr + tmp = TDIFF(I,J) + lst_adj_hh = INT(tmp) + lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.) ! w/ 1/2 timestep adjustment... + +!!! Process Minutes... + adj_min = min+lst_adj_min + if (adj_min.lt.0) then + min=60+adj_min + lst_adj_hh = lst_adj_hh - 1 + else if (adj_min.ge.0.AND.adj_min.lt.60) then + min=adj_min + else if (adj_min.ge.60) then + min=adj_min-60 + lst_adj_hh = lst_adj_hh + 1 + end if + +!!! Process Hours + adj_hh = hh+lst_adj_hh + if (adj_hh.lt.0) then + hh = 24+adj_hh + ddflag=1 + else if (adj_hh.ge.0.AND.adj_hh.lt.24) then + hh=adj_hh + else if (adj_hh.ge.24) then + hh=adj_hh-24 + ddflag = 2 + end if + + + +!!! Process Days, Months, Years +! Subtract a day + if (ddflag.eq.1) then + if (dd.gt.1) then + dd=dd-1 + else + if (mm.eq.1) then + mm=12 + yy=yy-1 + else + mm=mm-1 + end if + if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & + (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & + (mm.eq.12)) then + dd=31 + else + +!!! Adjustment for leap years!!! + if(mm.eq.2) then + if(MOD(yy,4).eq.0) then + dd=29 + else + dd=28 + end if + end if + if(mm.ne.2) dd=30 + end if + end if + end if + +! Add a day + if (ddflag.eq.2) then + if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & + (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & + (mm.eq.12)) then + if (dd.eq.31) then + dd=1 + if (mm.eq.12) then + mm=1 + yy=yy+1 + else + mm=mm+1 + end if + else + dd=dd+1 + end if + +!!! Adjustment for leap years!!! + else if (mm.eq.2) then + if(MOD(yy,4).eq.0) then + if (dd.eq.29) then + dd=1 + mm=3 + else + dd=dd+1 + end if + else + if (dd.eq.28) then + dd=1 + mm=3 + else + dd=dd+1 + end if + end if + else + if (dd.eq.30) then + dd=1 + mm=mm+1 + else + dd=dd+1 + end if + end if + + end if + + end do !i-loop + end do !j-loop + + return + end subroutine + +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE GMT2LOCAL +!DJG----------------------------------------------------------------------- + + + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE JULDAY_CALC +!DJG----------------------------------------------------------------------- + subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) + + implicit none + integer,intent(in) :: YYYY,MM,DD + integer,intent(out) :: JULDAY + + integer :: resid + integer julm(13) + DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, & + 304, 334, 365 / + + integer LPjulm(13) + DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, & + 305, 335, 366 / + + resid = MOD(YYYY,4) !Set up leap year check... + + if (resid.ne.0) then !If not a leap year.... + JULDAY = JULM(MM) + DD + else !If a leap year... + JULDAY = LPJULM(MM) + DD + end if + + RETURN + END subroutine JULDAY_CALC +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE JULDAY +!DJG----------------------------------------------------------------------- + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE SLOPE_ASPECT +!DJG----------------------------------------------------------------------- + subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) + + implicit none + integer, INTENT(IN) :: IX,JX +! real,INTENT(in),DIMENSION(IX,JX) :: TSLP !terrain slope (m/m) + real,INTENT(OUT),DIMENSION(IX,JX) :: TAZI !terrain aspect (deg) + + INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D + real :: DGRD + integer :: i,j + +! TSLP = 0. !Initialize as flat + TAZI = 0. !Initialize as north facing + +! Find steepest descent slope and direction... + do j=1,JX + do i=1,IX +! TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians... + +! Convert steepest slope and aspect to radians... + IF (SO8LD_D(i,j,3).eq.1) then + TAZI(I,J) = 0.0 + ELSEIF (SO8LD_D(i,j,3).eq.2) then + TAZI(I,J) = 45.0 + ELSEIF (SO8LD_D(i,j,3).eq.3) then + TAZI(I,J) = 90.0 + ELSEIF (SO8LD_D(i,j,3).eq.4) then + TAZI(I,J) = 135.0 + ELSEIF (SO8LD_D(i,j,3).eq.5) then + TAZI(I,J) = 180.0 + ELSEIF (SO8LD_D(i,j,3).eq.6) then + TAZI(I,J) = 225.0 + ELSEIF (SO8LD_D(i,j,3).eq.7) then + TAZI(I,J) = 270.0 + ELSEIF (SO8LD_D(i,j,3).eq.8) then + TAZI(I,J) = 315.0 + END IF + + DGRD = 3.141593/180. + TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians... + + END DO + END DO + + RETURN + END subroutine SLOPE_ASPECT +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE SLOPE_ASPECT +!DJG----------------------------------------------------------------------- + +!DJG---------------------------------------------------------------- +!DJG SUBROUTINE SOLSUB +!DJG---------------------------------------------------------------- + SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & + OUT2,OUT3,INCADJ) + + +! Notes.... + + implicit none + logical :: daily, first + integer :: yy,mo,ida,ihr,mm,d + integer,dimension(12) :: nday + real :: lat,long,longcor,longsun,in,inslo + real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint + real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec + real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo + real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo + real :: t1,z,cosa,a,cosbeta_flat,INCADJ + integer :: HHTIME,MMTIME,i,ik + real, dimension(4) :: ACOF,BCOF + +! Constants + daily=.FALSE. + ACOF(1) = 0.00839 + ACOF(2) = -0.05391 + ACOF(3) = -0.00154 + ACOF(4) = -0.0022 + BCOF(1) = -0.12193 + BCOF(2) = -0.15699 + BCOF(3) = -0.00657 + BCOF(4) = -0.00370 + DZERO = 80. + ECCENT = 0.0167 + PI = 3.14159 + CALINT = 1. + RTOD = PI / 180. + DECMAX=(23.+26./60.)*RTOD + OMEGA=2*PI/365. + ONEHR=15.*RTOD + +! Calculate Julian Day... + D = 0 + call JULDAY_CALC(YY,MO,IDA,D) + +! Ratio of radius vectors squared... + OMD=OMEGA*D + OMDZERO=OMEGA*DZERO +! RDVECSQ=1./(1.-ECCENT*COS(OMD))**2 + RDVECSQ = 1. ! no adjustment for orbital changes when coupled to HRLDAS... + +! Declination of sun... + LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO)) + DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN)) + SDEC=SIN(DECLIN) + CDEC=COS(DECLIN) + +! Check for Polar Day/night... + ARG=((PI/2.)-ABS(DECLIN))/RTOD + IF(ABS(LAT).GT.ARG) THEN + IF((LAT.GT.0..AND.DECLIN.LT.0) .OR. & + (LAT.LT.0..AND.DECLON.GT.0.)) THEN + OUT1 = 0. + OUT2 = 0. + OUT3 = 0. + RETURN + ENDIF + SR=-1.*PI + ELSE + +! Calculate sunrise hour angle... + SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN))) + END IF + +! Find standard meridian for site + STDMRDN=NINT(LONG/15.)*15. + LONGCOR=(LONG-STDMRDN)/15. + +! Compute time correction from equation of time... + B=2.*PI*(D-.4)/365 + EM=0. + DO I=1,4 + EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B)) + END DO + +! Compute time of solar noon... + TIMNOON=12.-EM-LONGCOR + +! Set up a few more terms... + AZSLO=AZ*RTOD + INSLO=IN*RTOD + SLAT=SIN(LAT*RTOD) + CLAT=COS(LAT*RTOD) + CAZ=COS(AZSLO) + SAZ=SIN(AZSLO) + SINC=SIN(INSLO) + CINC=COS(INSLO) + +! Begin solar radiation calculations...daily first, else instantaneous... + IF (DAILY) THEN ! compute daily integrated values...(Not used in HRLDAS!) + IHR=0 + MM=0 + HINC=CALINT*ONEHR/60. + IK=(2.*ABS(SR)/HINC)+2. + FIRST=.TRUE. + OUT1=0. + DO I=1,IK + H=SR+HINC*FLOAT(I-1) + COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) + COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & + SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & + SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) + EXTRA=SC*RDVECSQ*COSZ + IF(EXTRA.LE.0.) EXTRA=0. + EXTSLO=SC*RDVECSQ*COSBETA + IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. + IF(FIRST .AND. EXTSLO.GT.0.) THEN + OUT2=(H-HINC)/ONEHR+TIMNOON + FIRST = .FALSE. + END IF + IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON + OUT1=EXTSLO+OUT1 + END DO + OUT1=OUT1*CALINT*60./1000000. + + ELSE ! Compute instantaneous values...(Is used in HRLDAS!) + + T1=FLOAT(IHR)+FLOAT(MM)/60. + H=ONEHR*(T1-TIMNOON) + COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) + +! Assuming HRLDAS forcing already accounts for season, time of day etc, +! subtract out the component of adjustment that would occur for +! a flat surface, this should leave only the sloped component remaining + + COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & + SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & + SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) + + COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT + + INCADJ = COSBETA+(1-COSBETA_FLAT) + + EXTRA=SC*RDVECSQ*COSZ + IF(EXTRA.LE.0.) EXTRA=0. + EXTSLO=SC*RDVECSQ*INCADJ +! IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. !remove check for HRLDAS. + OUT1=EXTSLO + Z=ACOS(COSZ) + COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z)) + IF(COSA.LT.-1.) COSA=-1. + IF(COSA.GT.1.) COSA=1. + A=ABS(ACOS(COSA)) + IF(H.LT.0.) A=-A + OUT2=Z/RTOD + OUT3=A/RTOD+180 + + END IF ! End if for daily vs instantaneous values... + +!DJG----------------------------------------------------------------------- + RETURN + END SUBROUTINE SOLSUB +!DJG----------------------------------------------------------------------- + + subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) + implicit none + integer :: ix,jx,i,j + REAL, DIMENSION(IX,JX,8) :: SO8LD + INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D + real,DIMENSION(IX,JX) :: TERR + real :: dx(ix,jx,9),Vmax(ix,jx) + SO8LD_D = -1 + do j = 2, jx -1 + do i = 2, ix -1 + SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1) + SO8LD_D(i,j,1) = i + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 1 + Vmax(i,j) = SO8LD(i,j,1) + + SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2) + if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 2 + Vmax(i,j) = SO8LD(i,j,2) + end if + SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3) + if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j + SO8LD_D(i,j,3) = 3 + Vmax(i,j) = SO8LD(i,j,3) + end if + SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4) + if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 4 + Vmax(i,j) = SO8LD(i,j,4) + end if + SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5) + if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 5 + Vmax(i,j) = SO8LD(i,j,5) + end if + SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6) + if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 6 + Vmax(i,j) = SO8LD(i,j,6) + end if + SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7) + if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j + SO8LD_D(i,j,3) = 7 + Vmax(i,j) = SO8LD(i,j,7) + end if + SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8) + if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 8 + Vmax(i,j) = SO8LD(i,j,8) + end if + enddo + enddo + Vmax = TANH(Vmax) + return + end subroutine seq_land_SO8 + +#ifdef MPP_LAND + subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& + global_nx,global_ny) + + use module_mpp_land, only: my_id, io_id, & + write_io_real,decompose_data_int,decompose_data_real + + implicit none + integer,intent(in) :: ix,jx,global_nx,global_ny + INTEGER, intent(inout),DIMENSION(IX,JX,3) :: SO8LD_D +! real,intent(in), DIMENSION(IX,JX) :: TERRAIN + real,DIMENSION(IX,JX) :: TERRAIN + real,intent(out),dimension(ix,jx) :: Vmax + real,intent(in) :: dx(ix,jx,9) + real :: g_dx(ix,jx,9) + + real,DIMENSION(global_nx,global_ny) :: g_TERRAIN + real,DIMENSION(global_nx,global_ny) :: g_Vmax + integer,DIMENSION(global_nx,global_ny,3) :: g_SO8LD_D + integer :: k + + g_SO8LD_D = 0 + g_Vmax = 0 + + do k = 1, 9 + call write_IO_real(dx(:,:,k),g_dx(:,:,k)) + end do + + call write_IO_real(TERRAIN,g_TERRAIN) + if(my_id .eq. IO_id) then + call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny) + endif + call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) + call decompose_data_real(g_Vmax,Vmax) + return + end subroutine MPP_seq_land_SO8 + +#endif + + + + subroutine disaggregateDomain_drv(did) + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + integer :: did + call disaggregateDomain( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& + RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,nlst_rt(did)%AGGFACTRT,RT_DOMAIN(did)%SICE, & + RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%SH2OX,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)%dist, & + RT_DOMAIN(did)%INFXSWGT, RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, & + RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%SMCREFRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%SMCMAXRT, RT_DOMAIN(did)%SMCWLTRT, & + RT_DOMAIN(did)%SMCRT, & + RT_DOMAIN(did)%OVROUGHRT, RT_DOMAIN(did)%LAKE_MSKRT, & + RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%OV_ROUGH,RT_DOMAIN(did)%SLDPTH, & + RT_DOMAIN(did)%soiltypRT, RT_DOMAIN(did)%soiltyp) + + 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, & + LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & + SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT,OV_ROUGH, & + SLDPTH, soiltypRT, soiltyp & + ) +#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, & + mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, & + sum_real1 +#endif + implicit none + integer,INTENT(IN) :: IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT + real, INTENT(OUT), DIMENSION(IX,JX,NSOIL) :: SICE + real, INTENT(IN), DIMENSION(IX,JX,NSOIL) :: SMC,SH2OX + real, INTENT(IN), DIMENSION(IX,JX) :: INFXSRT, area_lsm, SMCMAX1,SMCREF1, & + SMCWLT1, LKSAT + integer, INTENT(IN), DIMENSION(IX,JX) :: VEGTYP, soiltyp + + real,INTENT(IN),DIMENSION(IXRT,JXRT,9)::dist + real,INTENT(IN),DIMENSION(IXRT,JXRT)::INFXSWGT,OVROUGHRTFAC, & + LKSATFAC + integer,INTENT(INOUT), DIMENSION(IXRT,JXRT) ::CH_NETRT, soiltypRT + real,INTENT(IN),DIMENSION(IXRT,JXRT,NSOIL)::SH2OWGT + real,INTENT(OUT),DIMENSION(IXRT,JXRT,NSOIL)::SMCREFRT, SMCMAXRT, & + SMCWLTRT,SMCRT + real,INTENT(OUT),DIMENSION(IXRT,JXRT)::INFXSUBRT + real,INTENT(INOUT),DIMENSION(IXRT,JXRT)::OVROUGHRT, LKSATRT + integer,INTENT(INOUT), DIMENSION(IXRT,JXRT) ::LAKE_MSKRT + + + real,INTENT(IN), DIMENSION(NSOIL) :: SLDPTH + REAL OV_ROUGH(*) + + + + integer :: i, j, AGGFACYRT, AGGFACXRT, IXXRT, JYYRT,KRT, KF + REAL :: LSMVOL,SMCEXCS, WATHOLDCAP + +#ifdef HYDRO_D +! ADCHANGE: Water balance variables + integer :: kk + real :: smctot1,smcrttot2 + real :: sicetot1 + real :: suminfxs1,suminfxsrt2 +#endif + +!------------------------------------- + + + + SICE=SMC-SH2OX + SMCREFRT = 0 + +!DJG First, Disaggregate a few key fields for routing... +!DJG Debug... +#ifdef HYDRO_D + print *, "Beginning Disaggregation..." +#endif + +!DJG Mass balance check for disagg... + +#ifdef HYDRO_D +! ADCHANGE: START Initial water balance variables +! ALL VARS in MM + suminfxs1 = 0. + smctot1 = 0. + sicetot1 = 0. + do i=1,IX + do j=1,JX + suminfxs1 = suminfxs1 + INFXSRT(I,J) / float(IX*JX) + do kk=1,NSOIL + smctot1 = smctot1 + SMC(I,J,KK)*SLDPTH(KK)*1000. / float(IX*JX) + sicetot1 = sicetot1 + SICE(I,J,KK)*SLDPTH(KK)*1000. / float(IX*JX) + end do + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxs1) + CALL sum_real1(smctot1) + CALL sum_real1(sicetot1) + suminfxs1 = suminfxs1/float(numprocs) + smctot1 = smctot1/float(numprocs) + sicetot1 = sicetot1/float(numprocs) +#endif +! END Initial water balance variables +#endif + +!DJG Weighting alg. alteration...(prescribe wghts if time = 1) + + + do J=1,JX + do I=1,IX + +!DJG Weighting alg. alteration... + LSMVOL=INFXSRT(I,J)*area_lsm(I,J) + + + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif +! if(AGGFACTRT .eq. 1) then +! IXXRT=I +! JYYRT=J +! endif + + +!DJG Implement subgrid weighting routine... + INFXSUBRT(IXXRT,JYYRT)=LSMVOL* & + INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9) + + + do KRT=1,NSOIL !Do for soil profile loop + IF(SICE(I,J,KRT).gt.0) then !...adjust for soil ice +!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable + SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT) + SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT) + WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) + IF (SICE(I,J,KRT).le.WATHOLDCAP) then + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) + else + if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) & + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - & + (SICE(I,J,KRT)-WATHOLDCAP) + if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0. + end if + ELSE + SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J) + SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J) + WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) + END IF !endif adjust for soil ice... + + +!Now Adjust soil moisture +!DJG Use SH2O instead of SMC for 'liquid' water... + IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water) + SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT) +!old SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT) + ELSE + SMCRT(IXXRT,JYYRT,KRT) = 0.001 !will be skipped w/ landmask + SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001 + END IF +!DJG Check/Adjust so that subgrid cells do not exceed saturation... + IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN + SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) & + * SLDPTH(KRT)*1000. !Excess soil water in units of (mm) + SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT) + DO KF = KRT-1,1, -1 !loop back upward to redistribute excess water from disagg. + SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) + IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN !Recheck new lyr sat. + SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) & + * SLDPTH(KF)*1000. !Excess soil water in units of (mm) + SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF) + ELSE ! Excess soil water expired + SMCEXCS = 0. + EXIT + END IF + END DO + IF (SMCEXCS.GT.0) THEN !If not expired by sfc then add to Infil. Excess + INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS + SMCEXCS = 0. + END IF + END IF !End if for soil moisture saturation excess + + + end do !End do for soil profile loop + + + + do KRT=1,NSOIL !debug loop + IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN + print *, "FATAL ERROR: SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,& + SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT) + call hydro_stop("In disaggregateDomain() - SMCMAX exceeded upon disaggregation3") + ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN + print *, "FATAL ERROR: SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,& + "SMCRT=",SMCRT(IXXRT,JYYRT,KRT),"SH2OWGT=",SH2OWGT(IXXRT,JYYRT,KRT),& + "SH2O=",SH2OX(I,J,KRT) + print*, "SMC=", SMC(i,j,KRT), "SICE =", sice(i,j,KRT) + print *, "VEGTYP = ", VEGTYP(I,J) + print *, "i,j,krt, nsoil",i,j,krt,nsoil +! ADCHANGE: If values are close but not exact, end up with a crash. Force values to match. + !IF (SMC(i,j,KRT).EQ.sice(i,j,KRT)) THEN + IF (ABS(SMC(i,j,KRT) - sice(i,j,KRT)) .LE. 0.00001) THEN + print *, "SMC = SICE, soil layer totally frozen, proceeding..." + SMCRT(IXXRT,JYYRT,KRT) = 0.001 + sice(i,j,KRT) = SMC(i,j,KRT) + ELSE + call hydro_stop("In disaggregateDomain() - SMCRT depleted") + END IF + END IF + end do !debug loop + + + +!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_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT) ! Distributed calibration...1/17/2012 + END IF + + + +!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling +! --- factor that will be read in from hires terrain file +! LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) +! LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * & !Apply scaling factor... +! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF... +!!DJG error found from KIT,improper scaling ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / & +! (max(0.,(SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL))) / & +! (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) + +!AD_CHANGE: +!New model corrected to scale from 0 at SMCREF to full LKSAT*LKSATFAC at SMCMAX: + LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * & + min (1., & !just in case, make sure scale factor doesn't go over 1 + ( max(0.,(SMCRT(IXXRT,JYYRT,NSOIL) - SMCREFRT(IXXRT,JYYRT,NSOIL))) / & !becomes 0 if less than SMCREF + (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) ) + +!DJG set up lake mask... +!--- modify to make lake mask large here, but not one of the routed lakes!!! +!-- IF (VEGTYP(I,J).eq.16) then + IF (VEGTYP(I,J).eq.16 .and. & + CH_NETRT(IXXRT,JYYRT).le.0) then + !--LAKE_MSKRT(IXXRT,JYYRT) = 1 +!yw LAKE_MSKRT(IXXRT,JYYRT) = 9999 + LAKE_MSKRT(IXXRT,JYYRT) = -9999 + end if + ! BF disaggregate soiltype information for gw-soil-coupling + ! TODO: move this disaggregation code line to lsm_init section because soiltype is time-invariant + soiltypRT(ixxrt,jyyrt) = soiltyp(i,j) + + + end do + end do + + end do + end do + +#ifdef HYDRO_D +! ADCHANGE: START Final water balance variables +! ALL VARS in MM + suminfxsrt2 = 0. + smcrttot2 = 0. + do i=1,IXRT + do j=1,JXRT + suminfxsrt2 = suminfxsrt2 + INFXSUBRT(I,J) / float(IXRT*JXRT) + do kk=1,NSOIL + smcrttot2 = smcrttot2 + SMCRT(I,J,KK)*SLDPTH(KK)*1000. / float(IXRT*JXRT) + end do + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxsrt2) + CALL sum_real1(smcrttot2) + suminfxsrt2 = suminfxsrt2/float(numprocs) + smcrttot2 = smcrttot2/float(numprocs) +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + print *, "Disagg Mass Bal: " + print *, "WB_DISAG!InfxsDiff", suminfxsrt2-suminfxs1 + print *, "WB_DISAG!Infxs1", suminfxs1 + print *, "WB_DISAG!Infxs2", suminfxsrt2 + print *, "WB_DISAG!SMCDIff", smcrttot2-(smctot1-sicetot1) + print *, "WB_DISAG!SMC1", smctot1 + print *, "WB_DISAG!SICE1", sicetot1 + print *, "WB_DISAG!SMC2", smcrttot2 + print *, "WB_DISAG!Residual", (suminfxsrt2-suminfxs1) + & + (smcrttot2-(smctot1-sicetot1)) +#ifdef MPP_LAND + endif +#endif +! END Final water balance variables +#endif + +#ifdef HYDRO_D + print *, "After Disaggregation..." +#endif + +#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(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) + call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) + call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99) + end DO +#endif + + end subroutine disaggregateDomain + + subroutine SubsurfaceRouting_drv(did) + + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + implicit none + integer :: did + IF (nlst_rt(did)%SUBRTSWCRT.EQ.1) THEN + call subsurfaceRouting (RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt , nlst_rt(did)%nsoil, & + RT_DOMAIN(did)%SMCRT,RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCREFRT,& + RT_DOMAIN(did)%SMCWLTRT, RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SLDPTH, & + nlst_rt(did)%DT,RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SOXRT, & + RT_DOMAIN(did)%SOYRT,RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%SOLDEPRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%QSUBBDRYTRT, RT_DOMAIN(did)%QSUBBDRYRT,& + RT_DOMAIN(did)%QSUBRT ,nlst_rt(did)%rt_option, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%sub_resid,RT_DOMAIN(did)%SO8RT_D, RT_DOMAIN(did)%SO8RT) + endif + + end subroutine SubsurfaceRouting_drv + + subroutine subsurfaceRouting (ixrt, jxrt , nsoil, & + SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT, & + ZSOIL, SLDPTH, & + DT,ZWATTABLRT,SOXRT,SOYRT,LKSATRT,& + SOLDEPRT,INFXSUBRT,QSUBBDRYTRT, QSUBBDRYRT,& + QSUBRT ,rt_option, dist,sub_resid,SO8RT_D, SO8RT) +#ifdef MPP_LAND + use module_mpp_land, only: mpp_land_com_real, mpp_land_com_integer +#endif + implicit none + integer, INTENT(IN) :: ixrt, jxrt , nsoil, rt_option + REAL, INTENT(IN) :: DT + real,INTENT(IN), DIMENSION(NSOIL) :: ZSOIL, SLDPTH + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,SOYRT,LKSATRT, SOLDEPRT , sub_resid + real,INTENT(INOUT), DIMENSION(IXRT,JXRT)::INFXSUBRT + real,INTENT(INOUT) :: QSUBBDRYTRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT, QSUBRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT, SMCWLTRT, SMCMAXRT,SMCREFRT + + + INTEGER :: SO8RT_D(IXRT,JXRT,3) + REAL :: SO8RT(IXRT,JXRT,8) + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) +! -----local array ---------- + REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRT + REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL + INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK + + + + + CWATAVAIL = 0. + CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & + SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & + CWATAVAIL,SLDPTH) +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99) + call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99) +#endif + + +!DJG Second, Call subsurface routing routine... +#ifdef HYDRO_D + print *, "Beginning SUB_routing..." + print *, "Routing method is ",rt_option, " direction." +#endif + +!!!! Find saturated layer depth... +! Loop through domain to determine sat. layers and assign wat tbl depth... +! and water available for subsfc routing (CWATAVAIL)... +! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK + + + CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & + LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT, & + INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT, & + SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK) + +#ifdef HYDRO_D + print *, "SUBROUTE routing called and returned..." +#endif + + end subroutine subsurfaceRouting + + + subroutine OverlandRouting_drv(did) + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + implicit none + integer :: did + if(nlst_rt(did)%OVRTSWCRT .eq. 1) then + call OverlandRouting (nlst_rt(did)%DT, nlst_rt(did)%DTRT_TER, nlst_rt(did)%rt_option, & + rt_domain(did)%ixrt, rt_domain(did)%jxrt,rt_domain(did)%LAKE_MSKRT, & + rt_domain(did)%INFXSUBRT, rt_domain(did)%RETDEPRT,rt_domain(did)%OVROUGHRT, & + rt_domain(did)%SOXRT, rt_domain(did)%SOYRT, rt_domain(did)%SFCHEADSUBRT, & + rt_domain(did)%DHRT, rt_domain(did)%CH_NETRT, rt_domain(did)%QSTRMVOLRT, & + rt_domain(did)%LAKE_INFLORT,rt_domain(did)%QBDRYRT, & + rt_domain(did)%QSTRMVOLTRT,rt_domain(did)%QBDRYTRT, rt_domain(did)%LAKE_INFLOTRT,& + rt_domain(did)%q_sfcflx_x,rt_domain(did)%q_sfcflx_y, & + rt_domain(did)%dist, rt_domain(did)%SO8RT, rt_domain(did)%SO8RT_D , & + rt_domain(did)%SMCTOT2,rt_domain(did)%suminfxs1,rt_domain(did)%suminfxsrt, & + rt_domain(did)%smctot1,rt_domain(did)%dsmctot ) +! ADCHANGE: If overland routing is called, INFXSUBRT is moved to SFCHEADSUBRT, so +! zeroing out just in case + rt_domain(did)%INFXSUBRT = 0.0 + endif + end subroutine OverlandRouting_drv + + + + subroutine OverlandRouting (DT, DTRT_TER, rt_option, ixrt, jxrt,LAKE_MSKRT, & + INFXSUBRT, RETDEPRT,OVROUGHRT,SOXRT, SOYRT, SFCHEADSUBRT,DHRT, & + CH_NETRT, QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y, & + dist, SO8RT, SO8RT_D, & + SMCTOT2,suminfxs1,suminfxsrt,smctot1,dsmctot ) +#ifdef MPP_LAND + use module_mpp_land, only: mpp_land_max_int1, sum_real1, my_id, io_id, numprocs +#endif + implicit none + + REAL, INTENT(IN) :: DT, DTRT_TER + integer, INTENT(IN) :: ixrt, jxrt, rt_option + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT, & + RETDEPRT,OVROUGHRT,SOXRT, SOYRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT,DHRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT + INTEGER SO8RT_D(IXRT,JXRT,3) + + integer :: i,j + + + real :: smctot2,smctot1,dsmctot + real :: suminfxsrt,suminfxs1 +! local variable + real :: chan_in1,chan_in2 + real :: lake_in1,lake_in2 + real :: qbdry1,qbdry2 + integer :: sfcrt_flag + + + +!DJG Third, Call Overland Flow Routing Routine... +#ifdef HYDRO_D + print *, "Beginning OV_routing..." + print *, "Routing method is ",rt_option, " direction." +#endif + +!DJG debug...OV Routing... + suminfxs1=0. + chan_in1=0. + lake_in1=0. + qbdry1=0. + do i=1,IXRT + do j=1,JXRT + suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT) + chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT) + lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT) + qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT) + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxs1) + CALL sum_real1(chan_in1) + CALL sum_real1(lake_in1) + CALL sum_real1(qbdry1) + suminfxs1 = suminfxs1/float(numprocs) + chan_in1 = chan_in1/float(numprocs) + lake_in1 = lake_in1/float(numprocs) + qbdry1 = qbdry1/float(numprocs) +#endif + + +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag) +!DJG.7.20.2007 - this check will skip ov rtng when no flow is present... + + sfcrt_flag = 0 + + do j=1,jxrt + do i=1,ixrt + if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then + sfcrt_flag = 1 + exit + end if + end do + if(sfcrt_flag.eq.1) exit + end do + +#ifdef MPP_LAND + call mpp_land_max_int1(sfcrt_flag) +#endif +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF) + + if (sfcrt_flag.eq.1) then !If/then for sfc_rt check... +#ifdef HYDRO_D + write(6,*) "calling OV_RTNG " +#endif + CALL OV_RTNG(DT,DTRT_TER,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT, & + CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist, & + LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,& + q_sfcflx_x,q_sfcflx_y) + else + SFCHEADSUBRT = INFXSUBRT +#ifdef HYDRO_D + print *, "No water to route overland..." +#endif + end if !Endif for sfc_rt check... + +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF) + +#ifdef HYDRO_D + print *, "OV routing called and returned..." +#endif + +!DJG Debug...OV Routing... + suminfxsrt=0. + chan_in2=0. + lake_in2=0. + qbdry2=0. + do i=1,IXRT + do j=1,JXRT + suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT) + chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT) + lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT) + qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT) + end do + end do +#ifdef MPP_LAND +! not tested + CALL sum_real1(suminfxsrt) + CALL sum_real1(chan_in2) + CALL sum_real1(lake_in2) + CALL sum_real1(qbdry2) + suminfxsrt = suminfxsrt/float(numprocs) + chan_in2 = chan_in2/float(numprocs) + lake_in2 = lake_in2/float(numprocs) + qbdry2 = qbdry2/float(numprocs) +#endif + +#ifdef HYDRO_D +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + print *, "OV Routing Mass Bal: " + print *, "WB_OV!InfxsDiff", suminfxsrt-suminfxs1 + print *, "WB_OV!Infxs1", suminfxs1 + print *, "WB_OV!Infxs2", suminfxsrt + print *, "WB_OV!ChaninDiff", chan_in2-chan_in1 + print *, "WB_OV!Chanin1", chan_in1 + print *, "WB_OV!Chanin2", chan_in2 + print *, "WB_OV!LakeinDiff", lake_in2-lake_in1 + print *, "WB_OV!Lakein1", lake_in1 + print *, "WB_OV!Lakein2", lake_in2 + print *, "WB_OV!QbdryDiff", qbdry2-qbdry1 + print *, "WB_OV!Qbdry1", qbdry1 + print *, "WB_OV!Qbdry2", qbdry2 + print *, "WB_OV!Residual", (suminfxs1-suminfxsrt)-(chan_in2-chan_in1) & + -(lake_in2-lake_in1)-(qbdry2-qbdry1) +#ifdef MPP_LAND + endif +#endif +#endif + + + end subroutine OverlandRouting + + + subroutine time_seconds(i3) + integer time_array(8) + real*8 i3 + call date_and_time(values=time_array) + i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & + time_array(7) + 0.001 * time_array(8) + return + end subroutine time_seconds + diff --git a/wrfv2_fire/hydro/Routing/module_GW_baseflow.F b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F new file mode 100644 index 00000000..299e15ac --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F @@ -0,0 +1,528 @@ +! Program Name: +! 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_GW_baseflow + +#ifdef MPP_LAND + use module_mpp_land + use MODULE_mpp_GWBUCKET, only: gw_sum_real, gw_write_io_real + use MODULE_mpp_ReachLS, only : updatelinkv +#endif + implicit none + +#include "rt_include.inc" +!yw #include "namelist.inc" +contains + +!------------------------------------------------------------------------------ +!DJG Simple GW Bucket Model +! for NHDPLUS mapping +!------------------------------------------------------------------------------ + + subroutine simp_gw_buck_nhd(ix,jx,ixrt,jxrt,numbasns, AGGFACTRT, DT, INFXSWGT & + , runoff1x_in, runoff2x_in,cellArea,area_lsm & + , c, ex,z_mx,z_gwsubbas_tmp, qout_gwsubbas, qin_gwsubbas,GWBASESWCRT,OVRTSWCRT & + , LNLINKSL, basns_area, nhdBuckMask ) + + use module_UDMAP, only: LNUMRSL, LUDRSL + + implicit none + +!!!Declarations... + integer, intent(in) :: ix,jx,ixrt,jxrt + integer, intent(in) :: numbasns, lnlinksl + real, intent(in), dimension(ix,jx) :: runoff2x_in + real, dimension(ixrt,jxrt) :: runoff2x , runoff1x + real, intent(in), dimension(ix,jx) :: runoff1x_in, area_lsm + real, intent(in) :: cellArea(ixrt,jxrt),DT + real, intent(in),dimension(numbasns) :: C,ex + real, intent(inout),dimension(numbasns) :: z_mx + real, intent(out),dimension(numbasns) :: qout_gwsubbas + real, intent(out),dimension(numbasns) :: qin_gwsubbas + real*8 :: z_gwsubbas(numbasns) + real :: qout_max, qout_spill, z_gw_spill + real, intent(inout),dimension(:) :: z_gwsubbas_tmp + real, intent(in),dimension(ixrt,jxrt) :: INFXSWGT + integer, intent(in) :: GWBASESWCRT + integer, intent(in) :: OVRTSWCRT + real, intent(in), dimension(numbasns) :: basns_area + + + real, dimension(numbasns) :: net_perc + integer, dimension(numbasns) :: nhdBuckMask + + integer :: i,j,bas, k, m, ii,jj + + integer :: AGGFACYRT, AGGFACTRT, AGGFACXRT, IXXRT, JYYRT + real*8, dimension(LNLINKSL) :: LQLateral + + + +!!!Initialize variables... + net_perc = 0. + qout_gwsubbas = 0. + qin_gwsubbas = 0. + z_gwsubbas(1:numbasns) = z_gwsubbas_tmp(1:numbasns) + +!Assign local value of runoff2 (drainage) for flux caluclation to buckets... + + do J=1,JX + do I=1,IX + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +! if(AGGFACTRT .eq. 1) then +! IXXRT=I +! JYYRT=J +! endif +#endif +!DJG Implement subgrid weighting routine... + if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then + runoff1x(IXXRT,JYYRT) = 0 + else + runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J) & + *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT) + endif + + if( (runoff2x_in(i,j) .lt. 0) .or. (runoff2x_in(i,j) .gt. 1000) ) then + runoff2x(IXXRT,JYYRT) = 0 + else + runoff2x(IXXRT,JYYRT)=runoff2x_in(i,j)*area_lsm(I,J) & + *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT) + endif + enddo + enddo + enddo + enddo + + + LQLateral = 0 + do k = 1, LNUMRSL + ! get from land grid runoff + do m = 1, LUDRSL(k)%ncell + ii = LUDRSL(k)%cell_i(m) + jj = LUDRSL(k)%cell_j(m) + if(ii .gt. 0 .and. jj .gt. 0) then + if(OVRTSWCRT.ne.1) then + LQLateral(k) = LQLateral(k)+runoff1x(ii,jj)*LUDRSL(k)%cellWeight(m)/1000 & + *cellArea(ii,jj) + endif + LQLateral(k) = LQLateral(k)+runoff2x(ii,jj)*LUDRSL(k)%cellWeight(m)/1000 & + *cellArea(ii,jj) + endif + end do + end do + + +#ifdef MPP_LAND + call updateLinkV(LQLateral, net_perc) ! m^3 + +#else + net_perc = LQLateral ! m^3 +#endif + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!Loop through GW basins to adjust for inflow/outflow +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + DO bas=1,numbasns ! Loop for GW bucket calcs... + if(nhdBuckMask(bas) .eq. 1) then ! if the basn is masked + qin_gwsubbas(bas) = net_perc(bas) !units (m^3) + +!Adjust level of GW depth...(conceptual GW bucket units (mm)) + + z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / basns_area(bas) ! m + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!Calculate baseflow as a function of GW bucket depth... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if(GWBASESWCRT.eq.1) then !active exponential bucket... if/then for bucket model discharge type... + +!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled... + qout_spill = 0. + z_gw_spill = 0. + +!!DJG...convert z_mx to millimeters...for v2 and later... +!yw added by Wei Yu...If block is to accomodate old parameter file... +! if(z_mx(bas) .gt. 5) then +! z_mx(bas) = z_mx(bas) /1000 ! change from mm to meters +! endif + + + if (z_gwsubbas(bas).gt.z_mx(bas)/1000.) then !If/then for bucket overflow case... + + z_gw_spill = z_gwsubbas(bas) - z_mx(bas)/1000. ! meters + z_gwsubbas(bas) = z_mx(bas)/1000. ! meters + + else + z_gw_spill = 0. + end if ! End if for bucket overflow case... + + qout_spill = z_gw_spill*(basns_area(bas))/DT !amount spilled from bucket overflow...units (m^3/s) + +!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket... + qout_max = z_gwsubbas(bas)*(basns_area(bas))/DT ! (m^3/s) ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s) + + +! Assume exponential relation between z/zmax and Q... +!DJG force asymptote to zero to prevent 'overdraft'... + qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)/1000.)-1) !Exp.model. q_out (m^3/s) + +!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... + qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit (m^3/s) + + elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket + +! Assuming a steady-state (inflow=outflow) model... +!DJG convert input and output units to cms... qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3) + qout_gwsubbas(bas) = qin_gwsubbas(bas)/DT !steady-state model...(m^3/s) + + end if ! End if for bucket model discharge type.... + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!Adjust level of GW depth in bucket... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & + basns_area(bas) ) ! units (meters) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!Combine calculated bucket discharge and amount spilled from bucket... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill ! units (m^3/s) + else + qout_gwsubbas(bas) = 0.0 + endif ! the basns is masked + + + END DO ! End loop for GW bucket calcs... + + z_gwsubbas_tmp(1:numbasns) = z_gwsubbas(1:numbasns) ! units (meters) + + return + +!------------------------------------------------------------------------------ + End subroutine simp_gw_buck_nhd +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +!DJG Simple GW Bucket Model +!------------------------------------------------------------------------------ + + subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,gw_strm_msk_lind,& + gwsubbasmsk, runoff1x_in, runoff2x_in, z_gwsubbas_tmp, qin_gwsubbas,& + qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,& + C,ex,z_mx,GWBASESWCRT,OVRTSWCRT) + implicit none + +!!!Declarations... + integer, intent(in) :: ix,jx,ixrt,jxrt + integer, intent(in) :: numbasns, gnumbasns + integer, intent(in), dimension(ix,jx) :: gwsubbasmsk + real, intent(in), dimension(ix,jx) :: runoff2x_in + real, dimension(ix,jx) :: runoff2x + real, intent(in), dimension(ix,jx) :: runoff1x_in + real, dimension(ix,jx) :: runoff1x + real, intent(in) :: basns_area(numbasns),dist(ixrt,jxrt,9),DT + integer, intent(in) :: basnsInd(numbasns) + real, intent(in),dimension(numbasns) :: C,ex,z_mx + real, intent(out),dimension(numbasns) :: qout_gwsubbas + real, intent(out),dimension(numbasns) :: qin_gwsubbas + real*8 :: z_gwsubbas(numbasns) + real :: qout_max, qout_spill, z_gw_spill + real, intent(inout),dimension(numbasns) :: z_gwsubbas_tmp + real, intent(out),dimension(ixrt,jxrt) :: qinflowbase + integer, intent(in),dimension(ixrt,jxrt) :: gw_strm_msk, gw_strm_msk_lind + integer, intent(in) :: GWBASESWCRT + integer, intent(in) :: OVRTSWCRT + + + real*8, dimension(numbasns) :: sum_perc8,ct_bas8 + real, dimension(numbasns) :: sum_perc + real, dimension(numbasns) :: net_perc + + real, dimension(numbasns) :: ct_bas + real, dimension(numbasns) :: gwbas_pix_ct + integer :: i,j,bas, k + character(len=19) :: header + character(len=1) :: jnk + + +!!!Initialize variables... + ct_bas8 = 0 + sum_perc8 = 0. + net_perc = 0. + qout_gwsubbas = 0. + qin_gwsubbas = 0. + z_gwsubbas = z_gwsubbas_tmp + +!Assign local value of runoff2 (drainage) for flux caluclation to buckets... + runoff2x = runoff2x_in + runoff1x = runoff1x_in + + + + +!!!Calculate aggregated percolation from deep runoff into GW basins... + do i=1,ix + do j=1,jx + +!!DJG 4/15/2015...reset runoff2x, runoff1x, values to 0 where extreme values exist...(<0 or +!> 1000) + if((runoff2x(i,j).lt.0.).OR.(runoff2x(i,j).gt.1000.)) then + runoff2x(i,j)=0. + end if + if((runoff1x(i,j).lt.0.).OR.(runoff1x(i,j).gt.1000.)) then + runoff1x(i,j)=0. + end if + + do bas=1,numbasns + if(gwsubbasmsk(i,j).eq.basnsInd(bas) ) then + if(OVRTSWCRT.ne.0) then + sum_perc8(bas) = sum_perc8(bas)+runoff2x(i,j) !Add only drainage to bucket...runoff2x in (mm) + else + sum_perc8(bas) = sum_perc8(bas)+runoff1x(i,j)+runoff2x(i,j) !Add sfc water & drainage to bucket...runoff1x and runoff2x in (mm) + end if + ct_bas8(bas) = ct_bas8(bas) + 1 + end if + end do + end do + end do + +#ifdef MPP_LAND + call gw_sum_real(sum_perc8,numbasns,gnumbasns,basnsInd) + call gw_sum_real(ct_bas8,numbasns,gnumbasns,basnsInd) +#endif + sum_perc = sum_perc8 + ct_bas = ct_bas8 + + + + +!!!Loop through GW basins to adjust for inflow/outflow + + DO bas=1,numbasns ! Loop for GW bucket calcs... +! #ifdef MPP_LAND +! if(ct_bas(bas) .gt. 0) then +! #endif + + net_perc(bas) = sum_perc(bas) / ct_bas(bas) !units (mm) +!DJG...old change to cms qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3) + qin_gwsubbas(bas) = net_perc(bas)/1000.* & + ct_bas(bas)*basns_area(bas)/DT !units (m^3/s) + + +!Adjust level of GW depth...(conceptual GW bucket units (mm)) +!DJG...old change to cms inflow... z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0 ! (m) + +!DJG...debug write (6,*) "DJG...before",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas) + + z_gwsubbas(bas) = z_gwsubbas(bas) + qin_gwsubbas(bas)*DT/( & + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + + + + + +!Calculate baseflow as a function of GW bucket depth... + + if(GWBASESWCRT.eq.1) then !active exponential bucket... if/then for bucket model discharge type... + +!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled... + qout_spill = 0. + z_gw_spill = 0. + if (z_gwsubbas(bas).gt.z_mx(bas)) then !If/then for bucket overflow case... + z_gw_spill = z_gwsubbas(bas) - z_mx(bas) + z_gwsubbas(bas) = z_mx(bas) +#ifdef HYDRO_D + write (6,*) "Bucket spilling...", bas, z_gwsubbas(bas), z_mx(bas), z_gw_spill +#endif + else + z_gw_spill = 0. + end if ! End if for bucket overflow case... + + qout_spill = z_gw_spill/1000.*(ct_bas(bas)*basns_area(bas))/DT !amount spilled from bucket overflow...units (cms) + + +!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket... + qout_max = z_gwsubbas(bas)/1000.*(ct_bas(bas)*basns_area(bas))/DT ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s) + + +! Assume exponential relation between z/zmax and Q... +!DJG...old...creates non-asymptotic flow... qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s) +!DJG force asymptote to zero to prevent 'overdraft'... +!DJG debug hardwire test... qout_gwsubbas(bas) = 1*(EXP(7.0*10./100.)-1) !Exp.model. q_out (m^3/s) + qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas))-1) !Exp.model. q_out (m^3/s) + +!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... + qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit + +!DJG...debug... write (6,*) "DJG-exp bucket...during",C(bas),ex(bas),z_gwsubbas(bas),qin_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max, qout_spill + + + + elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket + +! Assuming a steady-state (inflow=outflow) model... +!DJG convert input and output units to cms... qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3) + qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3/s) + +!DJG...debug write (6,*) "DJG-pass through...during",C(bas),ex(bas),qin_gwsubbas(bas), z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max + + end if ! End if for bucket model discharge type.... + + + + +!Adjust level of GW depth... +!DJG bug adjust output to be mm and correct area bug... z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT & +!DJG bug adjust output to be mm and correct area bug... / (ct_bas(bas)*basns_area(bas)) !units(m) + + z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + +!DJG...Combine calculated bucket discharge and amount spilled from bucket... + qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill ! units (cms) + + +!DJG...debug write (6,*) "DJG...after",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_spill +!DJG...debug write (6,*) "DJG...after...calc",bas,ct_bas(bas),ct_bas(bas)*basns_area(bas),basns_area(bas),DT + + + + +! #ifdef MPP_LAND +! endif +! #endif + END DO ! End loop for GW bucket calcs... + + z_gwsubbas_tmp = z_gwsubbas + + +!!!Distribute basin integrated baseflow to stream pixels as stream 'inflow'... + + qinflowbase = 0. + + + do i=1,ixrt + do j=1,jxrt +!!! -simple uniform disaggregation (8.31.06) + if (gw_strm_msk_lind(i,j).gt.0) then + + qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk_lind(i,j))*1000.*DT/ & + gwbas_pix_ct(gw_strm_msk_lind(i,j))/dist(i,j,9) ! units (mm) that gets passed into chan routing as stream inflow + + end if + end do + end do + + +!!! - weighted redistribution...(need to pass accum weights (slope) in...) +! NOT FINISHED just BASIC framework... +! do bas=1,numbasns +! do k=1,gwbas_pix_ct(bas) +! qinflowbase(i,j) = k*slope +! end do +! end do + + z_gwsubbas = z_gwsubbas_tmp + + return + +!------------------------------------------------------------------------------ + End subroutine simp_gw_buck +!------------------------------------------------------------------------------ + + + + +#ifdef MPP_LAND + subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns,gnumbasns,basnsInd) + USE module_mpp_land + implicit none + integer :: i,j,ixrt,jxrt,numbasns, bas, gnumbasns, k + integer,dimension(ixrt,jxrt) :: in_gw_strm_msk + integer,dimension(global_rt_nx,global_rt_ny) :: gw_strm_msk + real,dimension(numbasns) :: gwbas_pix_ct + real,dimension(gnumbasns) :: tmp_gwbas_pix_ct + integer, intent(in), dimension(:) :: basnsInd + + gw_strm_msk = 0 + + + call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk) + + call mpp_land_sync() + + if(my_id .eq. IO_id) then +! tmp_gwbas_pix_ct = 0.0 +! do bas = 1,gnumbasns +! do i=1,global_rt_nx +! do j=1,global_rt_ny +! if(gw_strm_msk(i,j) .eq. bas) then +! tmp_gwbas_pix_ct(bas) = tmp_gwbas_pix_ct(bas) + 1.0 +! endif +! end do +! end do +! end do + + tmp_gwbas_pix_ct = 0.0 + do i=1,global_rt_nx + do j=1,global_rt_ny + if(gw_strm_msk(i,j) .gt. 0) then + bas = gw_strm_msk(i,j) + tmp_gwbas_pix_ct(bas) = tmp_gwbas_pix_ct(bas) + 1.0 + endif + end do + end do + end if + + call mpp_land_sync() + + if(gnumbasns .gt. 0) then + call mpp_land_bcast_real(gnumbasns,tmp_gwbas_pix_ct) + endif + do k = 1, numbasns + bas = basnsInd(k) + gwbas_pix_ct(k) = tmp_gwbas_pix_ct(bas) + end do + + + return + end subroutine pix_ct_1 +#endif + + + + + +end module module_GW_baseflow diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_io.F b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F new file mode 100644 index 00000000..26f44fd1 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F @@ -0,0 +1,9923 @@ +! Program Name: +! 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_HYDRO_io +#ifdef MPP_LAND + use module_mpp_land + use module_mpp_reachls, only: ReachLS_decomp, reachls_wreal, ReachLS_write_io, & + ReachLS_wInt, reachls_wreal2, TONODE2RSL, gbcastvalue + use MODULE_mpp_GWBUCKET, only: gw_write_io_real, gw_write_io_int +#endif + use Module_Date_utilities_rt, only: geth_newdate + use module_HYDRO_utils, only: get_dist_ll + use module_namelist, only: nlst_rt + use module_RT_data, only: rt_domain + use module_gw_gw2d_data, only: gw2d + use netcdf + + implicit none +#include + + contains + + integer function get2d_real(var_name,out_buff,ix,jx,fileName, fatalErr) + implicit none + integer :: ivar, iret,varid,ncid,ix,jx + real out_buff(ix,jx) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: fileName + logical, optional, intent(in) :: fatalErr + logical :: fatalErr_local + character(len=256) :: errMsg + + fatalErr_local = .false. + if(present(fatalErr)) fatalErr_local=fatalErr + + get2d_real = -1 + + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) + if (iret .ne. 0) then + errMsg = "get2d_real: failed to open the netcdf file: " // trim(fileName) + print*, trim(errMsg) + if(fatalErr_local) call hydro_stop(trim(errMsg)) + out_buff = -9999. + return + endif + + ivar = nf_inq_varid(ncid,trim(var_name), varid) + if(ivar .ne. 0) then + ivar = nf_inq_varid(ncid,trim(var_name//"_M"), varid) + if(ivar .ne. 0) then + errMsg = "get2d_real: failed to find the variables: " // & + trim(var_name) // ' and ' // trim(var_name//"_M") // & + ' in ' // trim(fileName) + write(6,*) errMsg + if(fatalErr_local) call hydro_stop(errMsg) + return + endif + end if + + iret = nf_get_var_real(ncid, varid, out_buff) + if(iret .ne. 0) then + errMsg = "get2d_real: failed to read the variable: " // & + trim(var_name) // ' or ' // trim(var_name//"_M") // & + ' in ' // trim(fileName) + print*,trim(errMsg) + if(fatalErr_local) call hydro_stop(trim(errMsg)) + return + endif + + iret = nf_close(ncid) + if(iret .ne. 0) then + errMsg = "get2d_real: failed to close the file: " // & + trim(fileName) + print*,trim(errMsg) + if(fatalErr_local) call hydro_stop(trim(errMsg)) + endif + + get2d_real = ivar + end function get2d_real + + + subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName) + implicit none + integer ix,jx, status + character (len=*),intent(in) :: var_name, fileName + real,dimension(ix,jx):: out_buff + + +#ifdef MPP_LAND +#ifdef PARALLELIO + status = get2d_real(var_name,out_buff,ix,jx,fileName) +#else + real,allocatable, dimension(:,:) :: buff_g + + +#ifdef HYDRO_D + write(6,*) "start to read variable ", var_name +#endif + if(my_id .eq. IO_id) then + allocate(buff_g (global_nx,global_ny) ) + status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName) + else + allocate(buff_g (1,1) ) + end if + call decompose_data_real(buff_g,out_buff) + if(allocated(buff_g)) deallocate(buff_g) +#endif +#else + status = get2d_real(var_name,out_buff,ix,jx,fileName) +#endif +#ifdef HYDRO_D + write(6,*) "finish reading variable ", var_name +#endif + end subroutine get2d_lsm_real + + subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) + implicit none + integer ix,jx, status,land_cat, iret, dimid,ncid + character (len=*),intent(in) :: fileName + character (len=256) units + integer,dimension(ix,jx):: out_buff + real, dimension(ix,jx) :: xdum +#ifdef MPP_LAND + real,allocatable, dimension(:,:) :: buff_g + + +#ifndef PARALLELIO + if(my_id .eq. IO_id) then + allocate(buff_g (global_nx,global_ny) ) + else + allocate(buff_g (1,1) ) + endif + if(my_id .eq. IO_id) then +#endif +#endif + ! Open the NetCDF file. + iret = nf_open(fileName, NF_NOWRITE, ncid) + if (iret /= 0) then + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(fileName) + call hydro_stop("In get2d_lsm_vegtyp() - Problem opening geo_static file") + endif + + iret = nf_inq_dimid(ncid, "land_cat", dimid) + if (iret /= 0) then + call hydro_stop("In get2d_lsm_vegtyp() - nf_inq_dimid: land_cat problem ") + endif + + iret = nf_inq_dimlen(ncid, dimid, land_cat) + if (iret /= 0) then + call hydro_stop("In get2d_lsm_vegtyp() - nf_inq_dimlen: land_cat problem") + endif + +#ifdef MPP_LAND +#ifndef PARALLELIO + call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) + end if + call decompose_data_real(buff_g,xdum) + if(allocated(buff_g)) deallocate(buff_g) +#else + call get_landuse_netcdf(ncid, xdum, units, ix, jx, land_cat) +#endif + iret = nf_close(ncid) + +#else + call get_landuse_netcdf(ncid, xdum, units, ix, jx, land_cat) + iret = nf_close(ncid) +#endif + out_buff = nint(xdum) + end subroutine get2d_lsm_vegtyp + + + + subroutine get_file_dimension(fileName, ix,jx) + implicit none + character(len=*) fileName + integer ncid , iret, ix,jx, dimid +#ifdef MPP_LAND +#ifndef PARALLELIO + if(my_id .eq. IO_id) then +#endif +#endif + iret = nf_open(fileName, NF_NOWRITE, ncid) + if (iret /= 0) then + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(fileName) + call hydro_stop("In get_file_dimension() - Problem opening geo_static file") + endif + + iret = nf_inq_dimid(ncid, "west_east", dimid) + + if (iret /= 0) then + call hydro_stop("In get_file_dimension() - nf_inq_dimid: west_east problem") + endif + + iret = nf_inq_dimlen(ncid, dimid, ix) + if (iret /= 0) then + call hydro_stop("In get_file_dimension() - nf_inq_dimlen: west_east problem") + endif + + iret = nf_inq_dimid(ncid, "south_north", dimid) + if (iret /= 0) then + call hydro_stop("In get_file_dimension() - nf_inq_dimid: south_north problem.") + endif + + iret = nf_inq_dimlen(ncid, dimid, jx) + if (iret /= 0) then + call hydro_stop("In get_file_dimension() - nf_inq_dimlen: south_north problem") + endif + iret = nf_close(ncid) +#ifdef MPP_LAND +#ifndef PARALLELIO + endif + call mpp_land_bcast_int1(ix) + call mpp_land_bcast_int1(jx) +#endif +#endif + + end subroutine get_file_dimension + + subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) + implicit none + integer ix,jx, status,land_cat, iret, dimid,ncid + character (len=*),intent(in) :: fileName + character (len=256) units + integer,dimension(ix,jx):: out_buff + real, dimension(ix,jx) :: xdum +#ifdef MPP_LAND +#ifndef PARALLELIO + real,allocatable, dimension(:,:) :: buff_g + + + if(my_id .eq. IO_id) then + allocate(buff_g (global_nx,global_ny) ) +#endif +#endif + ! Open the NetCDF file. + iret = nf_open(fileName, NF_NOWRITE, ncid) + if (iret /= 0) then + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(fileName) + call hydro_stop("In get2d_lsm_soltyp() - problem to open geo_static file.") + endif + + iret = nf_inq_dimid(ncid, "soil_cat", dimid) + if (iret /= 0) then + call hydro_stop("In get2d_lsm_soltyp() - nf_inq_dimid: soil_cat problem") + endif + + iret = nf_inq_dimlen(ncid, dimid, land_cat) + if (iret /= 0) then + call hydro_stop("In get2d_lsm_soltyp() - nf_inq_dimlen: soil_cat problem") + endif + +#ifdef MPP_LAND +#ifndef PARALLELIO + call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) + end if + call decompose_data_real(buff_g,xdum) + if(my_id .eq. io_id) then + if(allocated(buff_g)) deallocate(buff_g) + endif +#else + call get_soilcat_netcdf(ncid, xdum, units, ix, jx, land_cat) +#endif + iret = nf_close(ncid) +#else + call get_soilcat_netcdf(ncid, xdum, units, ix, jx, land_cat) + iret = nf_close(ncid) +#endif + out_buff = nint(xdum) + end subroutine get2d_lsm_soltyp + + + subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim) + implicit none +#include + integer, intent(in) :: ncid + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim), intent(out) :: array + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j, l + character(len=24), parameter :: name = "LANDUSEF" + + units = "" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_landuse_netcdf() - nf_inq_varid problem") + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_landuse_netcdf() - nf_get_var_real problem") + endif + + do i = 1, idim + do j = 1, jdim + mp = maxloc(xtmp(i,j,:)) + array(i,j) = mp(1) + do l = 1,ldim + if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0 + enddo + enddo + enddo + + end subroutine get_landuse_netcdf + + + subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim) + implicit none +#include + + integer, intent(in) :: ncid + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim), intent(out) :: array + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j, did + character(len=24), parameter :: name = "SOILCTOP" + + did = 1 + units = "" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_soilcat_netcdf() - nf_inq_varid problem") + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_soilcat_netcdf() - nf_get_var_real problem") + endif + + do i = 1, idim + do j = 1, jdim + mp = maxloc(xtmp(i,j,:)) + array(i,j) = mp(1) + enddo + enddo + + if(nlst_rt(did)%GWBASESWCRT .ne. 3) then + where (array == 14) array = 1 ! DJG remove all 'water' soils... + endif + + end subroutine get_soilcat_netcdf + + +subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) + implicit none +#include + integer, intent(in) :: ncid,mm,dd + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim) :: array + real, dimension(idim,jdim) :: array2 + real, dimension(idim,jdim) :: diff + real, dimension(idim,jdim), intent(out) :: array3 + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j, mm2,daytot + real :: ddfrac + character(len=24), parameter :: name = "GREENFRAC" + + units = "fraction" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_greenfrac_netcdf() - nf_inq_varid problem") + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_greenfrac_netcdf() - nf_get_var_real problem") + endif + + + if (mm.lt.12) then + mm2 = mm+1 + else + mm2 = 1 + end if + +!DJG_DES Set up dates for daily interpolation... + if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then + daytot = 31 + else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then + daytot = 30 + else if (mm.eq.2) then + daytot = 28 + end if + ddfrac = float(dd)/float(daytot) + if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th + +#ifdef HYDRO_D + print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac + +#endif + do i = 1, idim + do j = 1, jdim + array(i,j) = xtmp(i,j,mm) !GREENFRAC in geogrid in units of fraction from month 1 + array2(i,j) = xtmp(i,j,mm2) !GREENFRAC in geogrid in units of fraction from month 1 + diff(i,j) = array2(i,j) - array(i,j) + array3(i,j) = array(i,j) + ddfrac * diff(i,j) + enddo + enddo + +end subroutine get_greenfrac_netcdf + + + +subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) + implicit none +#include + integer, intent(in) :: ncid,mm,dd + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim) :: array + real, dimension(idim,jdim) :: array2 + real, dimension(idim,jdim) :: diff + real, dimension(idim,jdim), intent(out) :: array3 + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j, mm2,daytot + real :: ddfrac + character(len=24), parameter :: name = "ALBEDO12M" + + + units = "fraction" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_albedo12m_netcdf() - nf_inq_varid problem") + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_albedo12m_netcdf() - nf_get_var_real problem") + endif + + if (mm.lt.12) then + mm2 = mm+1 + else + mm2 = 1 + end if + +!DJG_DES Set up dates for daily interpolation... + if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then + daytot = 31 + else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then + daytot = 30 + else if (mm.eq.2) then + daytot = 28 + end if + ddfrac = float(dd)/float(daytot) + if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th + +#ifdef HYDRO_D + print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac +#endif + + do i = 1, idim + do j = 1, jdim + array(i,j) = xtmp(i,j,mm) / 100.0 !Convert ALBEDO12M from % to fraction...month 1 + array2(i,j) = xtmp(i,j,mm2) / 100.0 !Convert ALBEDO12M from % to fraction... month 2 + diff(i,j) = array2(i,j) - array(i,j) + array3(i,j) = array(i,j) + ddfrac * diff(i,j) + enddo + enddo + +end subroutine get_albedo12m_netcdf + + + + + subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & + fatal_if_error, ierr) + implicit none +#include + character(len=*), intent(in) :: name + integer, intent(in) :: ncid + integer, intent(in) :: idim, jdim + real, dimension(idim,jdim), intent(out) :: array + character(len=256), intent(out) :: units + integer :: iret, varid + ! .TRUE._IF_ERROR: an input code value: + ! .TRUE. if an error in reading the data should stop the program. + ! Otherwise the, IERR error flag is set, but the program continues. + logical, intent(in) :: fatal_if_error + integer, intent(out) :: ierr + + units = "" + + iret = nf_inq_varid(ncid, name, varid) + + if (iret /= 0) then + if (fatal_IF_ERROR) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_2d_netcdf() - nf_inq_varid problem") + else + ierr = iret + return + endif + endif + + + iret = nf_get_var_real(ncid, varid, array) + if (iret /= 0) then + if (fatal_IF_ERROR) then + print*, 'name = "', trim(name)//'"' + call hydro_stop("In get_2d_netcdf() - nf_get_var_real problem") + else + ierr = iret + return + endif + endif + + ierr = 0; + end subroutine get_2d_netcdf + + + subroutine get_2d_netcdf_cows(var_name,ncid,var, & + ix,jx,tlevel,fatal_if_error,ierr) +#include + character(len=*), intent(in) :: var_name + integer,intent(in) :: ncid,ix,jx,tlevel + real, intent(out):: var(ix,jx) + logical, intent(in) :: fatal_if_error + integer ierr, iret + integer varid + integer start(4),count(4) + data count /1,1,1,1/ + data start /1,1,1,1/ + count(1) = ix + count(2) = jx + start(4) = tlevel + iret = nf_inq_varid(ncid, var_name, varid) + + if (iret /= 0) then + if (fatal_IF_ERROR) then + call hydro_stop("In get_2d_netcdf_cows() - nf_inq_varid problem") + else + ierr = iret + return + endif + endif + iret = nf_get_vara_real(ncid, varid, start,count,var) + + return + end subroutine get_2d_netcdf_cows + +!--------------------------------------------------------- +!DJG Subroutinesfor inputting routing fields... +!DNY first reads the files to get the size of the +!DNY LINKS arrays +!DJG - Currently only hi-res topo is read +!DJG - At a future time, use this routine to input +!DJG subgrid land-use classification or routing +!DJG parameters 'overland roughness' and 'retention +!DJG depth' +! +!DJG,DNY - Update this subroutine to read in channel and lake +! parameters if activated 11.20.2005 +!--------------------------------------------------------- + + SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & + route_direction_f, NLINKS, & + CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT) + + implicit none +#include + INTEGER :: I,J,channel_option,jj + INTEGER, INTENT(INOUT) :: NLINKS, NLINKSL + INTEGER, INTENT(IN) :: IXRT,JXRT + INTEGER :: CHNID,cnt + INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction + INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, DIMENSION(IXRT,JXRT) :: LAT, LON + INTEGER, DIMENSION(IXRT,JXRT) :: CH_LNKRT !- link routing ID + integer, INTENT(IN) :: UDMP_OPT + +!!Dummy read in grids for inverted y-axis + + + CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name + + ! variables for handling netcdf dimensions + integer :: iRet, ncid, dimId + logical :: routeLinkNetcdf + + NLINKS = 0 + CH_NETRT = -9999 + CH_NETLNK = -9999 + + NLINKSL = 0 + CH_LNKRT = -9999 + + + + cnt = 0 +#ifdef HYDRO_D + print *, "Channel Option in Routedim is ", channel_option +#endif + + + if (channel_option .eq. 4) return ! it will run Rapid + + +!-- will always read channel grid IF(channel_option.eq.3) then !get maxnodes and links from grid + + var_name = "CHANNELGRID" + call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + + +!-- new link id variable to handle link routing + var_name = "LINKID" +#ifdef MPP_LAND +#ifdef HYDRO_D + write(6,*) "read LINKID for CH_LNKRT from ", trim(geo_finegrid_flnm) +#endif +#endif +!!!! LINKID is used for reach based method. ? + IF(channel_option.ne.3 .and. UDMP_OPT.ne.1) then !get maxnodes and links from grid + call readRT2d_int(var_name,CH_LNKRT,ixrt,jxrt,& + trim(geo_finegrid_flnm), fatalErr=.TRUE.) + endif + + + + var_name = "FLOWDIRECTION" + call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +!note that this is not used for link routing + var_name = "LAKEGRID" + call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + + + var_name = "LATITUDE" + call readRT2d_real(var_name,LAT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + var_name = "LONGITUDE" + call readRT2d_real(var_name,LON,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + +!DJG inv do j=jxrt,1,-1 + do j=1,jxrt + do i = 1, ixrt +! if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then + if (CH_NETRT(i,j) .ge.0) then + NLINKS = NLINKS + 1 + if( UDMP_OPT .eq. 1) CH_NETLNK(i,j) = 2 + endif + end do + end do +#ifdef HYDRO_D + print *, "NLINKS IS ", NLINKS +#endif + if( UDMP_OPT .eq. 1) then + return + endif + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction + If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT) ) then !North + if(CH_NETRT(i,j+1) .ge.0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) ) then !North East + if(CH_NETRT(i+1,j+1) .ge.0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT)) then !East + if(CH_NETRT(i+1,j) .ge. 0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0)) then !south east + if(CH_NETRT(i+1,j-1).ge.0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0)) then !due south + if(CH_NETRT(i,j-1).ge.0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0) ) then !south west + if(CH_NETRT(i-1,j-1).ge.0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0)) then !West + if(CH_NETRT(i-1,j).ge.0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) ) then !North West + if(CH_NETRT(i-1,j+1).ge.0) then + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + endif + else +#ifdef HYDRO_D + write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j +#endif +135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) + if (DIRECTION(i,j) .eq. 0) then +#ifdef HYDRO_D + print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" +#endif + endif + + End If + End If !CH_NETRT check for this node + END DO + END DO +#ifdef HYDRO_D + print *, "found type 0 nodes", cnt +#endif +!Find out if the boundaries are on an edge or flow into a lake +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + + If ( (DIRECTION(i, j).EQ. 64) )then + if( j + 1 .GT. JXRT) then !-- 64's can only flow north + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + elseif(CH_NETRT(i,j+1) .lt. 0) then !North + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point N", cnt,CH_NETRT(i,j), i,j +#endif + endif + else if ( DIRECTION(i, j) .EQ. 128) then + if ((i + 1 .GT. IXRT) .or. (j + 1 .GT. JXRT)) then !-- 128's can flow out of the North or East edge + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + ! this is due north edge + elseif(CH_NETRT(i + 1, j + 1).lt.0) then !North East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point NE", cnt, CH_NETRT(i,j),i,j +#endif + endif + else if (DIRECTION(i, j) .EQ. 1) then + if (i + 1 .GT. IXRT) then !-- 1's can only flow due east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + elseif(CH_NETRT(i + 1, j) .lt. 0) then !East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point E", cnt,CH_NETRT(i,j), i,j +#endif + endif + else if (DIRECTION(i, j) .EQ. 2) then + !-- 2's can flow out of east or south edge + if( (i + 1 .GT. IXRT) .OR. (j - 1 .EQ. 0)) then !-- this is the south edge + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + elseif(CH_NETRT(i + 1, j - 1) .lt.0) then !south east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j +#endif + endif + else if ( DIRECTION(i, j) .EQ. 4) then + if( (j - 1 .EQ. 0)) then !-- 4's can only flow due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j +#endif + endif + else if ( DIRECTION(i, j) .EQ. 8) then + !-- 8's can flow south or west + if( (i - 1 .eq. 0) .OR. ( j - 1 .EQ. 0)) then !-- this is the south edge + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + elseif (CH_NETRT(i - 1, j - 1).lt.0) then !south west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j +#endif + endif + else if ( DIRECTION(i, j) .EQ. 16) then + if(i - 1 .eq. 0) then !-- 16's can only flow due west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + elseif (CH_NETRT(i - 1, j).lt.0) then !West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j +#endif + endif + else if ( DIRECTION(i, j) .EQ. 32) then + if ( (i - 1 .eq. 0) & !-- 32's can flow either west or north + .OR. (j .eq. JXRT)) then !-- this is the north edge + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point NW", cnt,CH_NETRT(i,j), i,j +#endif + endif + endif + endif !CH_NETRT check for this node + END DO + END DO + +#ifdef HYDRO_D + print *, "total number of channel elements", cnt + print *, "total number of NLINKS ", NLINKS +#endif + + + + !-- get the number of lakes + if (cnt .ne. NLINKS) then + print *, "Apparent error in network topology", cnt, NLINKS + print* , "ixrt =", ixrt, "jxrt =", jxrt + call hydro_stop("READ_ROUTEDIM") + endif + +!!-- no longer find the lakes from the 2-d hi res grid +!DJG inv do j=jxrt,1,-1 +! do j=1,jxrt +! do i = 1,ixrt +! if (LAKE_MSKRT(i,j) .gt. NLAKES) then +! NLAKES = LAKE_MSKRT(i,j) +! endif +! end do +! end do +!#ifdef HYDRO_D +! write(6,*) "finish read_red .. Total Number of Lakes in Domain = ", NLAKES +!#endif + + +!-- don't return here--! return + + END SUBROUTINE READ_ROUTEDIM + +!!! This subroutine gets the NLINKSL + subroutine get_NLINKSL(NLINKSL, channel_option, route_link_f) + implicit none + CHARACTER(len=*) :: route_link_f + integer :: NLINKSL, channel_option + CHARACTER(len=256) :: route_link_f_r + integer :: lenRouteLinkFR + logical :: routeLinkNetcdf + CHARACTER(len=256) :: InputLine + if (channel_option.ne.3) then ! overwrite the NLINKS +!-IF is now commented above else ! get nlinks from the ascii file of links +#ifdef HYDRO_D + write(6,*) "read file to get NLINKSL from", trim(route_link_f) + call flush(6) +#endif + !! is RouteLink file netcdf (*.nc) or csv (*.csv) + route_link_f_r = adjustr(route_link_f) + lenRouteLinkFR = len(route_link_f_r) + routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq. '.nc' + + if(routeLinkNetcdf) then + NLINKSL = get_netcdf_dim(trim(route_link_f), 'linkDim', & + 'READ_ROUTEDIM', fatalErr=.true.) + else + open(unit=17,file=trim(route_link_f), & !link + form='formatted',status='old') + +1011 read(17,*,end= 1999) InputLine + NLINKSL = NLINKSL + 1 + goto 1011 +1999 continue + NLINKSL = NLINKSL - 1 !-- first line is a comment + close(17) + end if ! routeLinkNetcdf + +#ifdef HYDRO_D + print *, "Number of Segments or Links on sparse network", NLINKSL + write(6,*) "NLINKSL = ", NLINKSL + call flush(6) +#endif + + end if !end-if is now for channel_option just above, not IF from further up + + return + end subroutine get_NLINKSL + + subroutine nreadRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) + implicit none + INTEGER :: iret + INTEGER, INTENT(IN) :: ixrt,jxrt + INTEGER :: i, j, ii,jj + CHARACTER(len=*):: var_name,fileName + real, INTENT(OUT), dimension(ixrt,jxrt) :: inv +#ifndef MPP_LAND + real, dimension(ixrt,jxrt) :: inv_tmp +#endif + logical, optional, intent(in) :: fatalErr + logical :: fatalErr_local +#ifdef MPP_LAND + real, allocatable,dimension(:,:) :: g_inv_tmp, g_inv +#endif + fatalErr_local = .FALSE. + if(present(fatalErr)) fatalErr_local=fatalErr + +#ifdef MPP_LAND + if(my_id .eq. io_id) then + + allocate(g_inv_tmp(global_rt_nx,global_rt_ny)) + allocate(g_inv(global_rt_nx,global_rt_ny)) + + + g_inv_tmp = -9999.9 + iret = get2d_real(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,& + trim(fileName), fatalErr=fatalErr_local) + do i=1,global_rt_nx + jj=global_rt_ny + do j=1,global_rt_ny + g_inv(i,j)=g_inv_tmp(i,jj) + jj=global_rt_ny-j + end do + end do + if(allocated(g_inv_tmp)) deallocate(g_inv_tmp) + else + allocate(g_inv(1,1)) + endif + call decompose_RT_real(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT) + if(allocated(g_inv)) deallocate(g_inv) +#else + inv_tmp = -9999.9 + iret = get2d_real(var_name,inv_tmp,ixrt,jxrt,& + trim(fileName), fatalErr=fatalErr_local) + do i=1,ixrt + jj=jxrt + do j=1,jxrt + inv(i,j)=inv_tmp(i,jj) + jj=jxrt-j + end do + end do +#endif + + + end SUBROUTINE nreadRT2d_real + + subroutine nreadRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr) + implicit none + INTEGER, INTENT(IN) :: ixrt,jxrt + INTEGER :: i, j, ii,jj, iret + CHARACTER(len=*):: var_name,fileName + integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv + integer, dimension(ixrt,jxrt) :: inv_tmp + logical, optional, intent(in) :: fatalErr + logical :: fatalErr_local +#ifdef MPP_LAND + integer, allocatable,dimension(:,:) :: g_inv_tmp, g_inv +#endif + fatalErr_local = .FALSE. + if(present(fatalErr)) fatalErr_local=fatalErr + +#ifdef MPP_LAND + if(my_id .eq. io_id) then + allocate(g_inv_tmp(global_rt_nx,global_rt_ny)) + allocate(g_inv(global_rt_nx,global_rt_ny)) + g_inv_tmp = -9999.9 + call get2d_int(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,& + trim(fileName), fatalErr=fatalErr_local) + do i=1,global_rt_nx + jj=global_rt_ny + do j=1,global_rt_ny + g_inv(i,j)=g_inv_tmp(i,jj) + jj=global_rt_ny-j + end do + end do + else + allocate(g_inv_tmp(1,1)) + allocate(g_inv(1,1)) + endif + call decompose_RT_int(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT) + if(allocated(g_inv_tmp)) deallocate(g_inv_tmp) + if(allocated(g_inv)) deallocate(g_inv) +#else + call get2d_int(var_name,inv_tmp,ixrt,jxrt,& + trim(fileName), fatalErr=fatalErr_local) + do i=1,ixrt + jj=jxrt + do j=1,jxrt + inv(i,j)=inv_tmp(i,jj) + jj=jxrt-j + end do + end do +#endif + end SUBROUTINE nreadRT2d_int +!--------------------------------------------------------- +!DJG ----------------------------------------------------- + + subroutine readRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) + implicit none + INTEGER :: iret + INTEGER, INTENT(IN) :: ixrt,jxrt + INTEGER :: i, j, ii,jj + CHARACTER(len=*):: var_name,fileName + real, INTENT(OUT), dimension(ixrt,jxrt) :: inv + real, dimension(ixrt,jxrt) :: inv_tmp + logical, optional, intent(in) :: fatalErr + logical :: fatalErr_local + fatalErr_local = .FALSE. + if(present(fatalErr)) fatalErr_local=fatalErr + inv_tmp = -9999.9 + iret = get2d_real(var_name,inv_tmp,ixrt,jxrt,& + trim(fileName), fatalErr=fatalErr_local) + do i=1,ixrt + jj=jxrt + do j=1,jxrt + inv(i,j)=inv_tmp(i,jj) + jj=jxrt-j + end do + end do + end SUBROUTINE readRT2d_real + + subroutine readRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr) + implicit none + INTEGER, INTENT(IN) :: ixrt,jxrt + INTEGER :: i, j, ii,jj + CHARACTER(len=*):: var_name,fileName + integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv + integer, dimension(ixrt,jxrt) :: inv_tmp + logical, optional, intent(in) :: fatalErr + logical :: fatalErr_local + fatalErr_local = .FALSE. + if(present(fatalErr)) fatalErr_local=fatalErr + call get2d_int(var_name,inv_tmp,ixrt,jxrt,& + trim(fileName), fatalErr=fatalErr_local) + do i=1,ixrt + jj=jxrt + do j=1,jxrt + inv(i,j)=inv_tmp(i,jj) + jj=jxrt-j + end do + end do + end SUBROUTINE readRT2d_int + +!--------------------------------------------------------- +!DJG ----------------------------------------------------- + +#ifdef MPP_LAND + subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& + gw_strm_msk,numbasns,ch_netrt,AGGFACTRT) + + USE module_mpp_land + + integer, intent(in) :: IX,JX,IXRT,JXRT,AGGFACTRT + integer, intent(out) :: numbasns + integer, intent(out), dimension(IX,JX) :: GWSUBBASMSK + integer, intent(out), dimension(IXRT,JXRT) :: gw_strm_msk + integer, intent(in), dimension(IXRT,JXRT) :: ch_netrt + character(len=256) :: gwbasmskfil + !integer,dimension(global_nX,global_ny) :: g_GWSUBBASMSK + !yw integer,dimension(global_rt_nx, global_rt_ny) :: g_gw_strm_msk,g_ch_netrt + + integer,allocatable,dimension(:,:) :: g_GWSUBBASMSK + integer,allocatable,dimension(:, :) :: g_gw_strm_msk,g_ch_netrt + + if(my_id .eq. IO_id) then + allocate(g_gw_strm_msk(global_rt_nx, global_rt_ny)) + allocate(g_ch_netrt(global_rt_nx, global_rt_ny)) + allocate(g_GWSUBBASMSK(global_nX,global_ny)) + else + allocate(g_gw_strm_msk(1,1)) + allocate(g_ch_netrt(1,1)) + allocate(g_GWSUBBASMSK(1,1)) + endif + + + call write_IO_rt_int(ch_netrt,g_ch_netrt) + + if(my_id .eq. IO_id) then + call READ_SIMP_GW(global_nX,global_ny,global_rt_nx,global_rt_ny,& + g_GWSUBBASMSK,gwbasmskfil,g_gw_strm_msk,numbasns,& + g_ch_netrt,AGGFACTRT) + endif + call decompose_data_int(g_GWSUBBASMSK,GWSUBBASMSK) + call decompose_RT_int(g_gw_strm_msk,gw_strm_msk, & + global_rt_nx, global_rt_ny,ixrt,jxrt) + call mpp_land_bcast_int1(numbasns) + + if(allocated(g_gw_strm_msk)) deallocate(g_gw_strm_msk) + if(allocated(g_ch_netrt)) deallocate(g_ch_netrt) + if(allocated(g_GWSUBBASMSK)) deallocate(g_GWSUBBASMSK) + + return + end subroutine MPP_READ_SIMP_GW +#endif + +!DJG ----------------------------------------------------- +! SUBROUTINE READ_SIMP_GW +!DJG ----------------------------------------------------- + + subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& + gw_strm_msk,numbasns,ch_netrt,AGGFACTRT) + implicit none +#include + + integer, intent(in) :: IX,JX,IXRT,JXRT,AGGFACTRT + integer, intent(in), dimension(IXRT,JXRT) :: ch_netrt + integer, intent(out) :: numbasns + integer, intent(out), dimension(IX,JX) :: GWSUBBASMSK + integer, intent(out), dimension(IXRT,JXRT) :: gw_strm_msk + character(len=256) :: gwbasmskfil + integer :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt + + numbasns = 0 + gw_strm_msk = -9999 + +!Open files... + open(unit=18,file=trim(gwbasmskfil), & + form='formatted',status='old') + +!Read in sub-basin mask... + do j=jx,1,-1 + read (18,*) (GWSUBBASMSK(i,j),i=1,ix) + end do + close(18) + + +!Loop through to count number of basins and assign basin indices to chan grid + do J=1,JX + do I=1,IX + +!Determine max number of basins...(assumes basins are numbered +! sequentially from 1 to max number of basins...) + if (GWSUBBASMSK(i,j).gt.numbasns) then + numbasns = GWSUBBASMSK(i,j) ! get count of basins... + end if + +!Assign gw basin index values to channel grid... + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT + IF(ch_netrt(IXXRT,JYYRT).ge.0) then !If channel grid cell + gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j) ! assign coarse grid basn indx to chan grid + END IF + + end do !AGGFACXRT + end do !AGGFACYRT + + end do !I-ix + end do !J-jx + +#ifdef HYDRO_D + write(6,*) "numbasns = ", numbasns +#endif + + return + +!DJG ----------------------------------------------------- + END SUBROUTINE READ_SIMP_GW +!DJG ----------------------------------------------------- + +!Wei Yu + subroutine get_gw_strm_msk_lind (ixrt,jxrt,gw_strm_msk,numbasns,basnsInd,gw_strm_msk_lind) + implicit none + integer, intent(in) :: ixrt,jxrt, numbasns + integer, dimension(:,:) :: gw_strm_msk, gw_strm_msk_lind + integer, dimension(:) :: basnsInd + integer:: i,j,k,bas + gw_strm_msk_lind = -999 + do j = 1, jxrt + do i = 1, ixrt + if(gw_strm_msk(i,j) .gt. 0) then + do k = 1, numbasns + if(gw_strm_msk(i,j) .eq. basnsInd(k)) then + gw_strm_msk_lind(i,j) = k + endif + end do + end if + end do + end do + + end subroutine get_gw_strm_msk_lind + + subroutine SIMP_GW_IND(ix,jx,GWSUBBASMSK,numbasns,gnumbasns,basnsInd) +! create an index of basin mask so that it is faster for parallel computation. + implicit none + integer, intent(in) :: ix,jx + integer, intent(in),dimension(ix,jx) :: GWSUBBASMSK + integer, intent(out):: gnumbasns + integer, intent(inout):: numbasns + integer, intent(inout),allocatable,dimension(:):: basnsInd + + integer,dimension(numbasns):: tmpbuf + + integer :: i,j,k + + + gnumbasns = numbasns + numbasns = 0 + tmpbuf = -999. + + do j = 1,jx + do i = 1, ix + if(GWSUBBASMSK(i,j) .gt.0) then + tmpbuf(GWSUBBASMSK(i,j)) = GWSUBBASMSK(i,j) + endif + end do + end do + do k = 1, gnumbasns + if(tmpbuf(k) .gt. 0) numbasns = numbasns + 1 + end do + + allocate(basnsInd(numbasns)) + + i = 1 + do k = 1, gnumbasns + if(tmpbuf(k) .gt. 0) then + basnsInd(i) = tmpbuf(k) + i = i + 1 + endif + end do +#ifdef HYDRO_D + write(6,*) "check numbasns, gnumbasns : ", numbasns, gnumbasns +#endif + + return + end subroutine SIMP_GW_IND + +!Wei Yu + subroutine read_GWBUCKPARM (numbasns,gnumbasns, basnsInd, & + gw_buck_coeff, gw_buck_exp, z_max, & + z_gwsubbas, bas_id,basns_area) +! read GWBUCKPARM file + + implicit none + integer, intent(in) :: gnumbasns, numbasns + integer, intent(in),dimension(numbasns) :: basnsInd + real, intent(out),dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, z_max, & + z_gwsubbas, basns_area + integer, intent(out),dimension(numbasns) :: bas_id + real, dimension(gnumbasns) :: tmp_buck_coeff, tmp_buck_exp, tmp_z_max, & + tmp_z_gwsubbas, tmp_basns_area + integer, dimension(gnumbasns) :: tmp_bas_id + CHARACTER(len=100) :: header + CHARACTER(len=1) :: jnk + integer :: bas,k + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif +!Read in GW bucket params and Zinit from input file in Run directory... +#ifndef NCEP_WCOSS + OPEN(81, FILE='GWBUCKPARM.TBL',FORM='FORMATTED',STATUS='OLD') + read(81,811) header +#else + OPEN(24, FORM='FORMATTED',STATUS='OLD') + read(24,811) header +#endif +811 FORMAT(A19) + + +#ifndef NCEP_WCOSS + do bas = 1,gnumbasns + +! commented out the new GWBUCKPARM.TBL used for Caralina domain +!new read(81,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & +!new jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas),jnk,tmp_basns_area(bas) +!new 812 FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4,A1,F11.3) + +!DJG...change bucket units to mm.... 812 FORMAT(I3,A1,F6.4,A1,F6.3,A1,F6.3,A1,F7.4) +! following is old GWBUCKPARM.TBL + read(81,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & + jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas) +812 FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4) + + end do + close(81) +#else + do bas = 1,gnumbasns + read(24,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & + jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas) +812 FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4) + + end do + close(24) +#endif + +#ifdef MPP_LAND + endif + + if(gnumbasns .gt. 0 ) then + call mpp_land_bcast_real(gnumbasns,tmp_buck_coeff) + call mpp_land_bcast_real(gnumbasns,tmp_buck_exp ) + call mpp_land_bcast_real(gnumbasns,tmp_z_max ) + call mpp_land_bcast_real(gnumbasns,tmp_z_gwsubbas ) + call mpp_land_bcast_real(gnumbasns,tmp_basns_area ) + call mpp_land_bcast_int(gnumbasns,tmp_bas_id) + endif +#endif + + do k = 1, numbasns + bas = basnsInd(k) + gw_buck_coeff(k) = tmp_buck_coeff(bas) + gw_buck_exp(k) = tmp_buck_exp(bas) + z_max(k) = tmp_z_max(bas) + z_gwsubbas(k) = tmp_z_gwsubbas(bas) + basns_area(k) = tmp_basns_area(bas) + bas_id(k) = tmp_bas_id(bas) + end do + end subroutine read_GWBUCKPARM + + + + ! BF read the static input fields needed for the 2D GW scheme + subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype, ihShift) + implicit none +#include + integer, intent(in) :: ix, jx + real, intent(in) :: ihShift + integer, dimension(ix,jx), intent(inout):: ltype + real, dimension(ix,jx), intent(inout) :: hc, ihead, botelv, por + +#ifdef MPP_LAND + integer, dimension(:,:), allocatable :: gLtype + real, dimension(:,:), allocatable :: gHC, gIHEAD, gBOTELV, gPOR +#endif + integer :: i + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then + allocate(gHC(global_rt_nx, global_rt_ny)) + allocate(gIHEAD(global_rt_nx, global_rt_ny)) + allocate(gBOTELV(global_rt_nx, global_rt_ny)) + allocate(gPOR(global_rt_nx, global_rt_ny)) + allocate(gLtype(global_rt_nx, global_rt_ny)) + else + allocate(gHC(1, 1)) + allocate(gIHEAD(1, 1)) + allocate(gBOTELV(1, 1)) + allocate(gPOR(1, 1)) + allocate(gLtype(1, 1)) + endif + +#ifndef PARALLELIO + if(my_id .eq. IO_id) then +#endif +#ifdef HYDRO_D + print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..." +#endif +#endif + + + ! hydraulic conductivity + i = get2d_real("HC", & +#ifdef MPP_LAND +#ifndef PARALLELIO + gHC, global_nx, global_ny, & +#else + hc, ix, jx, & +#endif +#else + hc, ix, jx, & +#endif + trim("./gwhires.nc")) + + ! initial head + i = get2d_real("IHEAD", & +#ifdef MPP_LAND + gIHEAD, global_nx, global_ny, & +#else + ihead, ix, jx, & +#endif + trim("./gwhires.nc")) + + ! aquifer bottom elevation + i = get2d_real("BOTELV", & +#ifdef MPP_LAND +#ifndef PARALLELIO + gBOTELV, global_nx, global_ny, & +#else + botelv, ix, jx, & +#endif +#else + botelv, ix, jx, & +#endif + trim("./gwhires.nc")) + + ! aquifer porosity + i = get2d_real("POR", & +#ifdef MPP_LAND +#ifndef PARALLELIO + gPOR, global_nx, global_ny, & +#else + por, ix, jx, & +#endif +#else + por, ix, jx, & +#endif + trim("./gwhires.nc")) + + + ! groundwater model mask (0 no aquifer, aquifer > 0 + call get2d_int("LTYPE", & +#ifdef MPP_LAND +#ifndef PARALLELIO + gLtype, global_nx, global_ny, & +#else + ltype, ix, jx, & +#endif +#else + ltype, ix, jx, & +#endif + trim("./gwhires.nc")) + + +#ifdef MPP_LAND +#ifndef PARALLELIO + gLtype(1,:) = 2 + gLtype(:,1) = 2 + gLtype(global_rt_nx,:) = 2 + gLtype(:,global_rt_ny) = 2 +#else +! BF TODO parallel io for gw ltype +#endif +#else + ltype(1,:) = 2 + ltype(:,1) = 2 + ltype(ix,:)= 2 + ltype(:,jx)= 2 +#endif + +#ifdef MPP_LAND +#ifndef PARALLELIO + endif + call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx) + if(allocated(gLtype)) deallocate(gLtype) + if(allocated(gHC)) deallocate(gHC) + if(allocated(gIHEAD)) deallocate(gIHEAD) + if(allocated(gBOTELV)) deallocate(gBOTELV) + if(allocated(gPOR)) deallocate(gPOR) +#endif +#endif + + + ihead = ihead + ihShift + + where(ltype .eq. 0) + hc = 0. +!yw por = 10**21 + por = 10E21 + end where + + + !bftodo: make filename accessible in namelist + return + end subroutine readGW2d + !BF + + subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & + startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & + q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & + geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,CHRTOUT_GRID, & + QBDRYRT & +#ifdef HYDRO_REALTIME + , iocflag & +#endif + ) + +!output the routing variables over routing grid. + implicit none +#include + + integer, intent(in) :: igrid +#ifdef HYDRO_REALTIME + integer, intent(in) :: iocflag +#endif + integer, intent(in) :: split_output_count + integer, intent(in) :: ixrt,jxrt + real, intent(in) :: dt + real, intent(in) :: dist(ixrt,jxrt,9) + integer, intent(in) :: nsoil + integer, intent(in) :: CHRTOUT_GRID + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + character(len=*), intent(in) :: geo_finegrid_flnm + real, dimension(nsoil), intent(in) :: sldpth + real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable + real*8, allocatable, DIMENSION(:) :: xcoord_d + real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord + + integer, save :: ncid,ncstatic + integer, save :: output_count + real, dimension(nsoil) :: asldpth + + integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n + integer :: iret, dimid_soil, i,j,ii,jj + character(len=256) :: output_flnm + character(len=19) :: date19 + character(len=32) :: convention + character(len=34) :: sec_since_date + character(len=34) :: sec_valid_date + + character(len=30) :: soilm + + real :: long_cm,lat_po,fe,fn, chan_in + real, dimension(2) :: sp + + real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID + real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y + real, dimension(ixrt,jxrt) :: QSTRMVOLRT + real, dimension(ixrt,jxrt) :: SFCHEADSUBRT + real, dimension(ixrt,jxrt) :: soxrt,soyrt + real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT + real, dimension(ixrt,jxrt,nsoil) :: SMCRT + + character(len=2) :: strTmp + + integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag + sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + decimation = 1 !-- decimation factor +#ifdef MPP_LAND + ixrtd = int(global_rt_nx/decimation) + jxrtd = int(global_rt_ny/decimation) +#else + ixrtd = int(ixrt/decimation) + jxrtd = int(jxrt/decimation) +#endif + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + allocate(xdumd(ixrtd,jxrtd)) + allocate(xcoord_d(ixrtd)) + allocate(ycoord_d(jxrtd)) + allocate(ycoord(jxrtd)) + + xdumd = -999 + xcoord_d = -999 + ycoord_d = -999 + ycoord = -999 +#ifdef MPP_LAND + else + allocate(xdumd(1,1)) + allocate(xcoord_d(1)) + allocate(ycoord_d(1)) + allocate(ycoord(1)) + endif +#endif + ii = 0 + +!DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09) + chan_in = 0.0 + do j=1,jxrt + do i=1,ixrt + chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9)) !(units m^3) + enddo + enddo +#ifdef MPP_LAND + call sum_real1(chan_in) +#endif +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif +#ifdef NCEP_WCOSS + open (unit=54, form='formatted', status='unknown', position='append') + write (54,713) chan_in + close (54) +#else +#ifndef HYDRO_REALTIME + open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',& + status='unknown',position='append') + write (46,713) chan_in + close (46) +#endif +#endif +#ifdef MPP_LAND + endif +#endif +713 FORMAT (F20.7) +! return +!DJG end dump of channel inflow for calibration.... + + if (CHRTOUT_GRID.eq.0) return ! return if hires flag eq 1, if =2 output full grid + + if (output_count == 0) then + + !-- Open the finemesh static files to obtain projection information +#ifdef HYDRO_D + write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) +#endif + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(iret) +#endif + + if (iret /= 0) then + write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & + trim(geo_finegrid_flnm) + write(*,*) "HIRES_OUTPUT will not be georeferenced..." + hires_flag = 0 + else + hires_flag = 1 + endif + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get Latitude (X) + iret = NF_INQ_VARID(ncstatic,'x',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord_d) + ! Get Longitude (Y) + iret = NF_INQ_VARID(ncstatic,'y',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) + else + ycoord_d = 0. + xcoord_d = 0. + end if !endif hires_georef + + jj = 0 +#ifdef MPP_LAND + do j=global_rt_ny,1,-1*decimation +#else + do j=jxrt,1,-1*decimation +#endif + jj = jj+1 + if (jj<= jxrtd) then + ycoord_d(jj) = ycoord(j) + endif + enddo + + +#ifndef HYDRO_REALTIME + if(hires_flag.eq.1) then !if/then hires_georef + ! Get projection information from finegrid netcdf file + iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) + if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file + end if !endif hires_georef + iret = nf_close(ncstatic) +#endif + +!-- create the fine grid routing file + write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + write(6,*) "using normal netcdf file for RTOUT_DOMAIN" + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + write(6,*) "using large netcdf file for RTOUT_DOMAIN" + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + if (iret /= 0) then + call hydro_stop("In output_rt() - Problem nf_create") + endif + + iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) + iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) +#ifndef HYDRO_REALTIME + iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils +#endif + +!--- define variables +! !- time definition, timeObs + iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time') + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + +#ifndef HYDRO_REALTIME + !- x-coordinate in cartesian system + iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- y-coordinate in cartesian ssystem + iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- LATITUDE + iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg North') + + !- LONGITUDE + iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg east') + + !-- z-level is soil + iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) + iret = nf_put_att_text(ncid,varid,'units',2,'cm') + iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') + + do n = 1, NSOIL + write(strTmp,'(I2)') n + iret = nf_def_var(ncid, "SOIL_M"//trim(strTmp), NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + end do + iret = nf_put_att_text(ncid,varid,'units',7,'m^3/m^3') + iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') + iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) +! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"ESNOW2D",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + +! iret = nf_def_var(ncid,"QSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') +! iret = nf_put_att_text(ncid,varid,'long_name',15,'subsurface flow') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) +#endif + +#ifdef HYDRO_REALTIME + if ( (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then +#endif + iret = nf_def_var(ncid,"zwattablrt",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',1,'m') + iret = nf_put_att_text(ncid,varid,'long_name',17,'water table depth') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"Q_SFCFLX_X",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') +! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux x') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"Q_SFCFLX_Y",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') +! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux y') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"sfcheadsubrt",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +#ifdef HYDRO_REALTIME + endif +#endif + +#ifndef HYDRO_REALTIME + iret = nf_def_var(ncid,"QSTRMVOLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',14,'channel inflow') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"SOXRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',1,'1') +! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope x') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"SOYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',1,'1') +! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope 7') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"SUB_RESID",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + + iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',70, & + 'accumulated value of the boundary flux, + into domain, - out of domain') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +!-- place projection information + if(hires_flag.eq.1) then !if/then hires_georef + iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) + iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) + iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) + iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) + iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) + iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) + end if !endif hires_georef +#endif + +! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "CF-1.0" + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) + + ! iret = nf_redef(ncid) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + ! iret = nf_enddef(ncid) + + iret = nf_enddef(ncid) + +#ifndef HYDRO_REALTIME +!!-- write latitude and longitude locations + iret = nf_inq_varid(ncid,"x", varid) + iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array + + iret = nf_inq_varid(ncid,"y", varid) + iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array +#endif + +#ifdef MPP_LAND + endif +#endif + +iret = nf_inq_varid(ncid,"time", varid) +iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) + +#ifndef HYDRO_REALTIME +#ifdef MPP_LAND + call write_IO_rt_real(LATVAL,xdumd) + if( my_id .eq. io_id) then +#else + xdumd = LATVAL +#endif + iret = nf_inq_varid(ncid,"LATITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + + +#ifdef MPP_LAND + endif !!! end if block of my_id .eq. io_id + + call write_IO_rt_real(LONVAL,xdumd) + + if( my_id .eq. io_id) then +#else + xdumd = LONVAL +#endif + iret = nf_inq_varid(ncid,"LONGITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + +#ifdef MPP_LAND + endif + + if( my_id .eq. io_id) then +#endif + + + + + + + do n = 1,nsoil + if(n == 1) then + asldpth(n) = -sldpth(n) + else + asldpth(n) = asldpth(n-1) - sldpth(n) + endif + enddo + + iret = nf_inq_varid(ncid,"depth", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) +!yw iret = nf_close(ncstatic) +#ifdef MPP_LAND + endif ! end of my_id .eq. io_id +#endif +#endif + + endif !!! end of if block output_count == 0 + output_count = output_count + 1 + +#ifndef HYDRO_REALTIME +!-- 3-d soils + do n = 1, nsoil +#ifdef MPP_LAND + call write_IO_rt_real(smcrt(:,:,n),xdumd) +#else + xdumd(:,:) = smcrt(:,:,n) +#endif +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + write(strTmp,'(I2)') n + iret = nf_inq_varid(ncid, "SOIL_M"//trim(strTmp), varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +#ifdef MPP_LAND + endif +#endif + enddo !-n soils +#endif + +#ifdef HYDRO_REALTIME + if ( (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then +#endif +#ifdef MPP_LAND + call write_IO_rt_real(ZWATTABLRT,xdumd) +#else + xdumd(:,:) = ZWATTABLRT(:,:) +#endif +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + iret = nf_inq_varid(ncid, "zwattablrt", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +#ifdef MPP_LAND + endif +#endif +#ifdef HYDRO_REALTIME + endif +#endif + +#ifndef HYDRO_REALTIME +#ifdef MPP_LAND + call write_IO_rt_real(QBDRYRT,xdumd) +#else + xdumd(:,:) = QBDRYRT(:,:) +#endif +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + iret = nf_inq_varid(ncid, "QBDRYRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +#ifdef MPP_LAND + endif +#endif + +#ifdef MPP_LAND + call write_IO_rt_real(QSTRMVOLRT,xdumd) +#else + xdumd(:,:) = QSTRMVOLRT(:,:) +#endif +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + iret = nf_inq_varid(ncid, "QSTRMVOLRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +#ifdef MPP_LAND + endif +#endif +#endif + +#ifdef HYDRO_REALTIME + if ( (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then +#endif +#ifdef MPP_LAND + call write_IO_rt_real(SFCHEADSUBRT,xdumd) +#else + xdumd(:,:) = SFCHEADSUBRT(:,:) +#endif +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + iret = nf_inq_varid(ncid, "sfcheadsubrt", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +#ifdef MPP_LAND + endif +#endif +#ifdef HYDRO_REALTIME + endif +#endif + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + + +!yw iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(output_count) +#endif + + if(allocated(xdumd)) deallocate(xdumd) + if(allocated(xcoord_d)) deallocate(xcoord_d) + if(allocated(ycoord_d)) deallocate(ycoord_d) + if(allocated(ycoord)) deallocate(ycoord) + +#ifdef HYDRO_D + write(6,*) "end of output_rt" +#endif + + end subroutine output_rt + + +!BF output section for gw2d model +!bftodo: clean up an customize for GW usage + + subroutine output_gw_spinup(igrid, split_output_count, ixrt, jxrt, & + startdate, date, HEAD, convgw, excess, & + geo_finegrid_flnm,dt,LATVAL,LONVAL,dist,output_gw) + +#ifdef MPP_LAND + USE module_mpp_land +#endif +!output the routing variables over routing grid. + implicit none +#include + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: ixrt,jxrt + real, intent(in) :: dt + real, intent(in) :: dist(ixrt,jxrt,9) + integer, intent(in) :: output_gw + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + character(len=*), intent(in) :: geo_finegrid_flnm + real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable + real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord + real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord + + integer, save :: ncid,ncstatic + integer, save :: output_count + + integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n + integer :: iret, dimid_soil, i,j,ii,jj + character(len=256) :: output_flnm + character(len=19) :: date19 + character(len=32) :: convention + character(len=34) :: sec_since_date + character(len=34) :: sec_valid_date + + character(len=30) :: soilm + + real :: long_cm,lat_po,fe,fn, chan_in + real, dimension(2) :: sp + + real, dimension(ixrt,jxrt) :: head, convgw, excess, & + latval, lonval + + integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag + +#ifdef MPP_LAND + real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gExcess + real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval +#endif + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99) + call write_IO_rt_real(latval,gLatval) + call write_IO_rt_real(lonval,gLonval) + call write_IO_rt_real(head,gHead) + call write_IO_rt_real(convgw,gConvgw) + call write_IO_rt_real(excess,gExcess) + + + if(my_id.eq.IO_id) then + + +#endif + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + decimation = 1 !-- decimation factor +#ifdef MPP_LAND + ixrtd = int(global_rt_nx/decimation) + jxrtd = int(global_rt_ny/decimation) +#else + ixrtd = int(ixrt/decimation) + jxrtd = int(jxrt/decimation) +#endif + allocate(xdumd(ixrtd,jxrtd)) + allocate(xcoord_d(ixrtd)) + allocate(ycoord_d(jxrtd)) + allocate(xcoord(ixrtd)) + allocate(ycoord(jxrtd)) + ii = 0 + jj = 0 + + if (output_gw.eq.0) return ! return if hires flag eq 0, if =1 output full grid + + if (output_count == 0) then + + !-- Open the finemesh static files to obtain projection information +#ifdef HYDRO_D + write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) + +#endif + iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) + + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & + trim(geo_finegrid_flnm) + write(*,*) "HIRES_OUTPUT will not be georeferenced..." +#endif + hires_flag = 0 + else + hires_flag = 1 + endif + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get Latitude (X) + iret = NF_INQ_VARID(ncstatic,'x',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) + ! Get Longitude (Y) + iret = NF_INQ_VARID(ncstatic,'y',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) + else + xcoord_d = 0. + ycoord_d = 0. + end if !endif hires_georef + + do j=jxrtd,1,-1*decimation + jj = jj+1 + if (jj<= jxrtd) then + ycoord_d(jj) = ycoord(j) + endif + enddo + +!yw do i = 1,ixrt,decimation +!yw ii = ii + 1 +!yw if (ii <= ixrtd) then +!yw xcoord_d(ii) = xcoord(i) + xcoord_d = xcoord +!yw endif +!yw enddo + + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get projection information from finegrid netcdf file + iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) + if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file + end if !endif hires_georef + iret = nf_close(ncstatic) + +!-- create the fine grid routing file + write(output_flnm, '(A12,".GW_SPINUP",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + + if (iret /= 0) then + call hydro_stop("In output_gw_spinup() - Problem nf_create") + endif + + iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) + iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) + +!--- define variables + !- time definition, timeObs + iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + + !- x-coordinate in cartesian system + iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- y-coordinate in cartesian ssystem + iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- LATITUDE + iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg North') + + !- LONGITUDE + iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg east') + + + iret = nf_def_var(ncid,"GwHead",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',1,'m') + iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"GwConv",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',12,'groundwater convergence') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"GwExcess",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',1,'m') + iret = nf_put_att_text(ncid,varid,'long_name',17,'surface excess groundwater') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +!-- place projection information + if(hires_flag.eq.1) then !if/then hires_georef + iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) + iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) + iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) + iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) + iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) + iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) + end if !endif hires_georef + +! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "CF-1.0" + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) + + iret = nf_enddef(ncid) + +!!-- write latitude and longitude locations +! xdumd = LATVAL + iret = nf_inq_varid(ncid,"x", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array + +! xdumd = LONVAL + iret = nf_inq_varid(ncid,"y", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array + +#ifdef MPP_LAND + xdumd = gLATVAL +#else + xdumd = LATVAL +#endif + iret = nf_inq_varid(ncid,"LATITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + +#ifdef MPP_LAND + xdumd = gLONVAL +#else + xdumd = LONVAL +#endif + iret = nf_inq_varid(ncid,"LONGITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + + + endif + + output_count = output_count + 1 + +!!-- time + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) + + +#ifdef MPP_LAND + xdumd = gHead +#else + xdumd = head +#endif + + iret = nf_inq_varid(ncid, "GwHead", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +#ifdef MPP_LAND + xdumd = gConvgw +#else + xdumd = convgw +#endif + iret = nf_inq_varid(ncid, "GwConv", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + +#ifdef MPP_LAND + xdumd = gExcess +#else + xdumd = excess +#endif + iret = nf_inq_varid(ncid, "GwExcess", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + +!!time in seconds since startdate + + iret = nf_redef(ncid) + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif + + if(allocated(xdumd)) deallocate(xdumd) + if(allocated(xcoord_d)) deallocate(xcoord_d) + if(allocated(xcoord)) deallocate(xcoord) + if(allocated(ycoord_d)) deallocate(ycoord_d) + if(allocated(ycoord)) deallocate(ycoord) + +#ifdef MPP_LAND + endif +#endif + + end subroutine output_gw_spinup + + +subroutine sub_output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & + startdate, date, HEAD, SMCRT, convgw, excess, qsgwrt, qgw_chanrt, & + geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,output_gw) + +#ifdef MPP_LAND + USE module_mpp_land +#endif +!output the routing variables over routing grid. + implicit none +#include + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: ixrt,jxrt + real, intent(in) :: dt + real, intent(in) :: dist(ixrt,jxrt,9) + integer, intent(in) :: nsoil + integer, intent(in) :: output_gw + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + character(len=*), intent(in) :: geo_finegrid_flnm + real, dimension(nsoil), intent(in) :: sldpth + real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable + real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord + real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord + + integer, save :: ncid,ncstatic + integer, save :: output_count + real, dimension(nsoil) :: asldpth + + integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n + integer :: iret, dimid_soil, i,j,ii,jj + character(len=256) :: output_flnm + character(len=19) :: date19 + character(len=32) :: convention + character(len=34) :: sec_since_date + character(len=34) :: sec_valid_date + + character(len=30) :: soilm + + real :: long_cm,lat_po,fe,fn, chan_in + real, dimension(2) :: sp + + real, dimension(ixrt,jxrt) :: head, convgw, excess, & + qsgwrt, qgw_chanrt, & + latval, lonval + real, dimension(ixrt,jxrt,nsoil) :: SMCRT + + integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag + +#ifdef MPP_LAND + real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gqsgwrt, gExcess, & + gQgw_chanrt + real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval + real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT +#endif + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99) + call MPP_LAND_COM_REAL(qsgwrt, ixrt, jxrt, 99) + call MPP_LAND_COM_REAL(qgw_chanrt, ixrt, jxrt, 99) + call write_IO_rt_real(latval,gLatval) + call write_IO_rt_real(lonval,gLonval) + call write_IO_rt_real(qsgwrt,gqsgwrt) + call write_IO_rt_real(qgw_chanrt,gQgw_chanrt) + call write_IO_rt_real(head,gHead) + call write_IO_rt_real(convgw,gConvgw) + call write_IO_rt_real(excess,gExcess) + + do i = 1, NSOIL + call MPP_LAND_COM_REAL(smcrt(:,:,i), ixrt, jxrt, 99) + call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i)) + end do + + if(my_id.eq.IO_id) then + + +#endif + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + decimation = 1 !-- decimation factor +#ifdef MPP_LAND + ixrtd = int(global_rt_nx/decimation) + jxrtd = int(global_rt_ny/decimation) +#else + ixrtd = int(ixrt/decimation) + jxrtd = int(jxrt/decimation) +#endif + allocate(xdumd(ixrtd,jxrtd)) + allocate(xcoord_d(ixrtd)) + allocate(ycoord_d(jxrtd)) + allocate(xcoord(ixrtd)) + allocate(ycoord(jxrtd)) + ii = 0 + jj = 0 + + if (output_gw.eq.0) return ! return if hires flag eq 0, if =1 output full grid + + if (output_count == 0) then + + !-- Open the finemesh static files to obtain projection information +#ifdef HYDRO_D + write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) + +#endif + iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) + + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & + trim(geo_finegrid_flnm) + write(*,*) "HIRES_OUTPUT will not be georeferenced..." +#endif + hires_flag = 0 + else + hires_flag = 1 + endif + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get Latitude (X) + iret = NF_INQ_VARID(ncstatic,'x',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) + ! Get Longitude (Y) + iret = NF_INQ_VARID(ncstatic,'y',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) + else + xcoord_d = 0. + ycoord_d = 0. + end if !endif hires_georef + + do j=jxrtd,1,-1*decimation + jj = jj+1 + if (jj<= jxrtd) then + ycoord_d(jj) = ycoord(j) + endif + enddo + +!yw do i = 1,ixrt,decimation +!yw ii = ii + 1 +!yw if (ii <= ixrtd) then +!yw xcoord_d(ii) = xcoord(i) + xcoord_d = xcoord +!yw endif +!yw enddo + + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get projection information from finegrid netcdf file + iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) + if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file + end if !endif hires_georef + iret = nf_close(ncstatic) + +!-- create the fine grid routing file + write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + + if (iret /= 0) then + call hydro_stop("In output_gw_spinup() - Problem nf_create") + endif + + iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) + iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) + iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils + +!--- define variables + !- time definition, timeObs + iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + + !- x-coordinate in cartesian system + iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- y-coordinate in cartesian ssystem + iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- LATITUDE + iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg North') + + !- LONGITUDE + iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg east') + + !-- z-level is soil + iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) + iret = nf_put_att_text(ncid,varid,'units',2,'cm') + iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') + + iret = nf_def_var(ncid, "SOIL_M", NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',6,'kg m-2') + iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') + iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) +! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"HEAD",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',1,'m') + iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"CONVGW",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',12,'channel flux') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"GwExcess",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',1,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',17,'surface excess groundwater') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"QSGWRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"QGW_CHANRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'m3 s-1') + iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) +!-- place projection information + if(hires_flag.eq.1) then !if/then hires_georef + iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) + iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) + iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) + iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) + iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) + iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) + end if !endif hires_georef + +! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "CF-1.0" + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) + + iret = nf_enddef(ncid) + +!!-- write latitude and longitude locations +! xdumd = LATVAL + iret = nf_inq_varid(ncid,"x", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array + +! xdumd = LONVAL + iret = nf_inq_varid(ncid,"y", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array + +#ifdef MPP_LAND + xdumd = gLATVAL +#else + xdumd = LATVAL +#endif + iret = nf_inq_varid(ncid,"LATITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + +#ifdef MPP_LAND + xdumd = gLONVAL +#else + xdumd = LONVAL +#endif + iret = nf_inq_varid(ncid,"LONGITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + + do n = 1,nsoil + if(n == 1) then + asldpth(n) = -sldpth(n) + else + asldpth(n) = asldpth(n-1) - sldpth(n) + endif + enddo + + iret = nf_inq_varid(ncid,"depth", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) +!yw iret = nf_close(ncstatic) + + endif + + output_count = output_count + 1 + +!!-- time + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) + +!-- 3-d soils + do n = 1, nsoil +#ifdef MPP_LAND + xdumd = gSMCRT(:,:,n) +#else + xdumd = SMCRT(:,:,n) +#endif +! !DJG inv jj = int(jxrt/decimation) +! jj = 1 +! ii = 0 +! !DJG inv do j = jxrt,1,-decimation +! do j = 1,jxrt,decimation +! do i = 1,ixrt,decimation +! ii = ii + 1 +! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then +! xdumd(ii,jj) = smcrt(i,j,n) +! endif +! enddo +! ii = 0 +! !DJG inv jj = jj -1 +! jj = jj + 1 +! enddo +! where (vegtyp(:,:) == 16) xdum = -1.E33 + iret = nf_inq_varid(ncid, "SOIL_M", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd) + enddo !-n soils + +#ifdef MPP_LAND + xdumd = gHead +#else + xdumd = head +#endif + + iret = nf_inq_varid(ncid, "HEAD", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +#ifdef MPP_LAND + xdumd = gConvgw +#else + xdumd = convgw +#endif + iret = nf_inq_varid(ncid, "CONVGW", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + +#ifdef MPP_LAND + xdumd = gExcess +#else + xdumd = excess +#endif + iret = nf_inq_varid(ncid, "GwExcess", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + +#ifdef MPP_LAND + xdumd = gqsgwrt +#else + xdumd = qsgwrt +#endif + + iret = nf_inq_varid(ncid, "QSGWRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +#ifdef MPP_LAND + xdumd = gQgw_chanrt +#else + xdumd = qgw_chanrt +#endif + + iret = nf_inq_varid(ncid, "QGW_CHANRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + +!!time in seconds since startdate + + iret = nf_redef(ncid) + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif + + if(allocated(xdumd)) deallocate(xdumd) + if(allocated(xcoord_d)) deallocate(xcoord_d) + if(allocated(xcoord)) deallocate(xcoord) + if(allocated(ycoord_d)) deallocate(ycoord_d) + if(allocated(ycoord)) deallocate(ycoord) + +#ifdef HYDRO_D + write(6,*) "end of output_ge" +#endif +#ifdef MPP_LAND + endif +#endif + + end subroutine sub_output_gw + +!NOte: output_chrt is the old version comparing to "output_chrt_bak". + subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & + startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & + STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & + lsmDt & +#ifdef WRF_HYDRO_NUDGING + , nudge & +#endif + , accLndRunOff, accQLateral, accStrmvolrt, accBucket, UDMP_OPT & + ) + + implicit none +#include +!!output the routing variables over just channel + integer, intent(in) :: igrid,K,channel_option + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS, NLINKSL + real, dimension(:), intent(in) :: chlon,chlat + real, dimension(:), intent(in) :: hlink,zelev + integer, dimension(:), intent(in) :: ORDER + integer, dimension(:), intent(inout) :: STRMFRXSTPTS + character(len=15), dimension(:), intent(inout) :: gages + character(len=15), intent(in) :: gageMiss + real, intent(in) :: lsmDt + + real, intent(in) :: dtrt_ch + real, dimension(:,:), intent(in) :: qlink +#ifdef WRF_HYDRO_NUDGING + real, dimension(:), intent(in) :: nudge +#endif + + integer, intent(in) :: UDMP_OPT + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + real, allocatable, DIMENSION(:) :: chanlat,chanlon + real, allocatable, DIMENSION(:) :: chanlatO,chanlonO + + real, allocatable, DIMENSION(:) :: elevation + real, allocatable, DIMENSION(:) :: elevationO + + integer, allocatable, DIMENSION(:) :: station_id + integer, allocatable, DIMENSION(:) :: station_idO + + integer, allocatable, DIMENSION(:) :: rec_num_of_station + integer, allocatable, DIMENSION(:) :: rec_num_of_stationO + + integer, allocatable, DIMENSION(:) :: lOrder !- local stream order + integer, allocatable, DIMENSION(:) :: lOrderO !- local stream order + + integer, save :: output_count + integer, save :: ncid,ncid2 + + integer :: stationdim, dimdata, varid, charid, n + integer :: obsdim, dimdataO, charidO + + integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output + integer :: start_posO, prev_posO, nlk + + integer :: previous_pos !-- used for the station model + character(len=256) :: output_flnm,output_flnm2 + character(len=19) :: date19,date19start, hydroTime + character(len=34) :: sec_since_date + integer :: seconds_since,nstations,cnt,ObsStation,nobs + character(len=32) :: convention + character(len=11),allocatable, DIMENSION(:) :: stname + character(len=15),allocatable, DIMENSION(:) :: stnameO + + !--- all this for writing the station id string + INTEGER TDIMS, TXLEN + PARAMETER (TDIMS=2) ! number of TX dimensions + PARAMETER (TXLEN = 11) ! length of example string + INTEGER TIMEID ! record dimension id + INTEGER TXID ! variable ID + INTEGER TXDIMS(TDIMS) ! variable shape + INTEGER TSTART(TDIMS), TCOUNT(TDIMS) + + !-- observation point ids + INTEGER OTDIMS, OTXLEN + PARAMETER (OTDIMS=2) ! number of TX dimensions + PARAMETER (OTXLEN = 15) ! length of example string + INTEGER OTIMEID ! record dimension id + INTEGER OTXID ! variable ID + INTEGER OTXDIMS(OTDIMS) ! variable shape + INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) + + real, dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket + + !! currently, this is the time of the hydro model, it's + !! lsm time (olddate) plus one lsm timestep + !call geth_newdate(hydroTime, date, nint(lsmDt)) + hydroTime=date + + seconds_since = int(dtrt_ch)*(K-1) + +! order_to_write = 2 !-- 1 all; 6 fewest + nstations = 0 ! total number of channel points to display + nobs = 0 ! number of observation points + + if(channel_option .ne. 3) then + nlk = NLINKSL + else + nlk = NLINKS + endif + + +!-- output only the higher oder streamflows and only observation points + do i=1,nlk + if(ORDER(i) .ge. order_to_write) nstations = nstations + 1 + if(channel_option .ne. 3) then + if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1 + else + if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1 + endif + enddo + + if (nobs .eq. 0) then ! let's at least make one obs point + nobs = 1 + if(channel_option .ne. 3) then + ! 123456789012345 + gages(1) = ' dummy' + else + STRMFRXSTPTS(1) = 1 + endif + endif + + allocate(chanlat(nstations)) + allocate(chanlon(nstations)) + allocate(elevation(nstations)) + allocate(lOrder(nstations)) + allocate(stname(nstations)) + allocate(station_id(nstations)) + allocate(rec_num_of_station(nstations)) + + allocate(chanlatO(nobs)) + allocate(chanlonO(nobs)) + allocate(elevationO(nobs)) + allocate(lOrderO(nobs)) + allocate(stnameO(nobs)) + allocate(station_idO(nobs)) + allocate(rec_num_of_stationO(nobs)) + + if(output_count == 0) then +!-- have moved sec_since_date from above here.. + sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & + //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + nstations = 0 + nobs = 0 + + write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + if (iret /= 0) then + call hydro_stop("In output_chrt() - Problem nf_create points") + endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2) +#else + iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2) +#endif + if (iret /= 0) then + call hydro_stop("In output_chrt() - Problem nf_create observation") + endif + + do i=1,nlk + if(ORDER(i) .ge. order_to_write) then + nstations = nstations + 1 + chanlat(nstations) = chlat(i) + chanlon(nstations) = chlon(i) + elevation(nstations) = zelev(i) + lOrder(nstations) = ORDER(i) + station_id(nstations) = i + if(STRMFRXSTPTS(nstations) .eq. -9999) then + ObsStation = 0 + else + ObsStation = 1 + endif + write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation + endif + enddo + + + do i=1,nlk + if(channel_option .ne. 3) then + if(trim(gages(i)) .ne. trim(gageMiss)) then + nobs = nobs + 1 + chanlatO(nobs) = chlat(i) + chanlonO(nobs) = chlon(i) + elevationO(nobs) = zelev(i) + lOrderO(nobs) = ORDER(i) + station_idO(nobs) = i + stnameO(nobs) = gages(i) + endif + else + if(STRMFRXSTPTS(i) .ne. -9999) then + nobs = nobs + 1 + chanlatO(nobs) = chlat(i) + chanlonO(nobs) = chlon(i) + elevationO(nobs) = zelev(i) + lOrderO(nobs) = ORDER(i) + station_idO(nobs) = i + write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) +#ifdef HYDRO_D + ! print *,"stationobservation name", stnameO(nobs) +#endif + endif + endif + enddo + + iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach + iret = nf_def_dim(ncid, "station", nstations, stationdim) + + + + iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO) !--for linked list approach + iret = nf_def_dim(ncid2, "station", nobs, obsdim) + + !- station location definition all, lat + iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude') + iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') + + !- station location definition obs, lat + iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude') + iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north') + + + !- station location definition, long + iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude') + iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') + + + !- station location definition, obs long + iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude') + iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east') + + +! !-- elevation is ZELEV + iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude') + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + + +! !-- elevation is obs ZELEV + iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude') + iret = nf_put_att_text(ncid2,varid,'units',6,'meters') + + +! !-- gage observation +! iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid) +! iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location') +! iret = nf_put_att_text(ncid,varid,'units',4,'none') + +!-- parent index + iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record') + + iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record') + + !-- prevChild + iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station') + iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + + iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station') + iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) + + !-- lastChild + iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station') + iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + + iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station') + iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) + +! !- flow definition, var + + if(UDMP_OPT .eq. 1) then + + iret = nf_def_var(ncid, "accLndRunOff", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',28,'ACCUMULATED runoff from land') + + iret = nf_def_var(ncid, "accQLateral", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',24,'Total ACCUMULATED runoff') + + iret = nf_def_var(ncid, "accStrmvolrt", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',39,'ACCUMULATED runoff from terrain routing') + + iret = nf_def_var(ncid, "accBucket", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',32,'ACCUMULATED runoff from gw bucket') + + endif + + iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow') + + iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow') + +#ifdef WRF_HYDRO_NUDGING + iret = nf_def_var(ncid, "nudge", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',32,'Amount of stream flow alteration') + + iret = nf_def_var(ncid2, "nudge", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid2,varid,'long_name',32,'Amount of stream flow alteration') +#endif + +! !- flow definition, var +! iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid) +! iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') +! iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow') + +! !- head definition, var + iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',5,'meter') + iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage') + + iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',5,'meter') + iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage') + +! !- order definition, var + iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order') + iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + + iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order') + iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + + !-- station id + ! define character-position dimension for strings of max length 11 + iret = NF_DEF_DIM(ncid, "id_len", 11, charid) + TXDIMS(1) = charid ! define char-string variable and position dimension first + TXDIMS(2) = stationdim + iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) + iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') + + + iret = NF_DEF_DIM(ncid2, "id_len", 15, charidO) + OTXDIMS(1) = charidO ! define char-string variable and position dimension first + OTXDIMS(2) = obsdim + iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid) + iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id') + + +! !- time definition, timeObs + iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) + iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation') + + iret = nf_def_var(ncid2,"time_observation",NF_INT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',34,sec_since_date) + iret = nf_put_att_text(ncid2,varid,'long_name',19,'time of observation') + + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) + + convention(1:32) = "Unidata Observation Dataset v1.0" + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start) + iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station") + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_int(ncid, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) + + iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_start",19, date19start) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "stationDimension",7, "station") + iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) + + iret = nf_enddef(ncid) + iret = nf_enddef(ncid2) + + !-- write latitudes + iret = nf_inq_varid(ncid,"latitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat) + + iret = nf_inq_varid(ncid2,"latitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO) + + !-- write longitudes + iret = nf_inq_varid(ncid,"longitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon) + + iret = nf_inq_varid(ncid2,"longitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO) + + !-- write elevations + iret = nf_inq_varid(ncid,"altitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation) + + iret = nf_inq_varid(ncid2,"altitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO) + + !-- write gage location +! iret = nf_inq_varid(ncid,"gages", varid) +! iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS) + + !-- write number_of_stations, OPTIONAL + !! iret = nf_inq_varid(ncid,"number_stations", varid) + !! iret = nf_put_var_int(ncid, varid, nstations) + + !-- write station id's + do i=1,nstations + TSTART(1) = 1 + TSTART(2) = i + TCOUNT(1) = TXLEN + TCOUNT(2) = 1 + iret = nf_inq_varid(ncid,"station_id", varid) + iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) + enddo + + !-- write observation id's + do i=1, nobs + OTSTART(1) = 1 + OTSTART(2) = i + OTCOUNT(1) = OTXLEN + OTCOUNT(2) = 1 + iret = nf_inq_varid(ncid2,"station_id", varid) + iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i)) + enddo + + endif + + output_count = output_count + 1 + + open (unit=55, & +#ifndef NCEP_WCOSS + file='frxst_pts_out.txt', & +#endif + status='unknown',position='append') + + cnt=0 + do i=1,nlk + + if(ORDER(i) .ge. order_to_write) then + start_pos = (cnt+1)+(nstations*(output_count-1)) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid,"time_observation", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) + + if(UDMP_OPT .eq. 1) then + iret = nf_inq_varid(ncid,"accLndRunOff", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accLndRunOff(i)) + + iret = nf_inq_varid(ncid,"accQLateral", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accQLateral(i)) + + iret = nf_inq_varid(ncid,"accStrmvolrt", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accStrmvolrt(i)) + + iret = nf_inq_varid(ncid,"accBucket", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accBucket(i)) + endif + + iret = nf_inq_varid(ncid,"streamflow", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1)) + +#ifdef WRF_HYDRO_NUDGING + iret = nf_inq_varid(ncid,"nudge", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), nudge(i)) +#endif + +! iret = nf_inq_varid(ncid,"pos_streamflow", varid) +! iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1))) + + iret = nf_inq_varid(ncid,"head", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i)) + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid,"parent_index", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) + + !--record number of previous record for same station +!obsolete format prev_pos = cnt+(nstations*(output_count-1)) + prev_pos = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid,"prevChild", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) + endif + cnt=cnt+1 !--indices are 0 based + rec_num_of_station(cnt) = start_pos-1 !-- save position for last child, 0-based!! + + + endif + enddo +! close(999) + + !-- output only observation points + cnt=0 + do i=1,nlk + if(channel_option .ne. 3) then + ! jlm this verry repetitiuos, oh well. + if(trim(gages(i)) .ne. trim(gageMiss)) then + + start_posO = (cnt+1)+(nobs * (output_count-1)) + !Write frxst_pts to text file... + !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & +118 FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) + !write(55,118) seconds_since, date(1:10), date(12:19), & +#ifndef HYDRO_REALTIME + write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), & + gages(i), chlon(i), chlat(i), & + qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) +#endif + !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) + !yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid2,"time_observation", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid2,"streamflow", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1)) + +#ifdef WRF_HYDRO_NUDGING + iret = nf_inq_varid(ncid2,"nudge", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), nudge(i)) +#endif + + iret = nf_inq_varid(ncid2,"head", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i)) + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid2,"parent_index", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt) + + !--record number of previous record for same station + !obsolete format prev_posO = cnt+(nobs*(output_count-1)) + prev_posO = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid2,"prevChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + + !IF block to add -1 to last element of prevChild array to designate end of list... + ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) + ! else + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + ! endif + + endif + cnt=cnt+1 !--indices are 0 based + rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! + endif + + + else !! channel options 3 below + + if(STRMFRXSTPTS(i) .ne. -9999) then + start_posO = (cnt+1)+(nobs * (output_count-1)) + !Write frxst_pts to text file... + !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & +117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) + !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & + ! qlink(i,1), qlink(i,1)*35.315,hlink(i) + ! JLM: makes more sense to output the value in frxstpts incase they have meaning, + ! as below, but I'm not going to make this change until I'm working with gridded + ! streamflow again. + write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), & + strmfrxstpts(i), chlon(i), chlat(i), & + qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid2,"time_observation", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid2,"streamflow", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1)) + + iret = nf_inq_varid(ncid2,"head", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i)) + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid2,"parent_index", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt) + + !--record number of previous record for same station + !obsolete format prev_posO = cnt+(nobs*(output_count-1)) + prev_posO = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid2,"prevChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + + !IF block to add -1 to last element of prevChild array to designate end of list... + ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) + ! else + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + ! endif + + endif + cnt=cnt+1 !--indices are 0 based + rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! + endif + + endif + + enddo + close(55) + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid,"lastChild", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station) + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid2,"lastChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO) + + iret = nf_redef(ncid) + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) + + iret = nf_redef(ncid2) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_end", 19, date19) + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + + iret = nf_enddef(ncid2) + iret = nf_sync(ncid2) + + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + iret = nf_close(ncid2) + endif + + if(allocated(chanlat)) deallocate(chanlat) + if(allocated(chanlon)) deallocate(chanlon) + if(allocated(elevation)) deallocate(elevation) + if(allocated(station_id)) deallocate(station_id) + if(allocated(lOrder)) deallocate(lOrder) + if(allocated(rec_num_of_station)) deallocate(rec_num_of_station) + if(allocated(stname)) deallocate(stname) + + if(allocated(chanlatO)) deallocate(chanlatO) + if(allocated(chanlonO)) deallocate(chanlonO) + if(allocated(elevationO)) deallocate(elevationO) + if(allocated(station_idO)) deallocate(station_idO) + if(allocated(lOrderO)) deallocate(lOrderO) + if(allocated(rec_num_of_stationO)) deallocate(rec_num_of_stationO) + if(allocated(stnameO)) deallocate(stnameO) +#ifdef HYDRO_D + print *, "Exited Subroutine output_chrt" +#endif + close(16) + +20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3) + +end subroutine output_chrt + +!-- output the channel route in an IDV 'station' compatible format +!Note: This version has pool output performance need to be +!solved. We renamed it from output_chrt to be output_chrt_bak. + subroutine output_chrt_bak(igrid, split_output_count, NLINKS, ORDER, & + startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & + STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & + lsmDt & +#ifdef WRF_HYDRO_NUDGING + , nudge & +#endif + , accLndRunOff, accQLateral, accStrmvolrt, accBucket, UDMP_OPT & + ) + + implicit none +#include +!!output the routing variables over just channel + integer, intent(in) :: igrid,K,channel_option + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS, NLINKSL + real, dimension(:), intent(in) :: chlon,chlat + real, dimension(:), intent(in) :: hlink,zelev + integer, dimension(:), intent(in) :: ORDER + integer, dimension(:), intent(inout) :: STRMFRXSTPTS + character(len=15), dimension(:), intent(inout) :: gages + character(len=15), intent(in) :: gageMiss + real, intent(in) :: lsmDt + + real, intent(in) :: dtrt_ch + real, dimension(:,:), intent(in) :: qlink +#ifdef WRF_HYDRO_NUDGING + real, dimension(:), intent(in) :: nudge +#endif + + integer, intent(in) :: UDMP_OPT + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + real, allocatable, DIMENSION(:) :: chanlat,chanlon + real, allocatable, DIMENSION(:) :: chanlatO,chanlonO + + real, allocatable, DIMENSION(:) :: elevation + real, allocatable, DIMENSION(:) :: elevationO + + integer, allocatable, DIMENSION(:) :: station_id + integer, allocatable, DIMENSION(:) :: station_idO + + integer, allocatable, DIMENSION(:) :: rec_num_of_station + integer, allocatable, DIMENSION(:) :: rec_num_of_stationO + + integer, allocatable, DIMENSION(:) :: lOrder !- local stream order + integer, allocatable, DIMENSION(:) :: lOrderO !- local stream order + + integer, save :: output_count + integer, save :: ncid,ncid2 + + integer :: stationdim, dimdata, varid, charid, n + integer :: obsdim, dimdataO, charidO + integer :: timedim, timedim2 + character(len=34) :: sec_valid_date + + integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output + integer :: start_posO, prev_posO, nlk + + integer :: previous_pos !-- used for the station model + character(len=256) :: output_flnm,output_flnm2 + character(len=19) :: date19,date19start, hydroTime + character(len=34) :: sec_since_date + integer :: seconds_since,nstations,cnt,ObsStation,nobs + character(len=32) :: convention + character(len=11),allocatable, DIMENSION(:) :: stname + character(len=15),allocatable, DIMENSION(:) :: stnameO + + !--- all this for writing the station id string + INTEGER TDIMS, TXLEN + PARAMETER (TDIMS=2) ! number of TX dimensions + PARAMETER (TXLEN = 11) ! length of example string + INTEGER TIMEID ! record dimension id + INTEGER TXID ! variable ID + INTEGER TXDIMS(TDIMS) ! variable shape + INTEGER TSTART(TDIMS), TCOUNT(TDIMS) + + !-- observation point ids + INTEGER OTDIMS, OTXLEN + PARAMETER (OTDIMS=2) ! number of TX dimensions + PARAMETER (OTXLEN = 15) ! length of example string + INTEGER OTIMEID ! record dimension id + INTEGER OTXID ! variable ID + INTEGER OTXDIMS(OTDIMS) ! variable shape + INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) + + real,dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket + + !! currently, this is the time of the hydro model, it's + !! lsm time (olddate) plus one lsm timestep + !call geth_newdate(hydroTime, date, nint(lsmDt)) + hydroTime=date + + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + +! order_to_write = 2 !-- 1 all; 6 fewest + nstations = 0 ! total number of channel points to display + nobs = 0 ! number of observation points + + if(channel_option .ne. 3) then + nlk = NLINKSL + else + nlk = NLINKS + endif + + +!-- output only the higher oder streamflows and only observation points + do i=1,nlk + if(ORDER(i) .ge. order_to_write) nstations = nstations + 1 + if(channel_option .ne. 3) then + if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1 + else + if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1 + endif + enddo + + if (nobs .eq. 0) then ! let's at least make one obs point + nobs = 1 + if(channel_option .ne. 3) then + ! 123456789012345 + gages(1) = ' dummy' + else + STRMFRXSTPTS(1) = 1 + endif + endif + + allocate(chanlat(nstations)) + allocate(chanlon(nstations)) + allocate(elevation(nstations)) + allocate(lOrder(nstations)) + allocate(stname(nstations)) + allocate(station_id(nstations)) + allocate(rec_num_of_station(nstations)) + + allocate(chanlatO(nobs)) + allocate(chanlonO(nobs)) + allocate(elevationO(nobs)) + allocate(lOrderO(nobs)) + allocate(stnameO(nobs)) + allocate(station_idO(nobs)) + allocate(rec_num_of_stationO(nobs)) + + if(output_count == 0) then +!-- have moved sec_since_date from above here.. + sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & + //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + nstations = 0 + nobs = 0 + + write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + if (iret /= 0) then + call hydro_stop("In output_chrt() - Problem nf_create points") + endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2) +#else + iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2) +#endif + if (iret /= 0) then + call hydro_stop("In output_chrt() - Problem nf_create observation") + endif + + do i=1,nlk + if(ORDER(i) .ge. order_to_write) then + nstations = nstations + 1 + chanlat(nstations) = chlat(i) + chanlon(nstations) = chlon(i) + elevation(nstations) = zelev(i) + lOrder(nstations) = ORDER(i) + station_id(nstations) = i + if(STRMFRXSTPTS(nstations) .eq. -9999) then + ObsStation = 0 + else + ObsStation = 1 + endif + write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation + endif + enddo + + + do i=1,nlk + if(channel_option .ne. 3) then + if(trim(gages(i)) .ne. trim(gageMiss)) then + nobs = nobs + 1 + chanlatO(nobs) = chlat(i) + chanlonO(nobs) = chlon(i) + elevationO(nobs) = zelev(i) + lOrderO(nobs) = ORDER(i) + station_idO(nobs) = i + stnameO(nobs) = gages(i) + endif + else + if(STRMFRXSTPTS(i) .ne. -9999) then + nobs = nobs + 1 + chanlatO(nobs) = chlat(i) + chanlonO(nobs) = chlon(i) + elevationO(nobs) = zelev(i) + lOrderO(nobs) = ORDER(i) + station_idO(nobs) = i + write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) +#ifdef HYDRO_D + ! print *,"stationobservation name", stnameO(nobs) +#endif + endif + endif + enddo + + iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach + iret = nf_def_dim(ncid, "station", nstations, stationdim) + iret = nf_def_dim(ncid, "time", 1, timedim) + + + iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO) !--for linked list approach + iret = nf_def_dim(ncid2, "station", nobs, obsdim) + iret = nf_def_dim(ncid2, "time", 1, timedim2) + + !- station location definition all, lat + iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude') + iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') + + !- station location definition obs, lat + iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude') + iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north') + + + !- station location definition, long + iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude') + iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') + + + !- station location definition, obs long + iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude') + iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east') + + +! !-- elevation is ZELEV + iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude') + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + + +! !-- elevation is obs ZELEV + iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude') + iret = nf_put_att_text(ncid2,varid,'units',6,'meters') + + +! !-- gage observation +! iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid) +! iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location') +! iret = nf_put_att_text(ncid,varid,'units',4,'none') + +!-- parent index + iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record') + + iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record') + + !-- prevChild + iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station') +!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) + + !-- lastChild + iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station') +!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) + +! !- flow definition, var + + if(UDMP_OPT .eq. 1) then + iret = nf_def_var(ncid, "accLndRunOff", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'unknow') + iret = nf_put_att_text(ncid,varid,'long_name',10,'ACCUMULATED runoff from land') + + iret = nf_def_var(ncid, "accQLateral", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'unknow') + iret = nf_put_att_text(ncid,varid,'long_name',10,'Total ACCUMULATED runoff') + + iret = nf_def_var(ncid, "accStrmvolrt", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'unknow') + iret = nf_put_att_text(ncid,varid,'long_name',10,'ACCUMULATED runoff from terrain routing') + + iret = nf_def_var(ncid, "accBucket", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'unknow') + iret = nf_put_att_text(ncid,varid,'long_name',10,'ACCUMULATED runoff from gw bucket') + endif + + iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow') + + iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow') + +#ifdef WRF_HYDRO_NUDGING + iret = nf_def_var(ncid, "nudge", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',32,'Amount of stream flow alteration') + + iret = nf_def_var(ncid2, "nudge", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid2,varid,'long_name',32,'Amount of stream flow alteration') +#endif + +! !- flow definition, var +! iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid) +! iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') +! iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow') + +#ifndef HYDRO_REALTIME +! !- head definition, var + iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',5,'meter') + iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage') + + iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',5,'meter') + iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage') +#endif + +! !- order definition, var + iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order') + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order') + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + !-- station id + ! define character-position dimension for strings of max length 11 + iret = NF_DEF_DIM(ncid, "id_len", 11, charid) + TXDIMS(1) = charid ! define char-string variable and position dimension first + TXDIMS(2) = stationdim + iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) + iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') + + + iret = NF_DEF_DIM(ncid2, "id_len", 15, charidO) + OTXDIMS(1) = charidO ! define char-string variable and position dimension first + OTXDIMS(2) = obsdim + iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid) + iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id') + + +! !- time definition, timeObs + iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time') + + iret = nf_def_var(ncid2,"time",NF_INT, 1, (/timedim2/), varid) + iret = nf_put_att_text(ncid2,varid,'units',34,sec_valid_date) + iret = nf_put_att_text(ncid2,varid,'long_name',17,'valid output time') + + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) + + convention(1:32) = "Unidata Observation Dataset v1.0" + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") +#ifndef HYDRO_REALTIME + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") +#endif + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_text(ncid, NF_GLOBAL, "station_dimension",7, "station") + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_int(ncid, NF_GLOBAL, "stream_order_output",NF_INT,1,order_to_write) + + iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station") +#ifndef HYDRO_REALTIME + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") +#endif + iret = nf_put_att_text(ncid2, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "station_dimension",7, "station") + iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream_order_output",NF_INT,1,order_to_write) + + iret = nf_enddef(ncid) + iret = nf_enddef(ncid2) + + !-- write latitudes + iret = nf_inq_varid(ncid,"latitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat) + + iret = nf_inq_varid(ncid2,"latitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO) + + !-- write longitudes + iret = nf_inq_varid(ncid,"longitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon) + + iret = nf_inq_varid(ncid2,"longitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO) + + !-- write elevations + iret = nf_inq_varid(ncid,"altitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation) + + iret = nf_inq_varid(ncid2,"altitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO) + + !-- write gage location +! iret = nf_inq_varid(ncid,"gages", varid) +! iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS) + + !-- write number_of_stations, OPTIONAL + !! iret = nf_inq_varid(ncid,"number_stations", varid) + !! iret = nf_put_var_int(ncid, varid, nstations) + + !-- write station id's + do i=1,nstations + TSTART(1) = 1 + TSTART(2) = i + TCOUNT(1) = TXLEN + TCOUNT(2) = 1 + iret = nf_inq_varid(ncid,"station_id", varid) + iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) + enddo + + !-- write observation id's + do i=1, nobs + OTSTART(1) = 1 + OTSTART(2) = i + OTCOUNT(1) = OTXLEN + OTCOUNT(2) = 1 + iret = nf_inq_varid(ncid2,"station_id", varid) + iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i)) + enddo + + endif + + output_count = output_count + 1 + + open (unit=55, & +#ifndef NCEP_WCOSS + file='frxst_pts_out.txt', & +#endif + status='unknown',position='append') + + cnt=0 + do i=1,nlk + + if(ORDER(i) .ge. order_to_write) then + start_pos = (cnt+1)+(nstations*(output_count-1)) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) + + if(UDMP_OPT .eq. 1) then + iret = nf_inq_varid(ncid,"accLndRunOff", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accLndRunOff(i)) + + iret = nf_inq_varid(ncid,"accQLateral", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accQLateral(i)) + + iret = nf_inq_varid(ncid,"accStrmvolrt", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accStrmvolrt(i)) + + iret = nf_inq_varid(ncid,"accBucket", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accBucket(i)) + endif + + iret = nf_inq_varid(ncid,"streamflow", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1)) + +#ifdef WRF_HYDRO_NUDGING + iret = nf_inq_varid(ncid,"nudge", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), nudge(i)) +#endif + +! iret = nf_inq_varid(ncid,"pos_streamflow", varid) +! iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1))) + +#ifndef HYDRO_REALTIME + iret = nf_inq_varid(ncid,"head", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i)) +#endif + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid,"parent_index", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) + + !--record number of previous record for same station +!obsolete format prev_pos = cnt+(nstations*(output_count-1)) + prev_pos = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid,"prevChild", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) + endif + cnt=cnt+1 !--indices are 0 based + rec_num_of_station(cnt) = start_pos-1 !-- save position for last child, 0-based!! + + + endif + enddo +! close(999) + + !-- output only observation points + cnt=0 + do i=1,nlk + if(channel_option .ne. 3) then + ! jlm this verry repetitiuos, oh well. + if(trim(gages(i)) .ne. trim(gageMiss)) then + + start_posO = (cnt+1)+(nobs * (output_count-1)) + !Write frxst_pts to text file... + !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & +118 FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) + !write(55,118) seconds_since, date(1:10), date(12:19), & +#ifndef HYDRO_REALTIME + write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), & + gages(i), chlon(i), chlat(i), & + qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) +#endif + !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) + !yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid2,"time", varid) + iret = nf_put_vara_int(ncid2, varid, (/1/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid2,"streamflow", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1)) + +#ifdef WRF_HYDRO_NUDGING + iret = nf_inq_varid(ncid2,"nudge", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), nudge(i)) +#endif + +#ifndef HYDRO_REALTIME + iret = nf_inq_varid(ncid2,"head", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i)) +#endif + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid2,"parent_index", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt) + + !--record number of previous record for same station + !obsolete format prev_posO = cnt+(nobs*(output_count-1)) + prev_posO = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid2,"prevChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + + !IF block to add -1 to last element of prevChild array to designate end of list... + ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) + ! else + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + ! endif + + endif + cnt=cnt+1 !--indices are 0 based + rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! + endif + + + else !! channel options 3 below + + if(STRMFRXSTPTS(i) .ne. -9999) then + start_posO = (cnt+1)+(nobs * (output_count-1)) + !Write frxst_pts to text file... + !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & +117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) + !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & + ! qlink(i,1), qlink(i,1)*35.315,hlink(i) + ! JLM: makes more sense to output the value in frxstpts incase they have meaning, + ! as below, but I'm not going to make this change until I'm working with gridded + ! streamflow again. + write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), & + strmfrxstpts(i), chlon(i), chlat(i), & + qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid2,"time", varid) + iret = nf_put_vara_int(ncid2, varid, (/1/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid2,"streamflow", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1)) + +#ifndef HYDRO_REALTIME + iret = nf_inq_varid(ncid2,"head", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i)) +#endif + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid2,"parent_index", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt) + + !--record number of previous record for same station + !obsolete format prev_posO = cnt+(nobs*(output_count-1)) + prev_posO = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid2,"prevChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + + !IF block to add -1 to last element of prevChild array to designate end of list... + ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) + ! else + ! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + ! endif + + endif + cnt=cnt+1 !--indices are 0 based + rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! + endif + + endif + + enddo + close(55) + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid,"lastChild", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station) + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid2,"lastChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO) + + iret = nf_redef(ncid) + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + + iret = nf_redef(ncid2) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + + iret = nf_enddef(ncid2) + iret = nf_sync(ncid2) + + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + iret = nf_close(ncid2) + endif + + if(allocated(chanlat)) deallocate(chanlat) + if(allocated(chanlon)) deallocate(chanlon) + if(allocated(elevation)) deallocate(elevation) + if(allocated(station_id)) deallocate(station_id) + if(allocated(lOrder)) deallocate(lOrder) + if(allocated(rec_num_of_station)) deallocate(rec_num_of_station) + if(allocated(stname)) deallocate(stname) + + if(allocated(chanlatO)) deallocate(chanlatO) + if(allocated(chanlonO)) deallocate(chanlonO) + if(allocated(elevationO)) deallocate(elevationO) + if(allocated(station_idO)) deallocate(station_idO) + if(allocated(lOrderO)) deallocate(lOrderO) + if(allocated(rec_num_of_stationO)) deallocate(rec_num_of_stationO) + if(allocated(stnameO)) deallocate(stnameO) +#ifdef HYDRO_D + print *, "Exited Subroutine output_chrt" +#endif + close(16) + +20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3) + +end subroutine output_chrt_bak + +#ifdef MPP_LAND +!-- output the channel route in an IDV 'station' compatible format + subroutine mpp_output_chrt(gnlinks,gnlinksl,map_l2g,igrid, & + split_output_count, NLINKS, ORDER, & + startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch, & + K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, & + lsmDt & +#ifdef WRF_HYDRO_NUDGING + , nudge & +#endif + , accLndRunOff, accQLateral, accStrmvolrt, accBucket, UDMP_OPT & + ) + + USE module_mpp_land + + implicit none + +!!output the routing variables over just channel + integer, intent(in) :: igrid,K,channel_option,NLINKSL + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS + real, dimension(:), intent(in) :: chlon,chlat + real, dimension(:), intent(in) :: hlink,zelev + + integer, dimension(:), intent(in) :: ORDER + integer, dimension(:), intent(inout) :: STRMFRXSTPTS + character(len=15), dimension(:), intent(inout) :: gages + character(len=15), intent(in) :: gageMiss + real, intent(in) :: lsmDt + + real, intent(in) :: dtrt_ch + real, dimension(:,:), intent(in) :: qlink +#ifdef WRF_HYDRO_NUDGING + real, dimension(:), intent(in) :: nudge +#endif + + integer, intent(in) :: UDMP_OPT + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + integer :: gnlinks, map_l2g(nlinks), order_to_write, gnlinksl + real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev +#ifdef WRF_HYDRO_NUDGING + real, allocatable,dimension(:) :: g_nudge +#endif + integer, allocatable,dimension(:) :: g_order,g_STRMFRXSTPTS + real,allocatable,dimension(:,:) :: g_qlink + integer :: gsize + character(len=15),allocatable,dimension(:) :: g_gages + real,allocatable,dimension(:) :: g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket + real, dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket + + gsize = gNLINKS + if(gnlinksl .gt. gsize) gsize = gnlinksl + if(my_id .eq. io_id ) then + allocate(g_chlon(gsize )) + allocate(g_chlat(gsize )) + allocate(g_hlink(gsize )) + allocate(g_zelev(gsize )) + allocate(g_qlink(gsize ,2)) +#ifdef WRF_HYDRO_NUDGING + allocate(g_nudge(gsize)) +#endif + allocate(g_order(gsize )) + allocate(g_STRMFRXSTPTS(gsize )) + allocate(g_gages(gsize)) + + allocate(g_accLndRunOff(gsize )) + allocate(g_accQLateral(gsize )) + allocate(g_accStrmvolrt(gsize )) + allocate(g_accBucket(gsize )) + + else + + allocate(g_accLndRunOff(1)) + allocate(g_accQLateral(1)) + allocate(g_accStrmvolrt(1)) + allocate(g_accBucket(1)) + + allocate(g_chlon(1)) + allocate(g_chlat(1)) + allocate(g_hlink(1)) + allocate(g_zelev(1)) + allocate(g_qlink(1,2)) +#ifdef WRF_HYDRO_NUDGING + allocate(g_nudge(1)) +#endif + allocate(g_order(1)) + allocate(g_STRMFRXSTPTS(1)) + allocate(g_gages(1)) + endif + + call mpp_land_sync() + + if(channel_option .eq. 1 .or. channel_option .eq. 2) then + g_qlink = 0 + g_gages = gageMiss + call ReachLS_write_io(qlink(:,1), g_qlink(:,1)) + call ReachLS_write_io(qlink(:,2), g_qlink(:,2)) +#ifdef WRF_HYDRO_NUDGING + g_nudge=0 + call ReachLS_write_io(nudge,g_nudge) +#endif + call ReachLS_write_io(order, g_order) + call ReachLS_write_io(chlon, g_chlon) + call ReachLS_write_io(chlat, g_chlat) + call ReachLS_write_io(zelev, g_zelev) +!yw This function does not work correctly for gages +!yw call ReachLS_write_io(gages, g_gages) + call ReachLS_write_io(STRMFRXSTPTS, g_STRMFRXSTPTS) + call ReachLS_write_io(hlink, g_hlink) + + call ReachLS_write_io(accLndRunOff, g_accLndRunOff) + call ReachLS_write_io(accQLateral, g_accQLateral) + call ReachLS_write_io(accStrmvolrt, g_accStrmvolrt) + call ReachLS_write_io(accBucket, g_accBucket) + + else + call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) + call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) + call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) + call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) + call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) + call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) + call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS) + call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) + endif + + + if(my_id .eq. IO_id) then + call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER, & + startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K, & + g_STRMFRXSTPTS,order_to_write,gNLINKSL,channel_option, g_gages, gageMiss, & + lsmDt & +#ifdef WRF_HYDRO_NUDGING + , g_nudge & +#endif + , g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket, UDMP_OPT & + ) + + end if + call mpp_land_sync() + if(allocated(g_order)) deallocate(g_order) + if(allocated(g_STRMFRXSTPTS)) deallocate(g_STRMFRXSTPTS) + if(allocated(g_chlon)) deallocate(g_chlon) + if(allocated(g_chlat)) deallocate(g_chlat) + if(allocated(g_hlink)) deallocate(g_hlink) + if(allocated(g_zelev)) deallocate(g_zelev) + if(allocated(g_qlink)) deallocate(g_qlink) + if(allocated(g_gages)) deallocate(g_gages) +#ifdef WRF_HYDRO_NUDGING + if(allocated(g_nudge)) deallocate(g_nudge) +#endif + if(allocated(g_accLndRunOff)) deallocate(g_accLndRunOff) + if(allocated(g_accQLateral)) deallocate(g_accQLateral) + if(allocated(g_accStrmvolrt)) deallocate(g_accStrmvolrt) + if(allocated(g_accBucket)) deallocate(g_accBucket) + +end subroutine mpp_output_chrt + +!--------- lake netcdf output ----------------------------------------- +!-- output the ilake info an IDV 'station' compatible format ----------- + subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt_ch,K) + + USE module_mpp_land + +!!output the routing variables over just channel + integer, intent(in) :: igrid, K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLAKES + real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht + real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake + real, intent(in) :: dtrt_ch + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + integer lake_index(nlakes) + + + call write_lake_real(latlake,lake_index,nlakes) + call write_lake_real(lonlake,lake_index,nlakes) + call write_lake_real(elevlake,lake_index,nlakes) + call write_lake_real(resht,lake_index,nlakes) + call write_lake_real(qlakei,lake_index,nlakes) + call write_lake_real(qlakeo,lake_index,nlakes) + if(my_id.eq. IO_id) then + call output_lakes(igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt_ch,K) + end if + call mpp_land_sync() + return + end subroutine mpp_output_lakes + + subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM) + + USE module_mpp_land + +!!output the routing variables over just channel + integer, intent(in) :: igrid, K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLAKES + real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht + real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake + real, intent(in) :: dtrt_ch + integer, dimension(NLAKES), intent(in) :: LAKEIDM ! lake id + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + integer lake_index(nlakes) + + call write_lake_real(latlake,lake_index,nlakes) + call write_lake_real(lonlake,lake_index,nlakes) + call write_lake_real(elevlake,lake_index,nlakes) + call write_lake_real(resht,lake_index,nlakes) + call write_lake_real(qlakei,lake_index,nlakes) + call write_lake_real(qlakeo,lake_index,nlakes) + + if(my_id.eq. IO_id) then + call output_lakes2(igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM) + end if + call mpp_land_sync() + return + end subroutine mpp_output_lakes2 +#endif + +!----------------------------------- lake netcdf output +!-- output the ilake info an IDV 'station' compatible format + subroutine output_lakes(igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt_ch,K) + +!!output the routing variables over just channel + integer, intent(in) :: igrid, K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLAKES + real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht + real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake + real, intent(in) :: dtrt_ch + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + integer, allocatable, DIMENSION(:) :: station_id + integer, allocatable, DIMENSION(:) :: rec_num_of_lake + + integer, save :: output_count + integer, save :: ncid + + integer :: stationdim, dimdata, varid, charid, n + integer :: iret,i, start_pos, prev_pos !-- + integer :: previous_pos !-- used for the station model + character(len=256) :: output_flnm + character(len=19) :: date19, date19start + character(len=34) :: sec_since_date + integer :: seconds_since,cnt + character(len=32) :: convention + character(len=6),allocatable, DIMENSION(:) :: stname + integer :: timedim + character(len=34) :: sec_valid_date + + !--- all this for writing the station id string + INTEGER TDIMS, TXLEN + PARAMETER (TDIMS=2) ! number of TX dimensions + PARAMETER (TXLEN = 6) ! length of example string + INTEGER TIMEID ! record dimension id + INTEGER TXID ! variable ID + INTEGER TXDIMS(TDIMS) ! variable shape + INTEGER TSTART(TDIMS), TCOUNT(TDIMS) + +! sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' +! seconds_since = int(dtrt_ch)*output_count + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + + allocate(station_id(NLAKES)) + allocate(rec_num_of_lake(NLAKES)) + allocate(stname(NLAKES)) + + if (output_count == 0) then + +!-- have moved sec_since_date from above here.. + sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & + //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + + if (iret /= 0) then + call hydro_stop("In output_lakes() - Problem nf_create") + endif + + do i=1,NLAKES + station_id(i) = i + write(stname(i),'(I6)') i + enddo + + iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach + iret = nf_def_dim(ncid, "station", nlakes, stationdim) + iret = nf_def_dim(ncid, "time", 1, timedim) + +#ifndef HYDRO_REALTIME + !- station location definition, lat + iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude') + iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') + + !- station location definition, long + iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude') + iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') + +! !-- lake's phyical elevation + iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude') + iret = nf_put_att_text(ncid,varid,'units',6,'meters') +#endif + + !-- parent index + iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',33,'index of the lake for this record') + + !-- prevChild + iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',54,'record number of the previous record for the same lake') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + !-- lastChild + iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',27,'latest report for this lake') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + +! !- water surface elevation + iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + iret = nf_put_att_text(ncid,varid,'long_name',23,'Water Surface Elevation') + +! !- inflow to lake + iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + +! !- outflow to lake + iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + + !-- station id + ! define character-position dimension for strings of max length 6 + iret = NF_DEF_DIM(ncid, "id_len", 6, charid) + TXDIMS(1) = charid ! define char-string variable and position dimension first + TXDIMS(2) = stationdim + iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) + iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') + +! !- time definition, timeObs + iret = nf_def_var(ncid,"time", NF_INT, 1, (/timedim/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time') + +! date19(1:19) = "0000-00-00_00:00:00" +! date19(1:len_trim(startdate)) = startdate +! iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) +! + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "Unidata Observation Dataset v1.0" + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") +#ifndef HYDRO_REALTIME + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") +#endif + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_text(ncid, NF_GLOBAL, "station_dimension",7, "station") +!! iret = nf_put_att_text(ncid, NF_GLOBAL, "observation_dimension",6, "recNum") +!! iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coordinate",16,"time_observation") + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_enddef(ncid) + +#ifndef HYDRO_REALTIME + !-- write latitudes + iret = nf_inq_varid(ncid,"latitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE) + + !-- write longitudes + iret = nf_inq_varid(ncid,"longitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE) + + !-- write physical height of lake + iret = nf_inq_varid(ncid,"altitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake) +#endif + + !-- write station id's + do i=1,nlakes + TSTART(1) = 1 + TSTART(2) = i + TCOUNT(1) = TXLEN + TCOUNT(2) = 1 + iret = nf_inq_varid(ncid,"station_id", varid) + iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) + enddo + + endif + + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) + + output_count = output_count + 1 + + cnt=0 + do i=1,NLAKES + + start_pos = (cnt+1)+(nlakes*(output_count-1)) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid,"time_observation", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid,"elevation", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), resht(i)) + + iret = nf_inq_varid(ncid,"inflow", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakei(i)) + + iret = nf_inq_varid(ncid,"outflow", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakeo(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid,"parent_index", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) + + !--record number of previous record for same station + prev_pos = cnt+(nlakes*(output_count-1)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid,"prevChild", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) + endif + + cnt=cnt+1 !--indices are 0 based + rec_num_of_lake(cnt) = start_pos-1 !-- save position for last child, 0-based!! + + enddo + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid,"lastChild", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) + + !-- number of children reported for this station, OPTIONAL + !-- iret = nf_inq_varid(ncid,"numChildren", varid) + !-- iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) + + iret = nf_redef(ncid) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_enddef(ncid) + + iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif + + if(allocated(station_id)) deallocate(station_id) + if(allocated(rec_num_of_lake)) deallocate(rec_num_of_lake) + if(allocated(stname)) deallocate(stname) +#ifdef HYDRO_D + print *, "Exited Subroutine output_lakes" +#endif + close(16) + + end subroutine output_lakes + +!----------------------------------- lake netcdf output +!-- output the lake as regular netcdf file format for better performance than point netcdf file. + subroutine output_lakes2(igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt_ch,K,LAKEIDM) + +!!output the routing variables over just channel + integer, intent(in) :: igrid, K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLAKES + real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht + real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake + integer, dimension(NLAKES), intent(in) :: LAKEIDM !-- LAKE ID + real, intent(in) :: dtrt_ch + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + + integer, save :: output_count + integer, save :: ncid + + integer :: stationdim, varid, n + integer :: iret,i !-- + character(len=256) :: output_flnm + character(len=19) :: date19, date19start + character(len=32) :: convention + integer :: timedim + integer :: seconds_since + character(len=34) :: sec_valid_date + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + + if (output_count == 0) then + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("output_lakes") + endif + + iret = nf_def_dim(ncid, "station", nlakes, stationdim) + + iret = nf_def_dim(ncid, "time", 1, timedim) + +#ifndef HYDRO_REALTIME + !- station location definition, lat + iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude') + iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') +#endif + + !- station location definition, LAKEIDM + iret = nf_def_var(ncid,"lake_id",NF_INT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake COMMON ID') + +#ifndef HYDRO_REALTIME + !- station location definition, long + iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude') + iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') + +! !-- lake's phyical elevation + iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude') + iret = nf_put_att_text(ncid,varid,'units',6,'meters') +#endif + +! !- water surface elevation + iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + iret = nf_put_att_text(ncid,varid,'long_name',23,'Water Surface Elevation') + +! !- inflow to lake + iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + +! !- outflow to lake + iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + + ! Time variable + iret = nf_def_var(ncid, "time", NF_INT, 1, (/timeDim/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time') + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate +#ifndef HYDRO_REALTIME + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") +#endif + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_enddef(ncid) + + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) + +#ifndef HYDRO_REALTIME + !-- write latitudes + iret = nf_inq_varid(ncid,"latitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE) + + !-- write longitudes + iret = nf_inq_varid(ncid,"longitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE) + + !-- write physical height of lake + iret = nf_inq_varid(ncid,"altitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake) +#endif + + !-- write elevation of lake + iret = nf_inq_varid(ncid,"elevation", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), resht ) + + !-- write elevation of inflow + iret = nf_inq_varid(ncid,"inflow", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), qlakei ) + + !-- write elevation of inflow + iret = nf_inq_varid(ncid,"outflow", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), qlakeo ) + + !-- write lake id + iret = nf_inq_varid(ncid,"lake_id", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/NLAKES/), LAKEIDM) + + endif + + output_count = output_count + 1 + + + iret = nf_redef(ncid) + + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + iret = nf_enddef(ncid) + + iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif + + end subroutine output_lakes2 +!----------------------------------- lake netcdf output + +#ifdef MPP_LAND + +!-- output the channel route in an IDV 'grid' compatible format + subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & + NLINKS,CH_NETLNK_in, startdate, date, & + qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt ) + + USE module_mpp_land + + implicit none +#include + integer g_ixrt,g_jxrt + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS,ixrt,jxrt + real, intent(in) :: dt + real, dimension(:,:), intent(in) :: qlink + integer, dimension(IXRT,JXRT), intent(in) :: CH_NETLNK_in + character(len=*), intent(in) :: geo_finegrid_flnm + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + integer:: gnlinks , map_l2g(nlinks) + + integer, allocatable,dimension(:,:) :: CH_NETLNK + real, allocatable,dimension(:,:) :: g_qlink + + if(my_id .eq. io_id) then + allocate(CH_NETLNK(g_IXRT,g_JXRT)) + allocate(g_qlink(gNLINKS,2) ) + else + allocate(CH_NETLNK(1,1)) + allocate(g_qlink(1,2) ) + endif + + call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) + call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) + + call write_IO_rt_int(CH_NETLNK_in, CH_NETLNK) + + if(my_id.eq.IO_id) then + call output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, & + GNLINKS, CH_NETLNK, startdate, date, & + g_qlink, dt, geo_finegrid_flnm) + endif + + if(allocated(g_qlink)) deallocate(g_qlink) + if(allocated(CH_NETLNK)) deallocate(CH_NETLNK) + return + end subroutine mpp_output_chrtgrd +#endif + +!-- output the channel route in an IDV 'grid' compatible format + subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & + NLINKS, CH_NETLNK, startdate, date, & + qlink, dt, geo_finegrid_flnm) + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS,ixrt,jxrt + real, intent(in) :: dt + real, dimension(:,:), intent(in) :: qlink + integer, dimension(IXRT,JXRT), intent(in) :: CH_NETLNK + character(len=*), intent(in) :: geo_finegrid_flnm + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + character(len=32) :: convention + integer,save :: output_count + integer, save :: ncid,ncstatic + real, dimension(IXRT,JXRT) :: tmpflow + real, dimension(IXRT) :: xcoord + real, dimension(JXRT) :: ycoord + real :: long_cm,lat_po,fe,fn + real, dimension(2) :: sp + + integer :: varid, n + integer :: jxlatdim,ixlondim,timedim !-- dimension ids + integer :: timedim2 + character(len=34) :: sec_valid_date + + integer :: iret,i,j + character(len=256) :: output_flnm + character(len=19) :: date19 + character(len=34) :: sec_since_date + + + integer :: seconds_since + + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + + tmpflow = -9E15 + + + write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + + +!--- define dimension +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + + if (iret /= 0) then + call hydro_stop("In output_chrtgrd() - Problem nf_create ") + endif + + iret = nf_def_dim(ncid, "time", NF_UNLIMITED, timedim) + iret = nf_def_dim(ncid, "x", ixrt, ixlondim) + iret = nf_def_dim(ncid, "y", jxrt, jxlatdim) + +!--- define variables +! !- time definition, timeObs + + !- x-coordinate in cartesian system +!yw iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/ixlondim/), varid) +!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') +!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') +!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- y-coordinate in cartesian ssystem +!yw iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/jxlatdim/), varid) +!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') +!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') +!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + +! !- flow definition, var + iret = nf_def_var(ncid,"streamflow",NF_REAL, 3, (/ixlondim,jxlatdim,timedim/), varid) + iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') + iret = nf_put_att_text(ncid,varid,'long_name',15,'water flow rate') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + iret = nf_def_var(ncid,"index",NF_INT, 2, (/ixlondim,jxlatdim/), varid) + iret = nf_def_var(ncid, "time", NF_INT, 1, (/timedim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time') + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + + +!-- place prjection information + + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "CF-1.0" + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + + iret = nf_enddef(ncid) + + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) + +!!-- write latitude and longitude locations + +!DJG inv do j=jxrt,1,-1 + do j=1,jxrt + do i=1,ixrt + if(CH_NETLNK(i,j).GE.0) then + tmpflow(i,j) = qlink(CH_NETLNK(i,j),1) + else + tmpflow(i,j) = -9E15 + endif + enddo + enddo + +!!time in seconds since startdate + iret = nf_inq_varid(ncid,"index", varid) + iret = nf_put_vara_int(ncid, varid, (/1,1/), (/ixrt,jxrt/),CH_NETLNK) + + iret = nf_inq_varid(ncid,"streamflow", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ixrt,jxrt,1/),tmpflow) + + iret = nf_close(ncid) + + + + end subroutine output_chrtgrd + + + subroutine read_chan_forcing( & + indir,olddate,startdate,hgrid,& + ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT) +! This subrouting is going to read channel forcing for +! channel only simulations (ie when CHANRTSWCRT = 2) + + implicit none +#include + ! in variable + character(len=*) :: olddate,hgrid,indir,startdate + character(len=256) :: filename + integer :: ixrt,jxrt + real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT + ! tmp variable + character(len=256) :: inflnm, product + integer :: i,j,mmflag + character(len=256) :: units + integer :: ierr + integer :: ncid + + +!DJG Create filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".RTOUT_DOMAIN"//hgrid +#ifdef HYDRO_D + print *, "Channel forcing file...",inflnm +#endif + + +!DJG Open NetCDF file... + ierr = nf_open(inflnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm) + call hydro_stop("In read_chan_forcing() - Problem opening netcdf file") + endif + +!DJG read data... + call get_2d_netcdf("QSTRMVOLRT", ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr) +!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) +!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) + + ierr = nf_close(ncid) + + end subroutine read_chan_forcing + + + + subroutine get2d_int(var_name,out_buff,ix,jx,fileName, fatalErr) + implicit none +#include + integer :: iret,varid,ncid,ix,jx + integer out_buff(ix,jx) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: fileName + logical, optional, intent(in) :: fatalErr + logical :: fatalErr_local + character(len=256) :: errMsg + + fatalErr_local = .false. + if(present(fatalErr)) fatalErr_local=fatalErr + + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) + if (iret .ne. 0) then + errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName) + print*, trim(errMsg) + if(fatalErr_local) call hydro_stop(trim(errMsg)) + endif + + iret = nf_inq_varid(ncid,trim(var_name), varid) + if(iret .ne. 0) then + errMsg = "get2d_int: failed to find the variable: " // & + trim(var_name) // ' in ' // trim(fileName) + print*, trim(errMsg) + if(fatalErr_local) call hydro_stop(errMsg) + endif + + iret = nf_get_var_int(ncid, varid, out_buff) + if(iret .ne. 0) then + errMsg = "get2d_int: failed to read the variable: " // & + trim(var_name) // " in " //trim(fileName) + print*,trim(errMsg) + if(fatalErr_local) call hydro_stop(trim(errMsg)) + endif + + iret = nf_close(ncid) + if(iret .ne. 0) then + errMsg = "get2d_int: failed to close the file: " // & + trim(fileName) + print*,trim(errMsg) + if(fatalErr_local) call hydro_stop(trim(errMsg)) + endif + + return + end subroutine get2d_int + + +#ifdef MPP_LAND + SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & + route_chan_f,route_link_f, & + route_direction_f, NLINKS, & + CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT) + + USE module_mpp_land + + implicit none +#include + INTEGER :: channel_option, did + INTEGER :: g_IXRT,g_JXRT + INTEGER, INTENT(INOUT) :: NLINKS, GNLINKS,NLINKSL + INTEGER, INTENT(IN) :: IXRT,JXRT + INTEGER :: CHNID,cnt + INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK !- each node gets unique id based on global domain + ! INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK ! temp array + INTEGER, allocatable,DIMENSION(:,:) :: g_CH_NETLNK ! temp array + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction + INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, DIMENSION(IXRT,JXRT) :: LAT, LON + INTEGER, INTENT(IN) :: UDMP_OPT + integer:: i,j + + CHARACTER(len=256) :: route_chan_f, route_link_f,route_direction_f + CHARACTER(len=256) :: geo_finegrid_flnm +! CHARACTER(len=*) :: geo_finegrid_flnm + +! integer, allocatable, dimension(:) :: tmp_int + integer :: ywcount + + + + if(my_id .eq. IO_id) then + allocate(g_CH_NETLNK(g_IXRT,g_JXRT)) + g_CH_NETLNK = -9999 + CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, & + route_direction_f, GNLINKS, & + g_CH_NETLNK, channel_option,geo_finegrid_flnm,NLINKSL, UDMP_OPT) + call get_NLINKSL(NLINKSL, channel_option, route_link_f) + else + allocate(g_CH_NETLNK(1,1)) + endif + + call mpp_land_bcast_int1(GNLINKS) + call mpp_land_bcast_int1(NLINKSL) + + + call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt) + if(allocated(g_CH_NETLNK)) deallocate(g_CH_NETLNK) + ywcount = 0 + CH_NETLNK = -9999 + do j = 1, jxrt + do i = 1, ixrt + if(GCH_NETLNK(i,j) .gt. 0) then + ywcount = ywcount + 1 + CH_NETLNK(i,j) = ywcount + endif + end do + end do + NLINKS = ywcount + + +!ywcheck +! CH_NETLNK = GCH_NETLNK + + + allocate(rt_domain(did)%map_l2g(NLINKS)) + + rt_domain(did)%map_l2g = -1 + do j = 1, jxrt + do i = 1, ixrt + if(CH_NETLNK(i,j) .gt. 0) then + rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j) + endif + end do + end do + + call mpp_chrt_nlinks_collect(NLINKS) + return + + 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) + + +#include + INTEGER, INTENT(IN) :: IXRT,JXRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT,CH_LNKRT +!Dummy inverted grids + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC + + integer :: I,J, iret, jj, channel_option, UDMP_OPT + CHARACTER(len=256) :: var_name + CHARACTER(len=*) :: route_topo_f + CHARACTER(len=*) :: route_chan_f + CHARACTER(len=*) :: geo_finegrid_flnm + + var_name = "TOPOGRAPHY" + + call nreadRT2d_real(var_name,ELRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + + IF(channel_option .ne. 3 .and. UDMP_OPT .ne. 1) then !get maxnodes and links from grid + var_name = "LINKID" + call nreadRT2d_int(var_name,CH_LNKRT,ixrt,jxrt,& + trim(geo_finegrid_flnm), fatalErr=.true.) + endif + + + +#ifdef HYDRO_D + write(6,*) "read linkid grid CH_LNKRT ",var_name +#endif + +!!!DY to be fixed ... 6/27/08 +! var_name = "BED_ELEVATION" +! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) + + var_name = "CHANNELGRID" + call nreadRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + + var_name = "LKSATFAC" + LKSATFAC = -9999.9 + call nreadRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + + where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... + + +!1.12.2012...Read in routing calibration factors... + var_name = "RETDEPRTFAC" + call nreadRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists + + var_name = "OVROUGHRTFAC" + call nreadRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists + + +#ifdef HYDRO_D + write(6,*) "finish READ_ROUTING_seq" +#endif + + return + +!DJG ----------------------------------------------------- + END SUBROUTINE READ_ROUTING_seq + +!DJG _____________________________ + subroutine output_lsm(outFile,did) + + + implicit none + + integer did + + character(len=*) outFile + + integer :: ncid,irt, dimid_ix, dimid_jx, & + dimid_ixrt, dimid_jxrt, varid, & + dimid_links, dimid_basns, dimid_soil + integer :: iret, n + character(len=2) tmpStr + + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) & +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(outFile), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + + if (iret /= 0) then + call hydro_stop("In output_lsm() - Problem nf_create") + endif + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif +#ifdef HYDRO_D + write(6,*) "output file ", outFile +#endif +! define dimension for variables + iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils + +#ifdef MPP_LAND + iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) +#else + iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) +#endif + +!define variables + do n = 1, nlst_rt(did)%nsoil + if( n .lt. 10) then + write(tmpStr, '(i1)') n + else + write(tmpStr, '(i2)') n + endif + iret = nf_def_var(ncid,"stc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"sh2ox"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + end do + + iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + + iret = nf_enddef(ncid) + +#ifdef MPP_LAND + endif +#endif + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SFCHEADRT,"sfcheadrt" ) + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif + + iret = nf_close(ncid) +#ifdef HYDRO_D + write(6,*) "finish writing outFile : ", outFile +#endif + +#ifdef MPP_LAND + endif +#endif + + return + end subroutine output_lsm + + + subroutine RESTART_OUT_nc(outFile,did) + + + implicit none + + integer did + integer :: n + character(len=2) :: tmpStr + character(len=*) outFile + + integer :: ncid,irt, dimid_ix, dimid_jx, & + dimid_ixrt, dimid_jxrt, varid, & + dimid_links, dimid_basns, dimid_soil, dimid_lakes + integer :: iret + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) & +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(outFile), NF_CLOBBER, ncid) +#ifdef HYDRO_D + write(6,*) "yyywww do not use large netcdf file definition. " + call flush(6) +#endif +#else + iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#ifdef HYDRO_D + write(6,*) "yyywww using large netcdf file definition. " + call flush(6) +#endif +#endif + + +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + + if (iret /= 0) then + call hydro_stop("In RESTART_OUT_nc() - Problem nf_create") + endif + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif +! define dimension for variables + iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils + +#ifdef MPP_LAND + iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) + iret = nf_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt) !-- make a decimated grid + iret = nf_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt) +#else + iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) + iret = nf_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt) !-- make a decimated grid + iret = nf_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt) +#endif + + if(nlst_rt(did)%channel_option .eq. 3) then + iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links) + else + iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinksl, dimid_links) + endif + iret = nf_def_dim(ncid, "basns", rt_domain(did)%gnumbasns, dimid_basns) + if(rt_domain(did)%nlakes .gt. 0) then + iret = nf_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes) + endif + +!define variables + do n = 1, nlst_rt(did)%nsoil + if( n .lt. 10) then + write(tmpStr, '(i1)') n + else + write(tmpStr, '(i2)') n + endif + iret = nf_def_var(ncid,"stc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"sh2ox"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + end do + + iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"sfcheadsubrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + do n = 1, nlst_rt(did)%nsoil + if( n .lt. 10) then + write(tmpStr, '(i1)') n + else + write(tmpStr, '(i2)') n + endif + iret = nf_def_var(ncid,"sh2owgt"//trim(tmpStr),NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + end do + iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"RETDEPRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + + + + + + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + iret = nf_def_var(ncid,"hlink",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"qlink1",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"qlink2",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"cvol",NF_FLOAT,1,(/dimid_links/),varid) + if(rt_domain(did)%nlakes .gt. 0) then + iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_lakes/),varid) + iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_lakes/),varid) + endif + iret = nf_def_var(ncid,"lake_inflort",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + iret = nf_def_var(ncid,"accLndRunOff",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"accQLateral",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"accStrmvolrt",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"accBucket",NF_FLOAT,1,(/dimid_links/),varid) + endif + end if + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then + + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_links/),varid) + else + iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) + endif + +!yw test bucket model +! iret = nf_def_var(ncid,"gwbas_pix_ct",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"gw_buck_exp",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"z_max",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"gw_buck_coeff",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"qin_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"qinflowbase",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) +! iret = nf_def_var(ncid,"qout_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) + end if + if(nlst_rt(did)%gwBaseSwCRT .eq. 3)then + iret = nf_def_var(ncid,"HEAD",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + end if + end if + +! put global attribute + iret = nf_put_att_int(ncid,NF_GLOBAL,"his_out_counts",NF_INT, 1,rt_domain(did)%his_out_counts) + iret = nf_put_att_text(ncid,NF_GLOBAL,"Restart_Time",19,nlst_rt(did)%olddate(1:19)) + iret = nf_put_att_text(ncid,NF_GLOBAL,"Since_Date",19,nlst_rt(did)%sincedate(1:19)) + iret = nf_put_att_real(ncid,NF_GLOBAL,"DTCT",NF_REAL, 1,nlst_rt(did)%DTCT) + iret = nf_enddef(ncid) + +#ifdef MPP_LAND + endif +#endif + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") + + + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt" ) + + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT, "QBDRYRT" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT, "SFCHEADSUBRT" ) + call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT, "RETDEPRT" ) + +!yw test + + +!yw test + + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + if(nlst_rt(did)%channel_option .eq. 3) then + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + else + call w_rst_crt_reach(ncid,rt_domain(did)%HLINK, "hlink" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl& +#endif + ) + endif + + if(nlst_rt(did)%channel_option .eq. 3) then + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + else + call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,1), "qlink1" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + endif + + + + if(nlst_rt(did)%channel_option .eq. 3) then + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + else + call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,2), "qlink2" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + call w_rst_crt_reach(ncid,rt_domain(did)%accLndRunOff, "accLndRunOff" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + call w_rst_crt_reach(ncid,rt_domain(did)%accQLateral, "accQLateral" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + call w_rst_crt_reach(ncid,rt_domain(did)%accStrmvolrt, "accStrmvolrt" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + call w_rst_crt_reach(ncid,rt_domain(did)%accBucket, "accBucket" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + endif ! end if of UDMP_OPT .eq. 1 + endif + + + + + if(nlst_rt(did)%channel_option .eq. 3) then + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + else + call w_rst_crt_reach(ncid,rt_domain(did)%cvol, "cvol" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + endif + + +! call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" & +!#ifdef MPP_LAND +! ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +!#endif +! ) + + + call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" & +#ifdef MPP_LAND + ,rt_domain(did)%lake_index & +#endif + ) + + call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" & +#ifdef MPP_LAND + ,rt_domain(did)%lake_index & +#endif + ) + + + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") + + end if + + + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + + call w_rst_crt_reach(ncid,rt_domain(did)%z_gwsubbas, "z_gwsubbas" & +#ifdef MPP_LAND + ,rt_domain(did)%gnlinksl & +#endif + ) + else + call w_rst_gwbucket_real(ncid,rt_domain(did)%numbasns,rt_domain(did)%gnumbasns, & + rt_domain(did)%basnsInd, rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) + endif +!yw test bucket model +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" ) +! call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase") +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" ) + end if + if(nlst_rt(did)%GWBASESWCRT.EQ.3) then + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho, "HEAD" ) + end if + end if + +#ifdef MPP_LAND + if(IO_id.eq.my_id) & +#endif + iret = nf_close(ncid) + + return + end subroutine RESTART_OUT_nc + +#ifdef MPP_LAND + + subroutine RESTART_OUT_bi(outFile,did) + + + implicit none + + integer did + + character(len=*) outFile + + integer :: iunit + integer :: i0,ie, i, istep, mkdirStatus + + + call mpp_land_sync() + + iunit = 81 + istep = 64 + i0 = 0 + ie = istep + do i = 0, numprocs,istep + if(my_id .ge. i0 .and. my_id .lt. ie) then + open(iunit, file = "restart/"//trim(outFile), form="unformatted",ERR=101, access="sequential") + write(iunit,ERR=101) rt_domain(did)%his_out_counts +! write(iunit,ERR=101) nlst_rt(did)%olddate(1:19) + write(iunit,ERR=101) nlst_rt(did)%sincedate(1:19) +! write(iunit,ERR=101) nlst_rt(did)%DTCT + write(iunit,ERR=101) rt_domain(did)%stc + write(iunit,ERR=101) rt_domain(did)%smc + write(iunit,ERR=101) rt_domain(did)%sh2ox + write(iunit,ERR=101) rt_domain(did)%SMCMAX1 + write(iunit,ERR=101) rt_domain(did)%SMCREF1 + write(iunit,ERR=101) rt_domain(did)%SMCWLT1 + write(iunit,ERR=101) rt_domain(did)%INFXSRT + write(iunit,ERR=101) rt_domain(did)%soldrain + write(iunit,ERR=101) rt_domain(did)%sfcheadrt + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + write(iunit,ERR=101) rt_domain(did)%HLINK + write(iunit,ERR=101) rt_domain(did)%QLINK(:,1) + write(iunit,ERR=101) rt_domain(did)%QLINK(:,2) + write(iunit,ERR=101) rt_domain(did)%cvol + write(iunit,ERR=101) rt_domain(did)%resht + write(iunit,ERR=101) rt_domain(did)%qlakeo + write(iunit,ERR=101) rt_domain(did)%LAKE_INFLORT + end if + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then + write(iunit,ERR=101) rt_domain(did)%z_gwsubbas + end if + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1) then + write(iunit,ERR=101) rt_domain(did)%QBDRYRT + write(iunit,ERR=101) rt_domain(did)%INFXSWGT + write(iunit,ERR=101) rt_domain(did)%SFCHEADSUBRT + write(iunit,ERR=101) rt_domain(did)%SH2OWGT + write(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT + write(iunit,ERR=101) rt_domain(did)%RETDEPRT + endif + end if + + close(iunit) + endif + call mpp_land_sync() + i0 = i0 + istep + ie = ie + istep + end do ! end do of i loop + + return +101 continue + call hydro_stop("FATAL ERROR: failed to output the hydro restart file.") + end subroutine RESTART_OUT_bi + + subroutine RESTART_in_bi(inFileTmp,did) + + + implicit none + + integer did + + character(len=*) inFileTmp + character(len=256) inFile + character(len=19) str_tmp + + integer :: iunit + logical :: fexist + integer :: i0,ie, i, istep + + iunit = 81 + + if(my_id .lt. 10) then + write(str_tmp,'(I1)') my_id + else if(my_id .lt. 100) then + write(str_tmp,'(I2)') my_id + else if(my_id .lt. 1000) then + write(str_tmp,'(I3)') my_id + else if(my_id .lt. 10000) then + write(str_tmp,'(I4)') my_id + else if(my_id .lt. 100000) then + write(str_tmp,'(I5)') my_id + endif + + inFile = trim(inFileTmp)//"."//str_tmp + + inquire (file=trim(inFile), exist=fexist) + if(.not. fexist) then + call hydro_stop("In RESTART_in_bi()- Could not find restart file "//trim(inFile)) + endif + + istep = 64 + i0 = 0 + ie = istep + do i = 0, numprocs,istep + if(my_id .ge. i0 .and. my_id .lt. ie) then + open(iunit, file = inFile, form="unformatted",ERR=101,access="sequential") + read(iunit,ERR=101) rt_domain(did)%his_out_counts +! read(iunit,ERR=101) nlst_rt(did)%olddate(1:19) + read(iunit,ERR=101) nlst_rt(did)%sincedate(1:19) +! read(iunit,ERR=101) nlst_rt(did)%DTCT + read(iunit,ERR=101) rt_domain(did)%stc + read(iunit,ERR=101) rt_domain(did)%smc + read(iunit,ERR=101) rt_domain(did)%sh2ox + read(iunit,ERR=101) rt_domain(did)%SMCMAX1 + read(iunit,ERR=101) rt_domain(did)%SMCREF1 + read(iunit,ERR=101) rt_domain(did)%SMCWLT1 + read(iunit,ERR=101) rt_domain(did)%INFXSRT + read(iunit,ERR=101) rt_domain(did)%soldrain + read(iunit,ERR=101) rt_domain(did)%sfcheadrt + if(nlst_rt(did)%SUBRTSWCRT.EQ.0.and.nlst_rt(did)%OVRTSWCRT.EQ.0) rt_domain(did)%sfcheadrt = 0 + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + read(iunit,ERR=101) rt_domain(did)%HLINK + read(iunit,ERR=101) rt_domain(did)%QLINK(:,1) + read(iunit,ERR=101) rt_domain(did)%QLINK(:,2) + read(iunit,ERR=101) rt_domain(did)%cvol + read(iunit,ERR=101) rt_domain(did)%resht + read(iunit,ERR=101) rt_domain(did)%qlakeo + read(iunit,ERR=101) rt_domain(did)%LAKE_INFLORT + end if + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then + read(iunit,ERR=101) rt_domain(did)%z_gwsubbas + end if + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1) then + read(iunit,ERR=101) rt_domain(did)%QBDRYRT + read(iunit,ERR=101) rt_domain(did)%INFXSWGT + read(iunit,ERR=101) rt_domain(did)%SFCHEADSUBRT + read(iunit,ERR=101) rt_domain(did)%SH2OWGT + read(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT + !read(iunit,ERR=101) rt_domain(did)%RETDEPRT + endif + end if + + close(iunit) + endif + call mpp_land_sync() + i0 = i0 + istep + ie = ie + istep + end do ! end do of i loop + + return +101 continue + call hydro_stop("In RESTART_in_bi() - failed to read the hydro restart file "//trim(inFile)) + end subroutine RESTART_in_bi +#endif + + subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) + implicit none + integer:: ncid,ix,jx,varid , iret + character(len=*) varName + real, dimension(ix,jx):: inVar +#ifdef MPP_LAND + real, allocatable, dimension(:,:) :: varTmp + if(my_id .eq. io_id ) then + allocate(varTmp(global_rt_nx, global_rt_ny)) + else + allocate(varTmp(1,1)) + endif + call write_IO_rt_real(inVar,varTmp) + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp) + endif + if(allocated(varTmp)) deallocate(varTmp) +#else + iret = nf_inq_varid(ncid,varName, varid) + if(iret .eq. 0) then + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar) + else + write(6,*) "Error : variable not defined in rst file before write: ", varName + endif +#endif + + return + end subroutine w_rst_rt_nc2 + + subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) + implicit none + integer:: ncid,ix,jx,varid , iret, nsoil + character(len=*) varName + real,dimension(ix,jx,nsoil):: inVar + character(len=2) tmpStr + integer k +#ifdef MPP_LAND + real varTmp(global_rt_nx,global_rt_ny) + do k = 1, nsoil + call write_IO_rt_real(inVar(:,:,k),varTmp(:,:)) + if(my_id .eq. IO_id) then + if( k .lt. 10) then + write(tmpStr, '(i1)') k + else + write(tmpStr, '(i2)') k + endif + iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp) + endif + end do +#else + do k = 1, nsoil + if( k .lt. 10) then + write(tmpStr, '(i1)') k + else + write(tmpStr, '(i2)') k + endif + iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/),(/ix,jx/),inVar(:,:,k)) + end do +#endif + return + end subroutine w_rst_rt_nc3 + + subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) + implicit none + integer:: ncid,ix,jx,varid , iret + character(len=*) varName + real inVar(ix,jx) + +#ifdef MPP_LAND + real varTmp(global_nx,global_ny) + call write_IO_real(inVar,varTmp) + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp) + endif +#else + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),invar) +#endif + + return + end subroutine w_rst_nc2 + + subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) + implicit none + integer:: ncid,ix,jx,varid , iret, nsoil + character(len=*) varName + real inVar(ix,jx,nsoil) + integer k + character(len=2) tmpStr + +#ifdef MPP_LAND + real varTmp(global_nx,global_ny) + do k = 1, nsoil + call write_IO_real(inVar(:,:,k),varTmp(:,:)) + if(my_id .eq. IO_id) then + if( k .lt. 10) then + write(tmpStr, '(i1)') k + else + write(tmpStr, '(i2)') k + endif + iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp) + endif + end do +#else + do k = 1, nsoil + if( k .lt. 10) then + write(tmpStr, '(i1)') k + else + write(tmpStr, '(i2)') k + endif + iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar(:,:,k)) + end do +#endif + return + end subroutine w_rst_nc3 + + subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & +#ifdef MPP_LAND + ,nodelist & +#endif + ) + implicit none + integer:: ncid,n,varid , iret + character(len=*) varName + real inVar(n) +#ifdef MPP_LAND + integer:: nodelist(n) + if(n .eq. 0) return + + call write_lake_real(inVar,nodelist,n) + if(my_id .eq. IO_id) then +#endif + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#ifdef MPP_LAND + endif +#endif + return + end subroutine w_rst_crt_nc1_lake + + subroutine w_rst_crt_reach(ncid,inVar,varName & +#ifdef MPP_LAND + , gnlinksl& +#endif + ) + implicit none + integer:: ncid,varid , iret, n + character(len=*) varName + real, dimension(:) :: inVar + +#ifdef MPP_LAND + integer:: gnlinksl + real,allocatable,dimension(:) :: g_var + if(my_id .eq. io_id) then + allocate(g_var(gnlinksl)) + g_var = 0 + else + allocate(g_var(1) ) + endif + + call ReachLS_write_io(inVar, g_var) + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinksl/),g_var) + endif + if(allocated(g_var)) deallocate(g_var) +#else + n = size(inVar,1) + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#endif + return + end subroutine w_rst_crt_reach + + subroutine w_rst_crt_nc1(ncid,n,inVar,varName & +#ifdef MPP_LAND + ,map_l2g, gnlinks& +#endif + ) + implicit none + integer:: ncid,n,varid , iret + character(len=*) varName + real inVar(n) +#ifdef MPP_LAND + integer:: gnlinks, map_l2g(n) + real g_var(gnlinks) + call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var) + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinks/),g_var) +#else + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#endif +#ifdef MPP_LAND + endif +#endif + return + end subroutine w_rst_crt_nc1 + + subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) + implicit none + integer:: ncid,n,varid , iret + character(len=*) varName + real,dimension(:) :: inVar +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#ifdef MPP_LAND + endif +#endif + return + end subroutine w_rst_crt_nc1g + + subroutine w_rst_gwbucket_real(ncid,numbasns,gnumbasns, & + basnsInd, inV,vName ) + implicit none + integer :: ncid,numbasns,gnumbasns + integer, dimension(:) :: basnsInd + real, dimension(:) :: inV + character(len=*) :: vName + integer i, j, k + real, allocatable,dimension(:) :: buf +#ifdef MPP_LAND + if (my_id .eq. IO_id) then + allocate(buf(gnumbasns)) + else + allocate(buf(1)) + endif + call gw_write_io_real(numbasns,inV,basnsInd,buf) +#else + allocate(buf(gnumbasns)) + do k = 1, numbasns + buf(basnsInd(k)) = inV(k) + end do +#endif + call w_rst_crt_nc1g(ncid,gnumbasns,buf,vName) + if(allocated(buf)) deallocate(buf) + end subroutine w_rst_gwbucket_real + + subroutine read_rst_gwbucket_real(ncid,outV,numbasns,& + gnumbasns,basnsInd, vName) + implicit none + integer :: ncid,numbasns,gnumbasns + integer, dimension(:) :: basnsInd + real, dimension(:) :: outV + character(len=*) :: vName + integer i, j,k + real, dimension(gnumbasns) :: buf + call read_rst_crt_nc(ncid,buf,gnumbasns,vName) + do k = 1, numbasns + outV(k) = buf(basnsInd(k)) + end do + end subroutine read_rst_gwbucket_real + + subroutine RESTART_IN_NC(inFile,did) + + implicit none + character(len=*) inFile + integer :: ierr, iret,ncid, did + + integer :: i, j + + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif +!open a netcdf file + iret = nf_open(trim(inFile), NF_NOWRITE, ncid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then + write(*,'("Problem opening file: ''", A, "''")') & + trim(inFile) + call hydro_stop("In RESTART_IN_NC() - Problem opening file") + endif + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + iret = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) + iret = NF_GET_ATT_REAL(ncid, NF_GLOBAL, 'DTCT', nlst_rt(did)%DTCT) + iret = nf_get_att_text(ncid,NF_GLOBAL,"Since_Date",nlst_rt(did)%sincedate(1:19)) + if(iret /= 0) nlst_rt(did)%sincedate = nlst_rt(did)%startdate + if(nlst_rt(did)%DTCT .gt. 0) then + nlst_rt(did)%DTCT = min(nlst_rt(did)%DTCT, nlst_rt(did)%DTRT_CH) + else + nlst_rt(did)%DTCT = nlst_rt(did)%DTRT_CH + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(rt_domain(did)%out_counts) + call mpp_land_bcast_real1(nlst_rt(did)%DTCT) +#endif + +#ifdef HYDRO_D + write(6,*) "nlst_rt(did)%nsoil=",nlst_rt(did)%nsoil +#endif + + if(nlst_rt(did)%rst_typ .eq. 1 ) then + call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") + call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") + call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain") + endif + +!yw check + + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1") + + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT,"SFCHEADSUBRT") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT,"QBDRYRT") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt") + !call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT,"RETDEPRT") + call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt") + + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + if(nlst_rt(did)%channel_option .eq. 3) then + call read_rst_crt_stream_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + else + call read_rst_crt_reach_nc(ncid,rt_domain(did)%HLINK,"hlink",rt_domain(did)%GNLINKSL) + call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,1),"qlink1",rt_domain(did)%GNLINKSL) + call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,2),"qlink2",rt_domain(did)%GNLINKSL) + call read_rst_crt_reach_nc(ncid,rt_domain(did)%CVOL,"cvol",rt_domain(did)%GNLINKSL) + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + ! read in the statistic value + call read_rst_crt_reach_nc(ncid,rt_domain(did)%accLndRunOff,"accLndRunOff",rt_domain(did)%GNLINKSL) + call read_rst_crt_reach_nc(ncid,rt_domain(did)%accQLateral,"accQLateral",rt_domain(did)%GNLINKSL) + call read_rst_crt_reach_nc(ncid,rt_domain(did)%accStrmvolrt,"accStrmvolrt",rt_domain(did)%GNLINKSL) + call read_rst_crt_reach_nc(ncid,rt_domain(did)%accBucket,"accBucket",rt_domain(did)%GNLINKS) + endif + endif + + if(rt_domain(did)%NLAKES .gt. 0) then + call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht") + call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo") + endif + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") + + end if + + if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0 .and. rt_domain(did)%gnumbasns .gt. 0) then + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + call read_rst_crt_reach_nc(ncid,rt_domain(did)%z_gwsubbas,"z_gwsubbas",rt_domain(did)%GNLINKSL) + else + call read_rst_gwbucket_real(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,& + rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd, "z_gwsubbas") + endif + end if + if(nlst_rt(did)%GWBASESWCRT.EQ.3) then + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho,"HEAD") + end if + end if + + if(nlst_rt(did)%rstrt_swc.eq.1) then !Switch for rest of restart accum vars... +#ifdef HYDRO_D + print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc +#endif + rt_domain(did)%INFXSRT=0. + rt_domain(did)%LAKE_INFLORT=0. + rt_domain(did)%QSTRMVOLRT=0. + rt_domain(did)%accLndRunOff = 0. + rt_domain(did)%accQLateral = 0. + rt_domain(did)%accStrmvolrt = 0. + rt_domain(did)%accBucket = 0. + end if + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_close(ncid) +#ifdef HYDRO_D + write(6,*) "end of RESTART_IN" + call flush(6) +#endif + + return + end subroutine RESTART_IN_nc + + subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr) + implicit none + integer :: ix,jx,nsoil, ireg, ncid, varid, iret + real,dimension(ix,jx,nsoil) :: var + character(len=*) :: varStr + character(len=2) :: tmpStr + integer :: n + integer i +#ifdef MPP_LAND + real,dimension(global_nx,global_ny) :: xtmp +#endif + + do i = 1, nsoil +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + if( i .lt. 10) then + write(tmpStr, '(i1)') i + else + write(tmpStr, '(i2)') i + endif + iret = nf_inq_varid(ncid, trim(varStr)//trim(tmpStr), varid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(iret) +#endif + + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr//trim(tmpStr) +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) & + iret = nf_get_var_real(ncid, varid, xtmp) + + call decompose_data_real(xtmp(:,:), var(:,:,i)) +#else + iret = nf_get_var_real(ncid, varid, var(:,:,i)) +#endif + end do + + return + end subroutine read_rst_nc3 + + subroutine read_rst_nc2(ncid,ix,jx,var,varStr) + implicit none + integer :: ix,jx,ireg, ncid, varid, iret + real,dimension(ix,jx) :: var + character(len=*) :: varStr +#ifdef MPP_LAND + real,dimension(global_nx,global_ny) :: xtmp + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) + +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) & + iret = nf_get_var_real(ncid, varid, xtmp) + + call decompose_data_real(xtmp, var) +#else + var = 0.0 + iret = nf_get_var_real(ncid, varid, var) +#endif + return + end subroutine read_rst_nc2 + + subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) + implicit none + integer :: ix,jx,nsoil, ireg, ncid, varid, iret + real,dimension(ix,jx,nsoil) :: var + character(len=*) :: varStr + character(len=2) :: tmpStr + integer i +#ifdef MPP_LAND + real,dimension(global_rt_nx,global_rt_ny) :: xtmp +#endif + do i = 1, nsoil + if( i .lt. 10) then + write(tmpStr, '(i1)') i + else + write(tmpStr, '(i2)') i + endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr)//trim(tmpStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr//trim(tmpStr) +#endif +#ifdef MPP_LAND + iret = nf_get_var_real(ncid, varid, xtmp) + call decompose_RT_real(xtmp(:,:),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx) +#else + iret = nf_get_var_real(ncid, varid, var(:,:,i)) +#endif + end do + return + end subroutine read_rst_rt_nc3 + + subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) + implicit none + integer :: ix,jx,ireg, ncid, varid, iret + real,dimension(ix,jx) :: var + character(len=*) :: varStr +#ifdef MPP_LAND + real,dimension(global_rt_nx,global_rt_ny) :: xtmp +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) & + iret = nf_get_var_real(ncid, varid, xtmp) + call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) +#else + iret = nf_get_var_real(ncid, varid, var) +#endif + return + end subroutine read_rst_rt_nc2 + + subroutine read_rt_nc2(ncid,ix,jx,var,varStr) + implicit none + integer :: ix,jx, ncid, varid, iret + real,dimension(ix,jx) :: var + character(len=*) :: varStr + +#ifdef MPP_LAND + real,allocatable, dimension(:,:) :: xtmp +!yw real,dimension(global_rt_nx,global_rt_ny) :: xtmp + if(my_id .eq. io_id ) then + allocate(xtmp(global_rt_nx,global_rt_ny)) + else + allocate(xtmp(1,1)) + endif + xtmp = 0.0 +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then + iret = nf_get_var_real(ncid, varid, xtmp) + endif + call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) + + if(allocated(xtmp)) deallocate(xtmp) + +#else + iret = nf_get_var_real(ncid, varid, var) +#endif + return + end subroutine read_rt_nc2 + + subroutine read_rst_crt_nc(ncid,var,n,varStr) + implicit none + integer :: ireg, ncid, varid, n, iret + real,dimension(n) :: var + character(len=*) :: varStr + + if( n .le. 0) return +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + iret = nf_get_var_real(ncid, varid, var) +#ifdef MPP_LAND + endif + if(n .gt. 0) then + call mpp_land_bcast_real(n,var) + endif +#endif + return + end subroutine read_rst_crt_nc + + subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) + implicit none + integer :: ncid, varid, n, iret, gnlinks + integer, intent(in), dimension(:) :: map_l2g + character(len=*) :: varStr + integer :: l, g + real,intent(out) , dimension(:) :: var_out +#ifdef MPP_LAND + real,dimension(gnlinks) :: var +#else + real,dimension(n) :: var +#endif + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + var = 0.0 + iret = nf_get_var_real(ncid, varid, var) +#ifdef MPP_LAND + endif + if(gnlinks .gt. 0) then + call mpp_land_bcast_real(gnlinks,var) + endif + + if(n .le. 0) return + var_out = 0 + + do l = 1, n + g = map_l2g(l) + var_out(l) = var(g) + end do +#else + var_out = var +#endif + return + end subroutine read_rst_crt_stream_nc + + subroutine read_rst_crt_reach_nc(ncid,var_out,varStr,gnlinksl) + implicit none + integer :: ncid, varid, n, iret, gnlinksl + character(len=*) :: varStr + integer :: l, g + real, dimension(:) :: var_out + + real,allocatable,dimension(:) :: var + + n = size(var_out,1) + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then + allocate(var(gnlinksl)) + else + allocate(var(1)) + endif +#else + allocate(var(n)) +#endif + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid, trim(varStr), varid) + endif + call mpp_land_bcast_int1(iret) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + + if(allocated(var)) deallocate(var) + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr + call flush(6) +#endif + if(my_id .eq. IO_id) then + var = 0.0 + iret = nf_get_var_real(ncid, varid, var) + endif + call ReachLS_decomp(var, var_out) + if(allocated(var)) deallocate(var) +#else + iret = nf_inq_varid(ncid, trim(varStr), varid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + if(allocated(var)) deallocate(var) + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif + iret = nf_get_var_real(ncid, varid, var_out) + if(allocated(var)) deallocate(var) +#endif + + + return + end subroutine read_rst_crt_reach_nc + + subroutine hrldas_out() + end subroutine hrldas_out + + + SUBROUTINE READ_CHROUTING1(IXRT,JXRT,fgDEM,CH_NETRT,CH_LNKRT, LAKE_MSKRT, & + FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & + NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & + LAKEIDA, HRZAREA, LAKEMAXH,WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, LAKEIDM, LAKEIDX, & + route_link_f, & + route_lake_f, route_direction_f, route_order_f, & + CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & + CHANXI, CHANYJ, CHLAT, CHLON, & + channel_option,LATVAL,LONVAL, & + STRMFRXSTPTS,geo_finegrid_flnm , NLINKSL, LINKID, GNLINKSL,UDMP_OPT & +#ifdef MPP_LAND + ,Link_Location & +#endif + ,gages, gageMiss) +#ifdef MPP_LAND + use module_mpp_land, only: my_id, io_id +#endif +#include + INTEGER, INTENT(IN) :: IXRT,JXRT, UDMP_OPT + INTEGER :: CHANRTSWCRT, NLINKS, NLAKES, NLINKSL, GNLINKSL + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: fgDEM + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION + INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT, CH_LNKRT + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk +#ifdef MPP_LAND + INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk + INTEGER :: LNLINKSL +!yw INTEGER, dimension(LNLINKSL) :: LLINKID +#endif + INTEGER :: I,J,K,channel_option + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL + CHARACTER(len=28) :: dir +!Dummy inverted grids from arc + + +!----DJG,DNY New variables for channel and lake routing + CHARACTER(len=155) :: header + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON + + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS + + INTEGER, INTENT(INOUT) :: MAXORDER + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum + REAL, INTENT(INOUT), DIMENSION(:,:) :: QLINK !channel flow + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE,LINKID ! identifies which nodes pour into which lakes + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK + REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid + REAL, DIMENSION(IXRT,JXRT) :: chanDepth, elrt + + +!-- store the location x,y location of the channel element + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ + +!--reservoir/lake attributes + REAL, INTENT(INOUT), DIMENSION(:) :: HRZAREA + INTEGER, INTENT(INOUT), DIMENSION(:) :: LAKEIDM !lake id for LAKES_Modeled in the LAKEPARM table (.nc or .tbl) + + REAL, INTENT(INOUT), DIMENSION(:) :: LAKEMAXH, WEIRH + REAL, INTENT(INOUT), DIMENSION(:) :: WEIRC + REAL, INTENT(INOUT), DIMENSION(:) :: WEIRL + REAL, INTENT(INOUT), DIMENSION(:) :: ORIFICEC + REAL, INTENT(INOUT), DIMENSION(:) :: ORIFICEA + REAL, INTENT(INOUT), DIMENSION(:) :: ORIFICEE + REAL, INTENT(INOUT), DIMENSION(:) :: LATLAKE,LONLAKE,ELEVLAKE + REAL, INTENT(INOUT), DIMENSION(:) :: ChSSlp, Bw + + INTEGER, INTENT(INOUT), DIMENSION(:) :: LAKEIDA !the COM lake id for each link on the full nlinks database + INTEGER, INTENT(INOUT), DIMENSION(:) :: LAKEIDX !the sequential index of lakes (1 to Nlakes) mapped to COMID + + INTEGER, DIMENSION(NLAKES,NLINKSL) :: tmpTO !a variable to hold hold the to of links for Lake Outlet Iding + INTEGER, DIMENSION(NLAKES) :: LAKELINKID !temporarily store the outlet index for each modeled lake + + + character(len=15), intent(inout), dimension(nlinks) :: gages !! need to respect the default values + character(len=15), intent(in) :: gageMiss + + CHARACTER(len=256) :: route_link_f + CHARACTER(len=256) :: route_lake_f + CHARACTER(len=256) :: route_direction_f + CHARACTER(len=256) :: route_order_f + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name + + INTEGER :: tmp, cnt, ncid, iret, jj,ct + INTEGER :: IOstatus, OUTLAKEID + + real :: gc,n + integer :: did + + did = 1 + +!--------------------------------------------------------- +! End Declarations +!--------------------------------------------------------- + + LAKEIDX = -999 + MAXORDER = -9999 + LAKELINKID = 0 +!initialize GSTRM + GSTRMFRXSTPTS = -9999 + +!yw initialize the array. + to_node = MAXORDER + from_node = MAXORDER +#ifdef MPP_LAND + Link_location = MAXORDER +#endif + +#ifdef HYDRO_D + print *, "reading routing initialization files..." + print *, "route direction", route_direction_f + print *, "route order", route_order_f + print *, "route linke",route_link_f + print *, "route lake",route_lake_f +#endif + +!DJG Edited code here to retrieve data from hires netcdf file.... + +!!-- read regardless; commented out on 7/21/14 + + var_name = "LATITUDE" + call nreadRT2d_real ( & + var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "LONGITUDE" + call nreadRT2d_real( & + var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "LAKEGRID" + call nreadRT2d_int(& + var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "FLOWDIRECTION" + call nreadRT2d_int(& + var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "STREAMORDER" + call nreadRT2d_int(& + var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "frxst_pts" + call nreadRT2d_int(& + var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm)) + +!!!Flip y-dimension of highres grids from exported Arc files... + + var_name = "CHAN_DEPTH" + call nreadRT2d_real( & + var_name,chanDepth,ixrt,jxrt,trim(geo_finegrid_flnm)) + + if(nlst_rt(did)%GWBASESWCRT .eq. 3) then + elrt = fgDEM - chanDepth + else + elrt = fgDEM !ywtmp + endif + + ct = 0 + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + + +!- read the grid regardless of routing method + cnt = 0 + BwG = 0.0 + ChSSlpG = 0.0 + MannNG = 0.0 + TYPEL = 0 + MannN = 0.0 + Bw = 0.0 + ChSSlp = 0.0 + + if (UDMP_OPT .eq. 1) goto 299 + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order + If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) ) then !North + if(CH_NETRT(i,j+1).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j + 1) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) ) then !North East + if(CH_NETRT(i+1,j+1).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) + CHANLEN(cnt) = dist(i,j,2) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) ) then !East + if(CH_NETRT(i+1,j).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j) + CHANLEN(cnt) = dist(i,j,3) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0) ) then !south east + if(CH_NETRT(i+1,j-1).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0) ) then !due south + if(CH_NETRT(i,j-1).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j - 1) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0) ) then !south west + if(CH_NETRT(i-1,j-1).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0) ) then !West + if(CH_NETRT(i-1,j).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) ) then !North West + if(CH_NETRT(i-1,j+1).ge.0) then +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) + CHANLEN(cnt) = dist(i,j,8) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif + endif + else +#ifdef HYDRO_D +! print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east +#endif + End If + + End If !CH_NETRT check for this node + + END DO + END DO + +#ifdef HYDRO_D + print *, "after exiting the channel, this many nodes", cnt + write(*,*) " " +#endif + + +!Find out if the boundaries are on an edge +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + + If (DIRECTION(i, j).EQ. 64) then + if( j + 1 .GT. JXRT) then !-- 64's can only flow north + goto 101 + elseif ( CH_NETRT(i,j+1) .lt. 0) then !North + goto 101 + endif + goto 102 +101 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j+1 .GT. JXRT) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i,j+1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j+1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +102 continue + + else if ( DIRECTION(i, j) .EQ. 128) then + if ((i + 1 .GT. IXRT) & !-- 128's can flow out of the North or East edge + .OR. (j + 1 .GT. JXRT)) then ! this is due north edge + goto 201 + elseif (CH_NETRT(i + 1, j + 1).lt.0) then !North East + goto 201 + endif +!#endif + goto 202 +201 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if((i+1 .GT. IXRT) .OR. (j+1 .GT. JXRT)) then ! an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i+1,j+1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i+1,j+1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,2) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point NE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +202 continue + + else if (DIRECTION(i, j) .EQ. 1) then + if(i + 1 .GT. IXRT) then !-- 1's can only flow due east + goto 301 + elseif(CH_NETRT(i + 1, j) .lt. 0) then !East + goto 301 + endif + goto 302 +301 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(i+1 .GT. IXRT) then !an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i+1,j).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i+1,j) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,3) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point E", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +302 continue + else if (DIRECTION(i, j) .EQ. 2) then + if((i + 1 .GT. IXRT) & !-- 2's can flow out of east or south edge + .OR. (j - 1 .EQ. 0)) then !-- this is the south edge + goto 401 + elseif (CH_NETRT(i + 1, j - 1) .lt.0) then !south east + goto 401 + endif + goto 402 +401 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i+1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +402 continue + + else if (DIRECTION(i, j) .EQ. 4) then + if(j - 1 .EQ. 0) then !-- 4's can only flow due south + goto 501 + elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south + goto 501 + endif + goto 502 +501 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j-1 .EQ. 0) then !- an edge + TYPEL(cnt) =1 + elseif(LAKE_MSKRT(i,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +502 continue + + else if ( DIRECTION(i, j) .EQ. 8) then + if( (i - 1 .LE. 0) & !-- 8's can flow south or west + .OR. (j - 1 .EQ. 0)) then !-- this is the south edge + goto 601 + elseif (CH_NETRT(i - 1, j - 1).lt.0) then !south west + goto 601 + endif + goto 602 +601 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +602 continue + else if (DIRECTION(i, j) .EQ. 16) then + if( i - 1 .LE.0) then !16's can only flow due west + goto 701 + elseif( CH_NETRT(i - 1, j).lt.0) then !West + goto 701 + endif + goto 702 +701 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(i-1 .EQ. 0) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +702 continue + + else if ( DIRECTION(i, j) .EQ. 32) then + if( (i - 1 .LE. 0) & !-- 32's can flow either west or north + .OR. (j + 1 .GT. JXRT)) then !-- this is the north edge + goto 801 + elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West + goto 801 + endif + goto 802 +801 continue +#ifdef MPP_LAND + cnt = CH_NETLNK(i,j) +#else + cnt = cnt + 1 +#endif + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if( (i-1 .EQ. 0) .OR. (j+1 .GT. JXRT)) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j+1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j+1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,8) + CHANXI(cnt) = i + CHANYJ(cnt) = j +#ifdef MPP_LAND + Link_Location(i,j) = cnt +#endif +#ifdef HYDRO_D +! print *, "Pour Point NW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +802 continue + endif + endif !CH_NETRT check for this node + END DO + END DO + +#ifdef MPP_LAND +#ifdef HYDRO_D + print*, "my_id=",my_id, "cnt = ", cnt +#endif +#endif + +#ifdef MPP_LAND + Link_location = CH_NETLNK + call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,TYPEL,NLINKS,99) +#endif + +! jump to here if UDMP_OPT .eq. 1 +299 continue + +!---- read in link routing data if not routing on grid, but on link network + IF (channel_option .eq. 3) THEN + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + if (NLAKES.gt.0) then !read in only if there are lakes + open(unit=79,file='LAKEPARM.TBL', form='formatted',status='old') + write(6,*) "before read(79) header for LAKEPARM.TBL" + call flush(6) + read(79,*) header !-- read the lake file + endif + + do i=1, NLAKES + read (79,*,err=5101) tmp, HRZAREA(i),LAKEMAXH(i), & + WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& + LATLAKE(i), LONLAKE(i),ELEVLAKE(i), WEIRH(i) + enddo +5101 continue + close(79) +#ifdef MPP_LAND + endif + + if(NLAKES .gt. 0) then + call mpp_land_bcast_real(NLAKES,HRZAREA) + call mpp_land_bcast_real(NLAKES,LAKEMAXH) + call mpp_land_bcast_real(NLAKES,WEIRH ) + call mpp_land_bcast_real(NLAKES,WEIRC ) + call mpp_land_bcast_real(NLAKES,WEIRL ) + call mpp_land_bcast_real(NLAKES,ORIFICEC) + call mpp_land_bcast_real(NLAKES,ORIFICEA) + call mpp_land_bcast_real(NLAKES,ORIFICEE) + call mpp_land_bcast_real(NLAKES,LATLAKE ) + call mpp_land_bcast_real(NLAKES,LONLAKE ) + call mpp_land_bcast_real(NLAKES,ELEVLAKE) + endif +#endif + +!!-- if routing on link network, read those data too + ELSEIF ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file ? do we need the channel switch? + + call readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f,maxorder, & + LINKID, TO_NODE, TYPEL, ORDER , & + QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, & + MannN, So, ChSSlp, Bw, LAKEIDA, HRZAREA, & + LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, & + ORIFICEA, ORIFICEE, gages, gageMiss, & + LAKEIDM,NLAKES, latlake, lonlake) + +!--- get the lake configuration here. +#ifdef MPP_LAND + call nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA, GNLINKSL) +! call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA) +#else + call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA) +#endif + + +#ifdef MPP_LAND + if(NLAKES .gt. 0) then +! call mpp_land_bcast_int(NLINKSL,LAKEIDA) +! call mpp_land_bcast_int(NLINKSL,LAKEIDX) + + call mpp_land_bcast_real(NLAKES,HRZAREA) + call mpp_land_bcast_int(NLAKES,LAKEIDM) + call mpp_land_bcast_real(NLAKES,LAKEMAXH) + call mpp_land_bcast_real(NLAKES,WEIRH ) + call mpp_land_bcast_real(NLAKES,WEIRC ) + call mpp_land_bcast_real(NLAKES,WEIRL ) + call mpp_land_bcast_real(NLAKES,ORIFICEC) + call mpp_land_bcast_real(NLAKES,ORIFICEA) + call mpp_land_bcast_real(NLAKES,ORIFICEE) + call mpp_land_bcast_real(NLAKES,LATLAKE ) + call mpp_land_bcast_real(NLAKES,LONLAKE ) + call mpp_land_bcast_real(NLAKES,ELEVLAKE) + endif +#endif + + ENDIF !channel option is 1 or 2 (linked routing) + + RETURN !from READ_CHROUTING1 + +!DJG ----------------------------------------------------- + END SUBROUTINE READ_CHROUTING1 + + subroutine readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f, maxorder, & + LINKID, TO_NODE, TYPEL, ORDER , & + QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, & + MannN, So, ChSSlp, Bw, LAKEIDA, HRZAREA, & + LAKEMAXH,WEIRH, WEIRC, WEIRL, ORIFICEC, & + ORIFICEA, ORIFICEE, gages, gageMiss,& + LAKEIDM,NLAKES, latlake, lonlake) + + implicit none + character(len=*) :: route_link_f,route_lake_f + integer :: GNLINKSL, NLINKSL, tmp_from_node,NLAKES + + INTEGER, INTENT(INOUT) :: MAXORDER + INTEGER, intent(out), dimension(:) :: LAKEIDA, LINKID, TO_NODE, TYPEL, ORDER + + real,dimension(:,:) :: QLINK + REAL, intent(out), dimension(:) :: CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, & + MannN, So, ChSSlp, Bw, latlake, lonlake + + character(len=15), dimension(:), intent(inout) :: gages + character(len=15), intent(in) :: gageMiss + +!NLAKES + INTEGER, intent(out), dimension(:) :: LAKEIDM + REAL, intent(out), dimension(:) :: HRZAREA,LAKEMAXH, WEIRC, WEIRL, ORIFICEC,WEIRH, & + ORIFICEA, ORIFICEE +!end NLAKES + + INTEGER, dimension(GNLINKSL) :: tmpLAKEIDA, tmpLINKID, tmpTO_NODE, tmpTYPEL, tmpORDER + character(len=15), dimension(gnlinksl) :: tmpGages + CHARACTER(len=155) :: header + integer :: i + + character(len=256) :: route_link_f_r,route_lake_f_r + integer :: lenRouteLinkFR,lenRouteLakeFR ! so the preceeding chan be changed without changing code + logical :: routeLinkNetcdf, routeLakeNetcdf + +#ifdef MPP_LAND + real :: tmpQLINK(GNLINKSL,2) + REAL, allocatable, dimension(:) :: tmpCHLON, tmpCHLAT, tmpZELEV, tmpMUSK, tmpMUSX, tmpCHANLEN, & + tmpMannN, tmpSo, tmpChSSlp, tmpBw +#endif + + !! is RouteLink file netcdf (*.nc) or csv (*.csv) + route_link_f_r = adjustr(route_link_f) + lenRouteLinkFR = len(route_link_f_r) + routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq. '.nc' + + !! is RouteLake file netcdf (*.nc) or .TBL + route_lake_f_r = adjustr(route_lake_f) + lenRouteLakeFR = len(route_lake_f_r) + routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc' + +#ifdef MPP_LAND + tmpQLINK = 0 + tmpGages = gageMiss + + if(my_id .eq. IO_id) then + + allocate(tmpCHLON(GNLINKSL)) + allocate(tmpCHLAT(GNLINKSL)) + allocate(tmpZELEV(GNLINKSL)) + allocate(tmpMUSK(GNLINKSL)) + allocate(tmpMUSX(GNLINKSL)) + allocate(tmpCHANLEN(GNLINKSL)) + allocate(tmpMannN(GNLINKSL)) + allocate(tmpSo(GNLINKSL)) + allocate(tmpChSSlp(GNLINKSL)) + allocate(tmpBw(GNLINKSL)) + + if(routeLinkNetcdf) then + + call read_route_link_netcdf( & + route_link_f, & + tmpLINKID, tmpTO_NODE, tmpCHLON, & + tmpCHLAT, tmpZELEV, tmpTYPEL, tmpORDER, & + tmpQLINK(:,1), tmpMUSK, tmpMUSX, tmpCHANLEN, & + tmpMannN, tmpSo, tmpChSSlp, tmpBw, & + tmpGages, tmpLAKEIDA) + + else + + open(unit=17,file=trim(route_link_f),form='formatted',status='old') + read(17,*) header +#ifdef HYDRO_D + print *, "header ", header, "NLINKSL = ", NLINKSL, GNLINKSL +#endif + call flush(6) + do i=1,GNLINKSL + read (17,*) tmpLINKID(i), tmp_from_node, tmpTO_NODE(i), tmpCHLON(i), & + tmpCHLAT(i), tmpZELEV(i), tmpTYPEL(i), tmpORDER(i), & + tmpQLINK(i,1), tmpMUSK(i), tmpMUSX(i), tmpCHANLEN(i), & + tmpMannN(i), tmpSo(i), tmpChSSlp(i), tmpBw(i) + + ! if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement + if (tmpORDER(i) .gt. MAXORDER) MAXORDER = tmpORDER(i) + end do + close(17) + + end if ! routeLinkNetcdf + + if(routeLakeNetcdf) then + call read_route_lake_netcdf(route_lake_f,HRZAREA, & + LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, & + ORIFICEA, ORIFICEE, LAKEIDM, latlake, lonlake) + endif + +!!- initialize channel if missing in input + do i=1,GNLINKSL + if(tmpQLINK(i,1) .le. 1e-3) then + tmpQLINK(i,1) = 20.0 * (1.0/(float(MAXORDER+1) - float(tmpORDER(i))))**3 + tmpQLINK(i,2) = tmpQLINK(i,1) !## initialize the current flow at each link + endif + end do + + endif ! my_id .eq. IO_id + + call ReachLS_decomp(tmpLINKID, LINKID ) + call ReachLS_decomp(tmpLAKEIDA, LAKEIDA ) + + call ReachLS_decomp(tmpTO_NODE, TO_NODE) + call ReachLS_decomp(tmpCHLON, CHLON ) + call ReachLS_decomp(tmpCHLAT, CHLAT ) + call ReachLS_decomp(tmpZELEV, ZELEV ) + call ReachLS_decomp(tmpTYPEL, TYPEL ) + call ReachLS_decomp(tmpORDER, ORDER ) + call ReachLS_decomp(tmpQLINK(:,1), QLINK(:,1)) + call ReachLS_decomp(tmpQLINK(:,2), QLINK(:,2)) + call ReachLS_decomp(tmpMUSK, MUSK ) + call ReachLS_decomp(tmpMUSX, MUSX ) + call ReachLS_decomp(tmpCHANLEN, CHANLEN) + call ReachLS_decomp(tmpMannN, MannN ) + call ReachLS_decomp(tmpSo, So ) + call ReachLS_decomp(tmpChSSlp, ChSSlp ) + call ReachLS_decomp(tmpBw, Bw ) + + +! call ReachLS_decomp(tmpHRZAREA, HRZAREA) +! call ReachLS_decomp(tmpLAKEMAXH, LAKEMAXH) +! call ReachLS_decomp(tmpWEIRC, WEIRC ) +! call ReachLS_decomp(tmpWEIRL, WEIRL ) +! call ReachLS_decomp(tmpORIFICEC, ORIFICEC) +! call ReachLS_decomp(tmpORIFICEA, ORIFICEA) +! call ReachLS_decomp(tmpORIFICEE, ORIFICEE) + +!yw This function does not work correctly for gages. +!yw call ReachLS_decomp(tmpGages, gages) + call mpp_land_bcast_int1(MAXORDER) + + if(NLAKES .gt. 0) then + call mpp_land_bcast_real(NLAKES, HRZAREA) + call mpp_land_bcast_real(NLAKES, LAKEMAXH) + call mpp_land_bcast_real(NLAKES, WEIRH) + call mpp_land_bcast_real(NLAKES, WEIRC) + call mpp_land_bcast_real(NLAKES, WEIRL) + call mpp_land_bcast_real(NLAKES, ORIFICEC) + call mpp_land_bcast_real(NLAKES, ORIFICEA) + call mpp_land_bcast_real(NLAKES, ORIFICEE) + call mpp_land_bcast_int(NLAKES, LAKEIDM) + endif + + + if(my_id .eq. io_id ) then + if(allocated(tmpCHLON)) deallocate(tmpCHLON) + if(allocated(tmpCHLAT)) deallocate(tmpCHLAT) + if(allocated(tmpZELEV)) deallocate(tmpZELEV) + if(allocated(tmpMUSK)) deallocate(tmpMUSK) + if(allocated(tmpMUSX)) deallocate(tmpMUSX) + if(allocated(tmpCHANLEN)) deallocate(tmpCHANLEN) + if(allocated(tmpMannN)) deallocate(tmpMannN) + if(allocated(tmpSo)) deallocate(tmpSo) + if(allocated(tmpChSSlp)) deallocate(tmpChSSlp) + if(allocated(tmpBw)) deallocate(tmpBw) +!, tmpHRZAREA,& +! tmpLAKEMAXH, tmpWEIRC, tmpWEIRL, tmpORIFICEC, & +! tmpORIFICEA,tmpORIFICEE) + endif + +#else + QLINK = 0 + if(routeLinkNetcdf) then + + call read_route_link_netcdf( & + route_link_f, & + LINKID, TO_NODE, CHLON, & + CHLAT, ZELEV, TYPEL, ORDER, & + QLINK(:,1), MUSK, MUSX, CHANLEN, & + MannN, So, ChSSlp, Bw, & + gages, LAKEIDA) + + else + + open(unit=17,file=trim(route_link_f),form='formatted',status='old') + read(17,*) header +#ifdef HYDRO_D + print *, "header ", header, "NLINKSL = ", NLINKSL +#endif + do i=1,NLINKSL + read (17,*) LINKID(i), tmp_from_node, TO_NODE(i), CHLON(i),CHLAT(i),ZELEV(i), & + TYPEL(i), ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & + MannN(i), So(i), ChSSlp(i), Bw(i) + + ! if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement + if (ORDER(i) .gt. MAXORDER) MAXORDER = ORDER(i) + end do + close(17) + + end if ! routeLinkNetcdf + +!!- initialize channel according to order if missing in input + do i=1,NLINKSL + if(QLINK(i,1) .le. 1e-3) then + QLINK(i,1) = 20.0 * (1/(float(MAXORDER+1) - float(ORDER(i))))**3 + QLINK(i,2) = QLINK(i,1) !## initialize the current flow at each link + endif + end do + +!!================================ +!!! need to add the sequential lake read here +!!================================= + + +#endif + + do i=1,NLINKSL +! if(So(i) .lt. 0.001) So(i) = 0.001 + So(i) = max(So(i), 0.00001) + end do + +#ifdef HYDRO_D + write(6,*) "finish read readLinkSL " + call flush(6) + +#endif + end subroutine readLinkSL + + + + +#ifdef MPP_LAND + +!yw continue + + SUBROUTINE MPP_READ_CHROUTING_new(IXRT,JXRT,ELRT,CH_NETRT, CH_LNKRT,LAKE_MSKRT, & + FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & + NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & + LAKEIDA,HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, LAKEIDM, LAKEIDX, & + route_link_f, & + route_lake_f, route_direction_f, route_order_f, & + CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & + CHANXI, CHANYJ, CHLAT, CHLON, & + channel_option,LATVAL,& + LONVAL,STRMFRXSTPTS,geo_finegrid_flnm,NLINKSL, LINKID, GNLINKSL,UDMP_OPT,g_ixrt,g_jxrt, & + gnlinks,GCH_NETLNK, map_l2g, link_location,yw_mpp_nlinks, & + lake_index, nlinks_index, gages, gageMiss) + implicit none + INTEGER, INTENT(IN) :: IXRT,JXRT,g_IXRT,g_JXRT, GNLINKS, UDMP_OPT + INTEGER :: CHANRTSWCRT, NLINKS, NLAKES, NLINKSL + INTEGER :: I,J,channel_option + CHARACTER(len=28) :: dir + +!----DJG,DNY New variables for channel and lake routing + CHARACTER(len=155) :: header + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON + + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKEIDA !identifies which links in the domain are id'd as lakes + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKEIDX ! the integer lake id. + + INTEGER, INTENT(INOUT) :: MAXORDER + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum + REAL, INTENT(INOUT), DIMENSION(:,:) :: QLINK !channel flow + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE,LINKID ! identifies which nodes pour into which lakes + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: map_l2g + +!-- store the location x,y location of the channel element + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ + +!--reservoir/lake attributes + INTEGER, INTENT(INOUT), DIMENSION(NLAKES) :: LAKEIDM + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: HRZAREA + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LAKEMAXH, WEIRH + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRC + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRL + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEC + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEA + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEE + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ChSSlp, Bw + character(len=15), intent(inout), dimension(nlinks) :: gages + character(len=15), intent(in) :: gageMiss + + CHARACTER(len=256) :: route_link_f + CHARACTER(len=256) :: route_lake_f + CHARACTER(len=256) :: route_direction_f + CHARACTER(len=256) :: route_order_f + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name + + INTEGER :: tmp, cnt, ncid + real :: gc,n + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK,GCH_NETLNK + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT, CH_LNKRT + INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT, link_location + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: latval,lonval + integer :: k + INTEGER, DIMENSION(nlinks) :: node_table, nlinks_index + INTEGER, DIMENSION(nlakes) :: lake_index + integer :: yw_mpp_nlinks , l, mpp_nlinks, GNLINKSL + + + + call READ_CHROUTING1(IXRT,JXRT,ELRT,CH_NETRT, CH_LNKRT, LAKE_MSKRT, & + FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & + NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & + LAKEIDA,HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, LAKEIDM, LAKEIDX, & + route_link_f, & + route_lake_f, route_direction_f, route_order_f, & + CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & + CHANXI, CHANYJ, CHLAT, CHLON, & + channel_option,LATVAL,LONVAL, & + STRMFRXSTPTS,geo_finegrid_flnm , NLINKSL, LINKID, GNLINKSL,UDMP_OPT & +#ifdef MPP_LAND + ,Link_Location & +#endif + ,gages, gageMiss) + + call mpp_land_max_int1(MAXORDER) + + if(MAXORDER .eq. 0) MAXORDER = -9999 + + lake_index = -99 + if(channel_option .eq. 3) then + do j = 1, jxrt + do i = 1, ixrt + if (LAKE_MSKRT(i,j) .gt. 0) then + lake_index(LAKE_MSKRT(i,j)) = LAKE_MSKRT(i,j) + endif + enddo + enddo + endif + + + CHANXI = 0 + CHANYj = 0 + do j = 1, jxrt + do i = 1, ixrt + if(CH_NETLNK(i,j) .gt. 0) then + CHANXI(CH_NETLNK(i,j)) = i + CHANYJ(CH_NETLNK(i,j)) = j + endif + end do + end do + + node_table = 0 + yw_mpp_nlinks = 0 + do j = 1, jxrt + do i = 1, ixrt + if(CH_NETLNK(i,j) .ge. 0) then + if( (i.eq.1) .and. (left_id .ge. 0) ) then + continue + elseif ( (i.eq. ixrt) .and. (right_id .ge. 0) ) then + continue + elseif ( (j.eq. 1) .and. (down_id .ge. 0) ) then + continue + elseif ( (j.eq. jxrt) .and. (up_id .ge. 0) ) then + continue + else + l = CH_NETLNK(i,j) + ! if(from_node(l) .gt. 0 .and. to_node(l) .gt. 0) then + yw_mpp_nlinks = yw_mpp_nlinks + 1 + nlinks_index(yw_mpp_nlinks) = l + ! endif + endif + endif + end do + end do + +#ifdef HYDRO_D + write(6,*) "nlinks=", nlinks, " yw_mpp_nlinks=", yw_mpp_nlinks," nlakes=", nlakes + call flush(6) +#endif + if(NLAKES .gt. 0) then + call mpp_land_bcast_real(NLAKES,HRZAREA) + call mpp_land_bcast_real(NLAKES,LAKEMAXH) + call mpp_land_bcast_real(NLAKES,WEIRC) + call mpp_land_bcast_real(NLAKES,WEIRC) + call mpp_land_bcast_real(NLAKES,WEIRL) + call mpp_land_bcast_real(NLAKES,ORIFICEC) + call mpp_land_bcast_real(NLAKES,ORIFICEA) + call mpp_land_bcast_real(NLAKES,ORIFICEE) + call mpp_land_bcast_real(NLAKES,LATLAKE) + call mpp_land_bcast_real(NLAKES,LONLAKE) + call mpp_land_bcast_real(NLAKES,ELEVLAKE) + endif + + + link_location = CH_NETLNK + + return + + end SUBROUTINE MPP_READ_CHROUTING_new + +#endif + + +#ifdef MPP_LAND + subroutine out_day_crt(dayMean,outFile) + implicit none + integer :: did + real :: dayMean(:) + character(len=*) :: outFile + integer:: ywflag + ywflag = -999 + did = 1 + if((nlst_rt(did)%olddate(12:13) .eq. "00") .and. (nlst_rt(did)%olddate(15:16) .eq. "00") ) ywflag = 99 + call mpp_land_bcast_int1(ywflag) + if(ywflag <0) return + ! output daily + call out_obs_crt(did,dayMean,outFile) + end subroutine out_day_crt + + subroutine out_obs_crt(did,dayMean,outFile) + implicit none + integer did, i, cnt + real :: dayMean(:) + character(len=*) :: outFile + real,dimension(rt_domain(did)%gnlinks) :: g_dayMean, chlat, chlon + integer,dimension(rt_domain(did)%gnlinks) :: STRMFRXSTPTS + + g_dayMean = -999 + chlat = -999 + chlon = -999 + STRMFRXSTPTS = 0 + + call write_chanel_int(RT_DOMAIN(did)%STRMFRXSTPTS,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,STRMFRXSTPTS) + + call write_chanel_real(dayMean,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,g_dayMean) + + call write_chanel_real(RT_DOMAIN(did)%CHLON,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlon) + + call write_chanel_real(RT_DOMAIN(did)%CHLAT,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlat) + + + open (unit=75,file=outFile,status='unknown',position='append') + cnt = 0 + do i = 1, rt_domain(did)%gnlinks + if(STRMFRXSTPTS(i) .gt. 0) then + write(75,114) nlst_rt(did)%olddate(1:4),nlst_rt(did)%olddate(6:7),nlst_rt(did)%olddate(9:10), nlst_rt(did)%olddate(12:13), & + cnt,chlon(i),chlat(i),g_dayMean(i) + cnt = cnt + 1 + endif + end do + close(75) +114 FORMAT(1x,A4,A2,A2,A2,",",I7,", ",F10.5,",",F10.5,",",F12.3) + end subroutine out_obs_crt +#endif + + subroutine outPutChanInfo(fromNode,toNode,chlon,chlat) + implicit none + integer, dimension(:) :: fromNode,toNode + real, dimension(:) :: chlat,chlon + integer :: iret, nodes, i, ncid, dimid_n, varid + + nodes = size(chlon,1) +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create("nodeInfor.nc", NF_CLOBBER, ncid) +#else + iret = nf_create("nodeInfor.nc", IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + iret = nf_def_dim(ncid, "node", nodes, dimid_n) !-- make a decimated grid +! define the varialbes + iret = nf_def_var(ncid,"fromNode",NF_INT,1,(/dimid_n/),varid) + iret = nf_def_var(ncid,"toNode",NF_INT,1,(/dimid_n/),varid) + iret = nf_def_var(ncid,"chlat",NF_FLOAT,1,(/dimid_n/),varid) + iret = nf_put_att_text(ncid,varid,'long_name',13,'node latitude') + iret = nf_def_var(ncid,"chlon",NF_FLOAT,1,(/dimid_n/),varid) + iret = nf_put_att_text(ncid,varid,'long_name',14,'node longitude') + iret = nf_enddef(ncid) +!write to the file + iret = nf_inq_varid(ncid,"fromNode", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nodes/), fromNode) + iret = nf_inq_varid(ncid,"toNode", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nodes/), toNode) + iret = nf_inq_varid(ncid,"chlat", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nodes/), chlat) + iret = nf_inq_varid(ncid,"chlon", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nodes/), chlon) + iret = nf_close(ncid) + end subroutine outPutChanInfo + + +!=================================================================================================== +! Program Name: read_route_link_netcdf +! Author(s)/Contact(s): James L McCreight +! Abstract: Read in the "RouteLink.nc" netcdf file specifing the channel topology. +! History Log: +! 7/17/15 -Created, JLM. +! Usage: +! Parameters: +! Input Files: netcdf file RouteLink.nc or other name. +! Output Files: None. +! Condition codes: Currently incomplete error handling. +! +! If appropriate, descriptive troubleshooting instructions or +! likely causes for failures could be mentioned here with the +! appropriate error code +! +! User controllable options: None. + +subroutine read_route_link_netcdf( route_link_file, & + LINKID, TO_NODE, CHLON, & + CHLAT, ZELEV, TYPEL, ORDER, & + QLINK, MUSK, MUSX, CHANLEN, & + MannN, So, ChSSlp, Bw, & + gages, LAKEIDA ) + +implicit none +character(len=*), intent(in) :: route_link_file +integer, dimension(:), intent(out) :: LAKEIDA, LINKID, TO_NODE +real, dimension(:), intent(out) :: CHLON, CHLAT, ZELEV +integer, dimension(:), intent(out) :: TYPEL, ORDER +real, dimension(:), intent(out) :: QLINK +real, dimension(:), intent(out) :: MUSK, MUSX, CHANLEN +real, dimension(:), intent(out) :: MannN, So, ChSSlp, Bw +character(len=15), dimension(:), intent(inout) :: gages + +integer :: iRet, ncid, ii, varid +logical :: fatal_if_error +fatal_if_error = .TRUE. !! was thinking this would be a global variable...could become an input. + +#ifdef HYDRO_D +print*,"start read_route_link_netcdf" +#endif + +iRet = nf90_open(trim(route_link_file), nf90_nowrite, ncid) +if (iRet /= nf90_noErr) then + write(*,'("read_route_link_netcdf: Problem opening: ''", A, "''")') trim(route_link_file) + if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem opening file.") +endif + + +call get_1d_netcdf_int(ncid, 'link', LINKID, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_int(ncid, 'NHDWaterbodyComID', LAKEIDA, 'read_route_link_netcdf', .FALSE.) +call get_1d_netcdf_int(ncid, 'to', TO_NODE, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'lon', CHLON, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'lat', CHLAT, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'alt', ZELEV, 'read_route_link_netcdf', .TRUE.) +!yw call get_1d_netcdf_int(ncid, 'type', TYPEL, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_int(ncid, 'order', ORDER, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'Qi', QLINK, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'MusK', MUSK, 'read_route_link_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'MusX', MUSX, 'read_route_link_netcdf', .TRUE.) +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. +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.) + +! gages is optional, only get it if it's defined in the file. +iRet = nf90_inq_varid(ncid, 'gages', varid) +if (iret .eq. nf90_NoErr) then + call get_1d_netcdf_text(ncid, 'gages', gages, 'read_route_link_netcdf', .true.) +end if + +iRet = nf90_close(ncId) +if (iRet /= nf90_noErr) then + write(*,'("read_route_link_netcdf: Problem closing: ''", A, "''")') trim(route_link_file) + if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem closing file.") +end if + +#ifdef HYDRO_D +ii = size(LINKID) +print*,'last index=',ii +print*, 'CHLON', CHLON(ii), 'CHLAT', CHLAT(ii), 'ZELEV', ZELEV(ii) +print*,'TYPEL', TYPEL(ii), 'ORDER', ORDER(ii), 'QLINK', QLINK(ii), 'MUSK', MUSK(ii) +print*, 'MUSX', MUSX(ii), 'CHANLEN', CHANLEN(ii), 'MannN', MannN(ii) +print*,'So', So(ii), 'ChSSlp', ChSSlp(ii), 'Bw', Bw(ii) +print*,'gages(ii): ',trim(gages(ii)) +print*,"finish read_route_link_netcdf" +#endif + +end subroutine read_route_link_netcdf + + +!=================================================================================================== +! Program Name: read_route_lake_netcdf +! Abstract: Read in the "LAKEPARM.nc" netcdf file specifing the channel topology. +! History Log: +! 7/17/15 -Created, JLM., then used by DNY +! Usage: +! Parameters: +! Input Files: netcdf file RouteLink.nc or other name. +! Output Files: None. +! Condition codes: Currently incomplete error handling. +! +subroutine read_route_lake_netcdf(route_lake_file, & + HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, & + ORIFICEC, ORIFICEA, ORIFICEE, LAKEIDM, & + lakelat, lakelon) + +implicit none +character(len=*), intent(in) :: route_lake_file +integer, dimension(:), intent(out) :: LAKEIDM +real, dimension(:), intent(out) :: HRZAREA, LAKEMAXH, WEIRC, WEIRL, WEIRH +real, dimension(:), intent(out) :: ORIFICEC, ORIFICEA, ORIFICEE, lakelat, lakelon + +integer :: iRet, ncid, ii, varid +logical :: fatal_if_error +fatal_if_error = .TRUE. !! was thinking this would be a global variable...could become an input. + +#ifdef HYDRO_D +print*,"start read_route_lake_netcdf" +#endif + +iRet = nf90_open(trim(route_lake_file), nf90_nowrite, ncid) +if (iRet /= nf90_noErr) then + write(*,'("read_route_lake_netcdf: Problem opening: ''", A, "''")') trim(route_lake_file) + if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem opening file.") +endif + +call get_1d_netcdf_int(ncid, 'lake_id', LAKEIDM, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'LkArea', HRZAREA, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'LkMxH', LAKEMAXH, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'WeirH', WEIRH, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'WeirC', WEIRC, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'WeirL', WEIRL, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'OrificeC', ORIFICEC, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'OrificeA', ORIFICEA, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'OrificeE', ORIFICEE, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'lat', lakelat, 'read_route_lake_netcdf', .TRUE.) +call get_1d_netcdf_real(ncid, 'lon', lakelon, 'read_route_lake_netcdf', .TRUE.) + +iRet = nf90_close(ncId) +if (iRet /= nf90_noErr) then + write(*,'("read_route_lake_netcdf: Problem closing: ''", A, "''")') trim(route_lake_file) + if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem closing file.") +end if + +#ifdef HYDRO_D +ii = size(LAKEIDM) +print*,'last index=',ii +print*,'HRZAREA', HRZAREA(ii) +print*,'LAKEMAXH', LAKEMAXH(ii), 'WEIRC', WEIRC(ii), 'WEIRL', WEIRL(ii) +print*,'ORIFICEC', ORIFICEC(ii), 'ORIFICEA', ORIFICEA(ii), 'ORIFICEE', ORIFICEE(ii) +print*,"finish read_route_lake_netcdf" +#endif + +end subroutine read_route_lake_netcdf + +!=================================================================================================== +! Program Names: get_1d_netcdf_real, get_1d_netcdf_int, get_1d_netcdf_text +! Author(s)/Contact(s): James L McCreight +! Abstract: Read a variable of real or integer type from an open netcdf file, respectively. +! History Log: +! 7/17/15 -Created, JLM. +! Usage: +! Parameters: See definitions. +! Input Files: This file is refered to by it's "ncid" obtained from nc_open +! prior to calling this routine. +! Output Files: None. +! Condition codes: hydro_stop is passed "get_1d_netcdf". +! +! If appropriate, descriptive troubleshooting instructions or +! likely causes for failures could be mentioned here with the +! appropriate error code +! +! User controllable options: None. + +!! could define an interface for these. +subroutine get_1d_netcdf_int(ncid, varName, var, callingRoutine, fatal_if_error) +integer, intent(in) :: ncid !! the file identifier +character(len=*), intent(in) :: varName +integer, dimension(:), intent(out) :: var +character(len=*), intent(in) :: callingRoutine +logical, intent(in) :: fatal_if_error +integer :: varid, iret +iRet = nf90_inq_varid(ncid, varName, varid) +if (iret /= nf90_noErr) then + if (fatal_IF_ERROR) then + print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName) + call hydro_stop("get_1d_netcdf") + end if +end if +iRet = nf90_get_var(ncid, varid, var) +if (iRet /= nf90_NoErr) then + print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName) + if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int") +end if +end subroutine get_1d_netcdf_int + + +subroutine get_1d_netcdf_real(ncid, varName, var, callingRoutine, fatal_if_error) +integer, intent(in) :: ncid !! the file identifier +character(len=*), intent(in) :: varName +real, dimension(:), intent(out) :: var +character(len=*), intent(in) :: callingRoutine +logical, intent(in) :: fatal_if_error + +integer :: varid, iret +iRet = nf90_inq_varid(ncid, varName, varid) +if (iret /= nf90_noErr) then + if (fatal_IF_ERROR) then + print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName) + call hydro_stop("get_1d_netcdf") + end if +end if +iRet = nf90_get_var(ncid, varid, var) +if (iRet /= nf90_NoErr) then + print*, trim(callingRoutine) // ": get_1d_netcdf_real: values: " // trim(varName) + if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_real") +end if +end subroutine get_1d_netcdf_real + +subroutine get_1d_netcdf_text(ncid, varName, var, callingRoutine, fatal_if_error) +integer, intent(in) :: ncid !! the file identifier +character(len=*), intent(in) :: varName +character(len=*), dimension(:), intent(out) :: var +character(len=*), intent(in) :: callingRoutine +logical, intent(in) :: fatal_if_error +integer :: varId, iRet +iRet = nf90_inq_varid(ncid, varName, varid) +if (iret /= nf90_NoErr) then + print*, trim(callingRoutine) // ": get_1d_netcdf_text: variable: " // trim(varName) + if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text") +end if +iRet = nf90_get_var(ncid, varid, var) +if (iret /= nf90_NoErr) then + print*, trim(callingRoutine) // ": get_1d_netcdf_text: values: " // trim(varName) + if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text") +end if +end subroutine get_1d_netcdf_text + +!=================================================================================================== +! Program Names: +! get_netcdf_dim +! Author(s)/Contact(s): +! James L McCreight +! Abstract: +! Get the length of a provided dimension. +! History Log: +! 7/23/15 -Created, JLM. +! Usage: +! Parameters: +! file: character, the file to query +! dimName: character, the name of the dimension +! callingRoutine: character, the name of the calling routine for error messages +! fatalErr: Optional, Logical - all errors are fatal, calling hydro_stop() +! Input Files: +! Specified argument. +! Output Files: +! Condition codes: +! hydro_stop is called. . +! User controllable options: +! Notes: + +function get_netcdf_dim(file, dimName, callingRoutine, fatalErr) +implicit none +integer :: get_netcdf_dim !! return value +character(len=*), intent(in) :: file, dimName, callingRoutine +integer :: ncId, dimId, iRet +logical, optional, intent(in) :: fatalErr +logical :: fatalErr_local +character(len=256) :: errMsg + +fatalErr_local = .false. +if(present(fatalErr)) fatalErr_local=fatalErr + +write(*,'("getting dimension from file: ", A)') trim(file) +iRet = nf90_open(trim(file), nf90_NOWRITE, ncId) +if (iret /= nf90_noerr) then + write(*,'("Problem opening file: ", A)') trim(file) + if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') +endif + +iRet = nf90_inq_dimid(ncId, trim(dimName), dimId) +if (iret /= nf90_noerr) then + write(*,'("Problem getting the dimension ID ", A)') & + '"' // trim(dimName) // '" in file: ' // trim(file) + if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') +endif + +iRet = nf90_inquire_dimension(ncId, dimId, len= get_netcdf_dim) +if (iret /= nf90_noerr) then + write(*,'("Problem getting the dimension length of ", A)') & + '"' // trim(dimName) // '" in file: ' // trim(file) + if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') +endif + +iRet = nf90_close(ncId) +if (iret /= nf90_noerr) then + write(*,'("Problem closing file: ", A)') trim(file) + if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') +endif +end function get_netcdf_dim + + +! read the GWBUCET Parm for NHDPlus +subroutine readBucket_nhd(infile, numbasns, gw_buck_coeff, gw_buck_exp, & + z_max, LINKID, nhdBuckMask) + implicit none + integer :: numbasns + integer, dimension(numbasns) :: LINKID + real, dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, z_max + integer, dimension(numbasns) :: nhdBuckMask + character(len=*) :: infile +! define temp array + integer :: i,j,k, gnid, ncid, varid, ierr, dimid, iret + integer, allocatable, dimension(:) :: tmpLinkid + real, allocatable, dimension(:) :: tmpCoeff, tmpExp, tmpz_max + +! get gnid +#ifdef MPP_LAND + if(my_id .eq. io_id ) then +#endif + iret = nf_open(trim(infile), NF_NOWRITE, ncid) +#ifdef MPP_LAND + if(iret .ne. 0) then + call hydro_stop("Failed to open GWBUCKET Parameter file.") + endif + iret = nf_inq_dimid(ncid, "BasinDim", dimid) + if (iret /= 0) then + !print*, "nf_inq_dimid: BasinDim" + call hydro_stop("Failed read GBUCKETPARM - nf_inq_dimid: BasinDim") + endif + iret = nf_inq_dimlen(ncid, dimid, gnid) + endif + call mpp_land_bcast_int1(gnid) +#endif + allocate(tmpLinkid(gnid)) + allocate(tmpCoeff(gnid)) + allocate(tmpExp(gnid)) + allocate(tmpz_max(gnid)) +#ifdef MPP_LAND + if(my_id .eq. io_id ) then +#endif +! read the file data. + iret = nf_inq_varid(ncid,"Coeff", varid) + if(iret /= 0) then + print * , "could not find Coeff from ", infile + call hydro_stop("Failed to read BUCKETPARM") + endif + iret = nf_get_var_real(ncid, varid, tmpCoeff) + + iret = nf_inq_varid(ncid,"Expon", varid) + if(iret /= 0) then + print * , "could not find Expon from ", infile + call hydro_stop("Failed to read BUCKETPARM") + endif + iret = nf_get_var_real(ncid, varid, tmpExp) + + iret = nf_inq_varid(ncid,"Zmax", varid) + if(iret /= 0) then + print * , "could not find Zmax from ", infile + call hydro_stop("Failed to read BUCKETPARM") + endif + iret = nf_get_var_real(ncid, varid, tmpz_max) + + iret = nf_inq_varid(ncid, "ComID", varid) + if(iret /= 0) then + print * , "could not find ComID from ", infile + call hydro_stop("Failed to read BUCKETPARM") + endif + iret = nf_get_var_int(ncid, varid, tmpLinkid) +#ifdef MPP_LAND + endif + if(gnid .gt. 0) then + call mpp_land_bcast_real_1d(tmpCoeff) + call mpp_land_bcast_real_1d(tmpExp) + call mpp_land_bcast_real_1d(tmpz_max) + call mpp_land_bcast_int(gnid ,tmpLinkid) + endif +#endif + + nhdBuckMask = -999 + do k = 1, numbasns + do i = 1, gnid + if(LINKID(k) .eq. tmpLinkid(i)) then + gw_buck_coeff(k) = tmpCoeff(i) + gw_buck_exp(k) = tmpExp(i) + z_max(k) = tmpz_max(i) + nhdBuckMask(k) = 1 + goto 301 + endif + end do +301 continue + end do + + if(allocated(tmpCoeff)) deallocate(tmpCoeff) + if(allocated(tmpExp)) deallocate(tmpExp) + if(allocated(tmpz_max)) deallocate(tmpz_max) + if(allocated(tmpLinkid)) deallocate(tmpLinkid) +end subroutine readBucket_nhd + +!-- output the channel routine for fast output. +! subroutine mpp_output_chrt2(gnlinks,gnlinksl,map_l2g,igrid, & +! split_output_count, NLINKS, ORDER, & +! startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch, & +! K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, & +! lsmDt & +! ) + +#ifdef MPP_LAND + subroutine mpp_output_chrt2(gnlinks,gnlinksl,map_l2g,igrid, & + split_output_count, NLINKS, ORDER, & + startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch, & + K,NLINKSL,channel_option,linkid & +#ifdef WRF_HYDRO_NUDGING + , nudge & +#endif + , QLateral, iocflag ,velocity & + , accLndRunOff, accQLateral, accStrmvolrt, accBucket, & + UDMP_OPT & + ) + + USE module_mpp_land + + implicit none + +!!output the routing variables over just channel + integer, intent(in) :: igrid,K,NLINKSL + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS + real, dimension(:), intent(in) :: chlon,chlat + real, dimension(:), intent(in) :: hlink,zelev + + integer, dimension(:), intent(in) :: ORDER, linkid + + real, intent(in) :: dtrt_ch + real, dimension(:,:), intent(in) :: qlink +#ifdef WRF_HYDRO_NUDGING + real, dimension(:), intent(in) :: nudge +#endif + real, dimension(:), intent(in) :: QLateral, velocity + integer, intent(in) :: iocflag + real, dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket + integer, intent(in) :: UDMP_OPT + + integer :: channel_option + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + integer :: gnlinks, map_l2g(nlinks), gnlinksl + real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev +#ifdef WRF_HYDRO_NUDGING + real, allocatable,dimension(:) :: g_nudge +#endif + integer, allocatable,dimension(:) :: g_order, g_linkid + real,allocatable,dimension(:,:) :: g_qlink + integer :: gsize + real, allocatable, dimension(:) :: g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket + real, allocatable, dimension(:) :: g_QLateral, g_velocity + + gsize = gNLINKS + if(gnlinksl .gt. gsize) gsize = gnlinksl + if(my_id .eq. io_id ) then + allocate(g_chlon(gsize )) + allocate(g_chlat(gsize )) + allocate(g_hlink(gsize )) + allocate(g_zelev(gsize )) + allocate(g_qlink(gsize ,2)) +#ifdef WRF_HYDRO_NUDGING + allocate(g_nudge(gsize)) +#endif + allocate(g_order(gsize )) + allocate(g_linkid(gsize )) + + allocate(g_accLndRunOff(gsize )) + allocate(g_accQLateral(gsize )) + allocate(g_accStrmvolrt(gsize )) + allocate(g_accBucket(gsize )) + + allocate(g_QLateral(gsize )) + allocate(g_velocity(gsize )) + + else + + allocate(g_accLndRunOff(1)) + allocate(g_accQLateral(1)) + allocate(g_accStrmvolrt(1)) + allocate(g_accBucket(1)) + allocate(g_QLateral(1)) + allocate(g_velocity(1)) + + allocate(g_chlon(1)) + allocate(g_chlat(1)) + allocate(g_hlink(1)) + allocate(g_zelev(1)) + allocate(g_qlink(1,2)) +#ifdef WRF_HYDRO_NUDGING + allocate(g_nudge(1)) +#endif + allocate(g_order(1)) + allocate(g_linkid(1)) + endif + + call mpp_land_sync() + if(channel_option .eq. 1 .or. channel_option .eq. 2) then + g_qlink = 0 + call ReachLS_write_io(qlink(:,1), g_qlink(:,1)) + call ReachLS_write_io(qlink(:,2), g_qlink(:,2)) +#ifdef WRF_HYDRO_NUDGING + g_nudge=0 + call ReachLS_write_io(nudge,g_nudge) +#endif + call ReachLS_write_io(order, g_order) + call ReachLS_write_io(linkid, g_linkid) + call ReachLS_write_io(chlon, g_chlon) + call ReachLS_write_io(chlat, g_chlat) + call ReachLS_write_io(zelev, g_zelev) + + call ReachLS_write_io(accLndRunOff, g_accLndRunOff) + call ReachLS_write_io(accQLateral, g_accQLateral) + call ReachLS_write_io(accStrmvolrt, g_accStrmvolrt) + call ReachLS_write_io(accBucket, g_accBucket) + + call ReachLS_write_io(QLateral, g_QLateral) + call ReachLS_write_io(velocity, g_velocity) + call ReachLS_write_io(hlink,g_hlink) + + else + call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) + call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) + call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) + call write_chanel_int(linkid,map_l2g,gnlinks,nlinks,g_linkid) + call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) + call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) + call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) + call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) + endif + + + if(my_id .eq. IO_id) then + call output_chrt2(igrid, split_output_count, GNLINKS, g_ORDER, & + startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K, & + gNLINKSL,channel_option, g_linkid & +#ifdef WRF_HYDRO_NUDGING + , g_nudge & +#endif + , g_QLateral, iocflag,g_velocity & + , g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket, & + UDMP_OPT & + ) + end if + call mpp_land_sync() + if(allocated(g_order)) deallocate(g_order) + if(allocated(g_chlon)) deallocate(g_chlon) + if(allocated(g_chlat)) deallocate(g_chlat) + if(allocated(g_hlink)) deallocate(g_hlink) + if(allocated(g_zelev)) deallocate(g_zelev) + if(allocated(g_qlink)) deallocate(g_qlink) + if(allocated(g_linkid)) deallocate(g_linkid) +#ifdef WRF_HYDRO_NUDGING + if(allocated(g_nudge)) deallocate(g_nudge) +#endif + if(allocated(g_QLateral)) deallocate(g_QLateral) + if(allocated(g_velocity)) deallocate(g_velocity) + +end subroutine mpp_output_chrt2 + +#endif + + +!subroutine output_chrt2 +!For realtime output only when CHRTOUT_GRID = 2. +! subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER, & +! startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & +! STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & +! lsmDt & +! ) + subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER, & + startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & + NLINKSL, channel_option ,linkid & +#ifdef WRF_HYDRO_NUDGING + , nudge & +#endif + , QLateral, iocflag, velocity & + , accLndRunOff, accQLateral, accStrmvolrt, accBucket, & + UDMP_OPT & + ) + + implicit none +#include +!!output the routing variables over just channel + integer, intent(in) :: igrid,K,channel_option + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS, NLINKSL + real, dimension(:), intent(in) :: chlon,chlat + real, dimension(:), intent(in) :: hlink,zelev + integer, dimension(:), intent(in) :: ORDER + + real, intent(in) :: dtrt_ch + real, dimension(:,:), intent(in) :: qlink +#ifdef WRF_HYDRO_NUDGING + real, dimension(:), intent(in) :: nudge +#endif + real, dimension(:), intent(in) :: QLateral, velocity + integer, intent(in) :: iocflag + real, dimension(nlinks), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket + integer, intent(in) :: UDMP_OPT + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + + + integer, allocatable, DIMENSION(:) :: linkid + + integer, allocatable, DIMENSION(:) :: rec_num_of_station + integer, allocatable, DIMENSION(:) :: rec_num_of_stationO + + integer, allocatable, DIMENSION(:) :: lOrder !- local stream order + + integer, save :: output_count + integer, save :: ncid + + integer :: stationdim, dimdata, varid, charid, n + integer :: timedim + + integer :: iret,i !-- order_to_write is the lowest stream order to output + integer :: start_posO, prev_posO, nlk + + integer :: previous_pos !-- used for the station model + character(len=256) :: output_flnm + character(len=34) :: sec_since_date + integer :: seconds_since,nstations,cnt,ObsStation + character(len=32) :: convention + character(len=11),allocatable, DIMENSION(:) :: stname + + character(len=34) :: sec_valid_date + + !--- all this for writing the station id string + INTEGER TDIMS, TXLEN + PARAMETER (TDIMS=2) ! number of TX dimensions + PARAMETER (TXLEN = 11) ! length of example string + INTEGER TIMEID ! record dimension id + INTEGER TXID ! variable ID + INTEGER TXDIMS(TDIMS) ! variable shape + INTEGER TSTART(TDIMS), TCOUNT(TDIMS) + + !-- observation point ids + INTEGER OTDIMS, OTXLEN + PARAMETER (OTDIMS=2) ! number of TX dimensions + PARAMETER (OTXLEN = 15) ! length of example string + INTEGER OTIMEID ! record dimension id + INTEGER OTXID ! variable ID + INTEGER OTXDIMS(OTDIMS) ! variable shape + INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) + character(len=19) :: date19, date19start + + + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + + + if(channel_option .ne. 3) then + nstations = NLINKSL + else + nstations = NLINKS + endif + + if(split_output_count .ne. 1 ) then + write(6,*) "WARNING: split_output_count need to be 1 for this output option." + endif +!-- have moved sec_since_date from above here.. + sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & + //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1)) + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + if (iret /= 0) then + print*, "Problem nf_create points" + call hydro_stop("In output_chrt2() - Problem nf_create points.") + endif + + iret = nf_def_dim(ncid, "station", nstations, stationdim) + iret = nf_def_dim(ncid, "time", 1, timedim) + +#ifndef HYDRO_REALTIME + !- station location definition all, lat + iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude') + iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') + + !- station location definition, long + iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude') + iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') + +! !-- elevation is ZELEV + iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude') + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + +!-- parent index +! iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/stationdim/), varid) +! iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record') + + + !-- prevChild +! iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/stationdim/), varid) +! iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station') + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + !-- lastChild +! iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) +! iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station') +! iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) +#endif + + if(UDMP_OPT .eq. 1) then + iret = nf_def_var(ncid, "accLndRunOff", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',28,'ACCUMULATED runoff from land') + + iret = nf_def_var(ncid, "accQLateral", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',24,'Total ACCUMULATED runoff') + + iret = nf_def_var(ncid, "accStrmvolrt", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',39,'ACCUMULATED runoff from terrain routing') + + iret = nf_def_var(ncid, "accBucket", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?') + iret = nf_put_att_text(ncid,varid,'long_name',32,'ACCUMULATED runoff from gw bucket') + endif + + iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time') + + !- flow definition, var + iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow') + +#ifdef WRF_HYDRO_NUDGING + !- nudge definition + iret = nf_def_var(ncid, "nudge", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',32,'Amount of stream flow alteration') +#endif + + +! !- head definition, var + if(channel_option .eq. 3) then + iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',5,'meter') + iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage') + endif +!#ifdef HYDRO_REALTIME +! if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then +! iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/stationdim/), varid) +! iret = nf_put_att_text(ncid,varid,'units',5,'meter') +! iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage') +! endif +!#endif + + + !-- NEW lateral inflow definition, var + if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then + iret = nf_def_var(ncid, "q_lateral", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',25,'Runoff into channel reach') + endif + + !-- NEW velocity definition, var + if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then + iret = nf_def_var(ncid, "velocity", NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'units',9,'meter/sec') + iret = nf_put_att_text(ncid,varid,'long_name',14,'River Velocity') + endif + +#ifndef HYDRO_REALTIME +! !- order definition, var + iret = nf_def_var(ncid, "order", NF_INT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order') + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) +#endif + + !-- station id + ! define character-position dimension for strings of max length 11 + iret = nf_def_var(ncid, "station_id", NF_INT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') + + convention(1:32) = "Unidata Observation Dataset v1.0" + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") +#ifndef HYDRO_REALTIME + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") +#endif + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_text(ncid, NF_GLOBAL, "station_dimension",7, "station") + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_int(ncid, NF_GLOBAL, "stream_order_output",NF_INT,1,1) + + + iret = nf_enddef(ncid) + + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) +#ifndef HYDRO_REALTIME + !-- write latitudes + iret = nf_inq_varid(ncid,"latitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chlat) + + !-- write longitudes + iret = nf_inq_varid(ncid,"longitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chlon) + + !-- write elevations + iret = nf_inq_varid(ncid,"altitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), zelev) + + !-- write order + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), ORDER) +#endif + + !-- write stream flow + iret = nf_inq_varid(ncid,"streamflow", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), qlink(:,1)) + +#ifdef WRF_HYDRO_NUDGING + !-- write nudge + iret = nf_inq_varid(ncid,"nudge", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), nudge) +#endif + + !-- write head + if(channel_option .eq. 3) then + iret = nf_inq_varid(ncid,"head", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), hlink) + endif +!#ifdef HYDRO_REALTIME +! if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then +! ! dummy value for now +! iret = nf_inq_varid(ncid,"head", varid) +! iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chlon*0.-9999.) +! endif +!#endif + + !-- write lateral inflow + if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then + iret = nf_inq_varid(ncid,"q_lateral", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), QLateral) + endif + + !-- writelvelocity (dummy value for now) + if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then + iret = nf_inq_varid(ncid,"velocity", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), velocity) + endif + + if(UDMP_OPT .eq. 1) then + + iret = nf_inq_varid(ncid,"accLndRunOff", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accLndRunOff) + + iret = nf_inq_varid(ncid,"accQLateral", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accQLateral) + + iret = nf_inq_varid(ncid,"accStrmvolrt", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accStrmvolrt) + + iret = nf_inq_varid(ncid,"accBucket", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accBucket) + + endif + + + !-- write id + iret = nf_inq_varid(ncid,"station_id", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), linkid) + + + + + iret = nf_redef(ncid) + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + + + iret = nf_close(ncid) + +#ifdef HYDRO_D + print *, "Exited Subroutine output_chrt" +#endif + + +end subroutine output_chrt2 + + + subroutine output_GW_Diag(did) + implicit none + integer :: i , did, gnbasns + +#ifdef MPP_LAND + real, allocatable, dimension(:) :: g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas + integer, allocatable, dimension(:) :: g_basnsInd + if(my_id .eq. io_id) then + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then + allocate(g_qin_gwsubbas(rt_domain(did)%gnumbasns)) + allocate(g_qout_gwsubbas(rt_domain(did)%gnumbasns)) + allocate(g_z_gwsubbas(rt_domain(did)%gnumbasns)) + allocate(g_basnsInd(rt_domain(did)%gnumbasns)) + gnbasns = rt_domain(did)%gnumbasns + else + allocate(g_qin_gwsubbas(rt_domain(did)%gnlinksl)) + allocate(g_qout_gwsubbas(rt_domain(did)%gnlinksl)) + allocate(g_z_gwsubbas(rt_domain(did)%gnlinksl)) + allocate(g_basnsInd(rt_domain(did)%gnlinksl)) + gnbasns = rt_domain(did)%gnlinksl + endif + endif + + if(nlst_rt(did)%channel_option .ne. 3) then + call ReachLS_write_io(rt_domain(did)%qin_gwsubbas,g_qin_gwsubbas) + call ReachLS_write_io(rt_domain(did)%qout_gwsubbas,g_qout_gwsubbas) + call ReachLS_write_io(rt_domain(did)%z_gwsubbas,g_z_gwsubbas) + call ReachLS_write_io(rt_domain(did)%linkid,g_basnsInd) + else + call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas, & + rt_domain(did)%basnsInd,g_qin_gwsubbas) + call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas, & + rt_domain(did)%basnsInd,g_qout_gwsubbas) + call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas, & + rt_domain(did)%basnsInd,g_z_gwsubbas) + call gw_write_io_int(rt_domain(did)%numbasns,rt_domain(did)%basnsInd, & + rt_domain(did)%basnsInd,g_basnsInd) + endif + if(my_id .eq. io_id) then +! open (unit=51,file='GW_inflow.txt',form='formatted',& +! status='unknown',position='append') +! open (unit=52,file='GW_outflow.txt',form='formatted',& +! status='unknown',position='append') +! open (unit=53,file='GW_zlev.txt',form='formatted',& +! status='unknown',position='append') +! do i=1,RT_DOMAIN(did)%gnumbasns +! write (51,951) i,nlst_rt(did)%olddate,g_qin_gwsubbas(i) +951 FORMAT(I3,1X,A19,1X,F11.3) +! write (52,951) i,nlst_rt(did)%olddate,g_qout_gwsubbas(i) +! write (53,951) i,nlst_rt(did)%olddate,g_z_gwsubbas(i) +! end do +! close(51) +! close(52) +! close(53) + + call output_gw_netcdf( nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, gnbasns, & + trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & + g_basnsInd,g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas ) + deallocate(g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas, g_basnsInd) + + endif +# else +! open (unit=51,file='GW_inflow.txt',form='formatted',& +! status='unknown',position='append') +! open (unit=52,file='GW_outflow.txt',form='formatted',& +! status='unknown',position='append') +! open (unit=53,file='GW_zlev.txt',form='formatted',& +! status='unknown',position='append') +! do i=1,RT_DOMAIN(did)%numbasns +! write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) +951 FORMAT(I3,1X,A19,1X,F11.3) +! write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) +! write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) +! end do +! close(51) +! close(52) +! close(53) + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then + call output_gw_netcdf( nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, RT_DOMAIN(did)%numbasns, & + trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & + rt_domain(did)%basnsInd,rt_domain(did)%qin_gwsubbas, & + rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas ) + else + call output_gw_netcdf( nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, RT_DOMAIN(did)%nlinksl, & + trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & + rt_domain(did)%linkid,rt_domain(did)%qin_gwsubbas, & + rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas ) + endif +#endif + end subroutine output_GW_Diag + + +!----------------------------------- gw netcdf output + + subroutine output_gw_netcdf(igrid, split_output_count, nbasns, & + startdate, date, & + gw_id_var, gw_in_var, gw_out_var, gw_z_var) + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: nbasns + real, dimension(:), intent(in) :: gw_in_var, gw_out_var, gw_z_var + integer, dimension(:), intent(in) :: gw_id_var + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + + integer, save :: output_count + integer, save :: ncid + + integer :: basindim, varid, n, nstations + integer :: iret,i !-- + character(len=256) :: output_flnm + character(len=19) :: date19, date19start + character(len=32) :: convention + integer :: timedim + integer :: seconds_since + character(len=34) :: sec_since_date + character(len=34) :: sec_valid_date + + if(split_output_count .ne. 1 ) then + write(6,*) "WARNING: split_output_count need to be 1 for this output option." + endif + + sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & + //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + seconds_since = int(nlst_rt(1)%out_dt*60*(rt_domain(1)%out_counts-1)) + + sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) & + //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC' + + write(output_flnm, '(A12,".GWOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("output_gw_netcdf") + endif + +!!! Define dimensions + + nstations =nbasns + + iret = nf_def_dim(ncid, "basin", nstations, basindim) + + iret = nf_def_dim(ncid, "time", 1, timedim) + +!!! Define variables + + + !- gw basin ID + iret = nf_def_var(ncid,"gwbas_id",NF_INT, 1, (/basindim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',11,'GW basin ID') + + !- gw inflow + iret = nf_def_var(ncid, "gw_inflow", NF_FLOAT, 1, (/basindim/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + + !- gw outflow + iret = nf_def_var(ncid, "gw_outflow", NF_FLOAT, 1, (/basindim/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + + !- depth in gw bucket + iret = nf_def_var(ncid, "gw_zlev", NF_FLOAT, 1, (/basindim/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + + ! Time variable + iret = nf_def_var(ncid, "time", NF_INT, 1, (/timeDim/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date) + iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time') + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate)) + iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + + iret = nf_enddef(ncid) + +!!! Input variables + + !-- write lake id + iret = nf_inq_varid(ncid,"gwbas_id", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), gw_id_var) + + !-- write gw inflow + iret = nf_inq_varid(ncid,"gw_inflow", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), gw_in_var ) + + !-- write elevation of inflow + iret = nf_inq_varid(ncid,"gw_outflow", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), gw_out_var ) + + !-- write elevation of inflow + iret = nf_inq_varid(ncid,"gw_zlev", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), gw_z_var ) + + !-- write time variable + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) + + iret = nf_close(ncid) + + end subroutine output_gw_netcdf + +!------------------------------- end gw netcdf output + + + subroutine read_NSIMLAKES(NLAKES,route_lake_f) + integer :: NLAKES + CHARACTER(len=256) :: route_lake_f + + character(len=256) :: route_lake_f_r + integer :: lenRouteLakeFR, iRet, ncid, dimId + logical :: routeLakeNetcdf + + !! is RouteLake file netcdf (*.nc) or from the LAKEPARM.TBL ascii +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + route_lake_f_r = adjustr(route_lake_f) + lenRouteLakeFR = len(route_Lake_f_r) + routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc' + + + write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f) + write(6,*) "routeLakeNetcdf TF Name Len",routeLakeNetcdf, route_lake_f,lenRouteLakeFR + call flush(6) + + if(routeLakeNetcdf) then + write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f) + NLAKES = get_netcdf_dim(trim(route_lake_f), 'nlakes', & + 'read_NSIMLAKES', fatalErr=.true.) + else +!yw for IOC reach based routing, if netcdf lake file is not set from the hydro.namelist, +! we will assume that no lake will be assimulated. + write(6,*) "No lake nectdf file defined. NLAKES is set to be zero." + NLAKES = 0 + endif +#ifdef MPP_LAND + endif ! end if block of my_id .eq. io_id + call mpp_land_bcast_int1(NLAKES) +#endif + + end subroutine read_NSIMLAKES + +! sequential code: not used.!!!!!! + subroutine nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, gTO_NODE,LINKID, LAKEIDM, LAKEIDA) + !--- get the lake configuration here. + implicit none + integer, dimension(:), intent(inout) :: TYPEL, LAKELINKID, LAKEIDX + integer, dimension(:), intent(inout) :: gTO_NODE + integer, dimension(:), intent(inout) :: LINKID, LAKEIDM, LAKEIDA + integer, intent(in) :: NLAKES, NLINKSL + integer, dimension(NLINKSL) :: OUTLAKEID + integer :: i,j,k, kk + + TYPEL = -999 + +!! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach +#ifdef MPP_LAND + call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, gTO_NODE,LINKID, LAKEIDM, LAKEIDA,NLINKSL) +#endif + + OUTLAKEID = gTO_NODE + DO i = 1, NLAKES + DO j = 1, NLINKSL + DO k = 1, NLINKSL + + if( (gTO_NODE(j) .eq. LINKID(k) ) .and. & + (LAKEIDA(k) .lt. 0 .and. LAKEIDA(j) .eq. LAKEIDM(i))) then + TYPEL(j) = 1 !this is the link flowing out of the lake + OUTLAKEID(j) = LAKEIDA(j) ! LINKID(j) + LAKELINKID(i) = j +! write(61,*) gTO_NODE(j),LAKEIDA(j),LAKEIDA(k),LAKELINKID(i) , j +! call flush(61) + elseif( (gTO_NODE(j) .eq. LINKID(k)) .and. & + (LAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. & + (LAKEIDA(k) .eq. LAKEIDM(i)) ) then + TYPEL(j) = 3 !type_3 inflow link to lake + OUTLAKEID(j) = LAKEIDM(i) + elseif (LAKEIDA(j) .eq. LAKEIDM(i) .and. .not. TYPEL(j) .eq. 1) then + TYPEL(j) = 2 ! internal lake linkd + endif + END DO + END DO + END DO + + DO i = 1, NLAKES + if(LAKELINKID(i) .gt. 0) then + LAKEIDX(LAKELINKID(i)) = i + endif + ENDDO + + ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link + DO i = 1, NLINKSL + DO j = 1, NLINKSL + if(TYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. OUTLAKEID(i))) then + gTO_NODE(i) = LINKID(j) ! OUTLAKEID(i) + endif + ENDDO + ENDDO + +! do k = 1, NLINKSL +! write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k) +! call flush(60+my_id) +! end do + +! DO i = 1, NLINKSL +! write(61,*) i,LAKEIDX(i), TYPEL(i) +! end do +! DO i = 1, NLAKES +! write(62,*) i,LAKELINKID(i) +! write(63,*) i,LAKEIDM(i) +! end do +! close(61) +! close(62) +! close(63) +! call hydro_finish() + +! write(60,*) TYPEL +! write(63,*) LAKELINKID, LAKEIDX +! write(64,*) gTO_NODE +! write(61,*) LINKID +! write(62,*) LAKEIDM, LAKEIDA +! close(60) +! close(61) +! close(62) +! close(63) +! close(64) +! call hydro_finish() + + + end subroutine nhdLakeMap + +#ifdef MPP_LAND + subroutine nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL) + !--- get the lake configuration here. + implicit none + integer, dimension(:), intent(out) :: TYPEL, LAKELINKID, LAKEIDX + integer, dimension(:), intent(inout) :: TO_NODE + integer, dimension(:), intent(in) :: LINKID, LAKEIDA + integer, dimension(:), intent(inout) :: LAKEIDM + integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL + integer, dimension(NLINKSL) :: OUTLAKEID + integer :: i,size ,j,k, kk, num, maxNum, m, mm + integer, allocatable, dimension(:) :: gLINKID, tmpTYPEL, tmpLINKID, ind, & + tmplakeida, tmpoutlakeid, tmpTO_NODE, gLAKEIDA, gLAKEIDX + integer, allocatable, dimension(:,:) :: gtonodeout + + integer,allocatable, dimension(:) :: gto, tmpLAKELINKID, gTYPEL, gOUTLAKEID + + integer tmpBuf(GNLINKSL) + + allocate (gto(GNLINKSL)) + + if(my_id .eq. io_id) then + allocate (tmpLAKELINKID(nlakes) ) + else + allocate (tmpLAKELINKID(1)) + endif + + +! prescan the data and remove the LAKEIDM which point to two links. +#ifdef MPP_LAND + call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL) +#endif + + + call gBcastValue(TO_NODE,gto) + maxNum = 0 + kk = 0 + do m = 1, NLINKSL + num = 0 + do k = 1, gnlinksl + if(gto(k) .eq. LINKID(m) ) then + kk = kk +1 + num = num + 1 + endif + end do + if(num .gt. maxNum) maxNum = num + end do + + allocate(ind(kk)) + allocate(gToNodeOut(NLINKSL,maxNum+1)) + gToNodeOut = -99 + allocate(tmpTYPEL(kk)) + allocate(tmpLINKID(kk)) + allocate(tmpLAKEIDA(kk)) + allocate(tmpOUTLAKEID(kk)) + allocate(tmpTO_NODE(kk)) + + if(kk .gt. 0) then + tmpOUTLAKEID = -999 + tmpTYPEL = -999 + tmpTO_NODE = -999 + endif + if(NLINKSL .gt. 0) then + OUTLAKEID = -999 + TYPEL = -999 + endif + + kk = 0 + do m = 1, NLINKSL + num = 1 + do k = 1, gnlinksl + if(gto(k) .eq. LINKID(m) ) then + kk = kk +1 + ind(kk) = k + tmpTO_NODE(kk) = gto(k) + gToNodeOut(m,num+1) = kk + gToNodeOut(m,1) = num + num = num + 1 + endif + end do + end do + size = kk + if(allocated(gto)) deallocate (gto) + + allocate(gLINKID(gnlinksl)) + call gBcastValue(LINKID,gLINKID) + do i = 1, size + k = ind(i) + tmpLINKID(i) = gLINKID(k) + enddo + + allocate(gLAKEIDA(gnlinksl)) + call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) ) + do i = 1, size + k = ind(i) + tmpLAKEIDA(i) = gLAKEIDA(k) + enddo + if(allocated(gLAKEIDA)) deallocate(gLAKEIDA) + +!yw LAKELINKID = 0 + tmpLAKELINKID = LAKELINKID + tmpOUTLAKEID = tmpTO_NODE + OUTLAKEID(1:NLINKSL) = TO_NODE(1:NLINKSL) + + !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach + DO i = 1, NLAKES + DO k = 1, NLINKSL + do m = 1, gToNodeOut(k,1) + j = gToNodeOut(k,m+1) + if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. & + (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then + tmpTYPEL(j) = 1 !this is the link flowing out of the lake + tmpOUTLAKEID(j) = tmpLAKEIDA(j) !tmpLINKID(j) ! Wei Check + LAKELINKID(i) = ind(j) +! write(61,*) tmpTO_NODE(j),tmpLAKEIDA(j),LAKEIDA(k),LAKELINKID(i) +! call flush(61) + elseif( (tmpTO_NODE(j) .eq. LINKID(k)) .and. & + (tmpLAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. & + (LAKEIDA(k) .eq. LAKEIDM(i)) ) then + tmpTYPEL(j) = 3 !type_3 inflow link to lake + tmpOUTLAKEID(j) = LAKEIDM(i) !Wei Check +! write(62,*) tmpTO_NODE(j),tmpOUTLAKEID(j),LAKEIDM(i) +! call flush(62) + elseif (tmpLAKEIDA(j) .eq. LAKEIDM(i) .and. tmpTYPEL(j) .ne. 1) then + tmpTYPEL(j) = 2 ! internal lake linkd + !! print the following to get the list of links which are ignored bc they are internal to lakes. + !print*,'Ndg: tmpLAKEIDA(j):', tmpLAKEIDA(j) + endif + END DO + END DO + END DO + +!yw call sum_int1d(LAKELINKID, NLAKES) + call updateLake_seqInt(LAKELINKID,nlakes,tmpLAKELINKID) + + if(allocated(tmplakelinkid)) deallocate(tmpLAKELINKID) + + if(gNLINKSL .gt. 0) then + if(my_id .eq. 0) then + allocate(gLAKEIDX(gNLINKSL)) + gLAKEIDX = -999 + DO i = 1, NLAKES + if(LAKELINKID(i) .gt. 0) then + gLAKEIDX(LAKELINKID(i)) = i + endif + ENDDO + else + allocate(gLAKEIDX(1)) + endif + call ReachLS_decomp(gLAKEIDX, LAKEIDX) + if(allocated(gLAKEIDX)) deallocate(gLAKEIDX) + endif + +! do k = 1, size +! write(70+my_id,*) "k, ind(k), typel, lakeidx", k, ind(k),tmpTYPEL(k), lakeidx(ind(k)) +! call flush(70+my_id) +! end do + + call TONODE2RSL(ind,tmpTYPEL,size,gNLINKSL,NLINKSL,TYPEL(1:NLINKSL), -999 ) + call TONODE2RSL(ind,tmpOUTLAKEID,size,gNLINKSL,NLINKSL,OUTLAKEID(1:NLINKSL), -999 ) + + + ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link +!yw DO i = 1, NLINKSL +!yw 105 +! DO k = 1, NLINKSL +! do m = 1, gToNodeOut(k,1) +! i = gToNodeOut(k,m+1) +! DO j = 1, NLINKSL +! if (tmpTYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. tmpOUTLAKEID(i)) & +! .and. tmpOUTLAKEID(i) .ne. -999) then +! !yw tmpTO_NODE(i) = tmpOUTLAKEID(i) !Wei Check +! tmpTO_NODE(i) = LINKID(j) !Wei Check +! endif +! END DO +! END DO +! END DO +! call TONODE2RSL(ind,tmpTO_NODE,size,gNLINKSL,NLINKSL,TO_NODE(1:NLINKSL), -999 ) + + ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link + allocate(gTYPEL(gNLINKSL)) + allocate(gOUTLAKEID(gNLINKSL)) + call gBcastValue(TYPEL,gTYPEL) + call gBcastValue(OUTLAKEID,gOUTLAKEID) + DO i = 1, NLINKSL + DO j = 1, gNLINKSL + if(TYPEL(i) .eq. 3 .and. gTYPEL(j) .eq. 1 .and. (gOUTLAKEID(j) .eq. OUTLAKEID(i))) then + TO_NODE(i) = gLINKID(j) ! OUTLAKEID(i) + endif + ENDDO + ENDDO + if(allocated(gLINKID)) deallocate(gLINKID) + if(allocated(gTYPEL)) deallocate(gTYPEL) + if(allocated(gOUTLAKEID)) deallocate(gOUTLAKEID) + if(allocated(tmpTYPEL)) deallocate(tmpTYPEL) + if(allocated(tmpLINKID)) deallocate(tmpLINKID) + if(allocated(tmpTO_NODE)) deallocate(tmpTO_NODE) + if(allocated(tmpLAKEIDA)) deallocate(tmpLAKEIDA) + if(allocated(tmpOUTLAKEID)) deallocate(tmpOUTLAKEID) + + +! do k = 1, NLINKSL +! write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k) +! call flush(60+my_id) +! end do + + +! call ReachLS_write_io(TO_NODE(1:NLINKSL), tmpBuf(1:gNLINKSL) ) +! if(my_id .eq. io_id ) then +! write(70,*) tmpBuf(1:gNLINKSL) +! call flush(70) +! endif +! call ReachLS_write_io(TYPEL(1:NLINKSL), tmpBuf(1:gNLINKSL) ) +! if(my_id .eq. io_id ) then +! write(71,*) tmpBuf +! call flush(71) +! endif +! call ReachLS_write_io(LAKEIDX(1:NLINKSL), tmpBuf(1:gNLINKSL)) +! if(my_id .eq. io_id ) then +! write(72,*) tmpBuf +! call flush(72) +! close(72) +! endif +! call ReachLS_write_io(OUTLAKEID(1:NLINKSL), tmpBuf(1:gNLINKSL)) +! if(my_id .eq. io_id ) then +! write(73,*) tmpBuf +! call flush(73) +! endif +! call hydro_finish() + +! DO i = 1, NLINKSL +! write(61,*) i,LAKEIDX(i), TYPEL(i) +! end do +! DO i = 1, NLAKES +! write(63,*) i,LAKEIDM(i) +! write(62,*) i,LAKELINKID(i) +! end do +! close(61) +! close(62) +! close(63) + +! write(60,*) TYPEL +! write(63,*) LAKELINKID, LAKEIDX +! write(64,*) TO_NODE +! write(61,*) LINKID +! write(62,*) LAKEIDM, LAKEIDA +! close(60) +! close(61) +! close(62) +! close(63) +! close(64) +! call hydro_finish() + + end subroutine nhdLakeMap_mpp + + subroutine nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL) + !--- get the lake configuration here. + implicit none + integer, dimension(NLAKES) :: LAKELINKID + integer, dimension(:), intent(in) :: TO_NODE + integer, dimension(:), intent(in) :: LINKID, LAKEIDA + integer, dimension(:), intent(inout) :: LAKEIDM + integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL + integer :: i,size ,j,k, kk, num, maxNum, m, mm + integer, allocatable, dimension(:) :: ind, & + tmplakeida, tmpoutlakeid, tmpTO_NODE, gLAKEIDA + integer, allocatable, dimension(:,:) :: gtonodeout + + integer,allocatable, dimension(:) :: gto , tmpLAKELINKID, gtoLakeId_g, gtoLakeId + +! integer tmpBuf(GNLINKSL) + integer, dimension(nlakes) :: lakemask + integer ii + + allocate (gto(GNLINKSL)) + allocate (gtoLakeId_g(GNLINKSL)) + allocate (gtoLakeId(NLINKSL)) + if(my_id .eq. io_id) then + allocate(tmpLAKELINKID(nlakes)) + else + allocate(tmpLAKELINKID(1)) + endif + + gtoLakeId_g=-999 + + call gBcastValue(TO_NODE,gto) + maxNum = 0 + kk = 0 + do m = 1, NLINKSL + num = 0 + do k = 1, gnlinksl + if(gto(k) .eq. LINKID(m) ) then + gtoLakeId_g(k) = lakeida(m) + kk = kk +1 + num = num + 1 + endif + end do + if(num .gt. maxNum) maxNum = num + end do + + allocate(ind(kk)) + allocate(gToNodeOut(NLINKSL,maxNum+1)) + gToNodeOut = -99 + allocate(tmpLAKEIDA(kk)) + allocate(tmpTO_NODE(kk)) + + + kk = 0 + do m = 1, NLINKSL + num = 1 + do k = 1, gnlinksl + if(gto(k) .eq. LINKID(m) ) then + kk = kk +1 + ind(kk) = k + tmpTO_NODE(kk) = gto(k) + gToNodeOut(m,num+1) = kk + gToNodeOut(m,1) = num + num = num + 1 + endif + end do + end do + size = kk + if(allocated(gto)) deallocate (gto) + + + allocate(gLAKEIDA(gnlinksl)) + call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) ) + do i = 1, size + k = ind(i) + tmpLAKEIDA(i) = gLAKEIDA(k) + enddo + if(allocated(gLAKEIDA)) deallocate(gLAKEIDA) + + tmpLAKELINKID = LAKELINKID +! LAKELINKID = 0 + DO i = 1, NLAKES + DO k = 1, NLINKSL + do m = 1, gToNodeOut(k,1) + j = gToNodeOut(k,m+1) + if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. & + (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then + if(LAKELINKID(i) .gt. 0) then + LAKELINKID(i) = -999 +#ifdef HYDRO_D + write(6,*) "remove the lake LAKEIDM(i) ", i, LAKEIDM(i) + call flush(6) +#endif + endif + if(LAKELINKID(i) .eq. 0) LAKELINKID(i) = ind(j) + endif + END DO + END DO + END DO +!yw call match1dLake(LAKELINKID, NLAKES, -999) + +!yw double check + call combine_int1d(gtoLakeId_g,gnlinksl, -999) + call ReachLS_decomp(gtoLakeId_g,gtoLakeId) + + lakemask = 0 + DO k = 1, NLINKSL + if(LAKEIDA(k) .gt. 0) then + DO i = 1, NLAKES + if(gtoLakeId(k) .eq. LAKEIDM(i) ) then + goto 992 + endif + enddo + DO i = 1, NLAKES + if(LAKEIDA(k) .eq. LAKEIDM(i) ) then + lakemask(i) = lakemask(i) + 1 + goto 992 + endif + enddo +992 continue + endif + enddo + + if(allocated(gtoLakeId_g)) deallocate(gtoLakeId_g) + if(allocated(gtoLakeId)) deallocate(gtoLakeId) + call sum_int1d(lakemask, NLAKES) + + do i = 1, nlakes + if(lakemask(i) .ne. 1) then + LAKELINKID(i) = -999 +#ifdef HYDRO_D + if(my_id .eq. IO_id) then + write(6,*) "double check remove the lake : ",LAKEIDM(i) + call flush(6) + endif +#endif + endif + enddo + + +!end double check + + + call updateLake_seqInt(LAKELINKID,nlakes,tmpLAKELINKID) + +! if(my_id .eq. 0) then +! write(65,*) "check LAKEIDM *****," +! write(65,*) LAKEIDM +! call flush(6) +! endif + + do k = 1, NLAKES + if(LAKELINKID(k) .eq. -999) LAKEIDM(k) = -999 + end do + +! if(my_id .eq. 0) then +! write(65,*) "check LAKEIDM *****," +! write(65,*) LAKEIDM +! call flush(6) +! endif + + close(65) + if(allocated(tmpTO_NODE)) deallocate(tmpTO_NODE) + if(allocated(tmpLAKEIDA)) deallocate(tmpLAKEIDA) + if(allocated(tmplakelinkid)) deallocate(tmplakelinkid) + + end subroutine nhdLakeMap_scan +#endif + +!ADCHANGE: New output lake types routine + subroutine output_lake_types( inNLINKS, inLINKID, inTYPEL ) + +#ifdef MPP_LAND + use module_mpp_land +#endif + + implicit none +#include + + integer, dimension(:), intent(in) :: inLINKID, inTYPEL + integer, intent(in) :: inNLINKS + + integer :: iret + integer :: ncid, varid + integer, parameter :: did=1 + integer :: linkdim + character(len=256), parameter :: output_flnm = "LAKE_TYPES.nc" + + integer, allocatable, dimension(:) :: linkId, typeL + +#ifdef MPP_LAND + + if(my_id .eq. io_id) then + allocate( linkId(inNLINKS) ) + allocate( typeL(inNLINKS) ) + else + allocate(linkId(1), typeL(1)) + end if + + call mpp_land_sync() + call ReachLS_write_io(inLINKID, linkId) + call ReachLS_write_io(inTYPEL, typeL) + +#else + + allocate( linkId(inNLINKS) ) + allocate( typeL(inNLINKS) ) + + linkId = inLINKID + typeL = inTYPEL + +#endif + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + + ! Create the channel connectivity file +#ifdef HYDRO_D + print*,'Lakes: output_flnm = "'//trim(output_flnm)//'"' + flush(6) +#endif + +#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT + write(6,*) "using normal netcdf file for LAKE TYPES" + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#else + write(6,*) "using large netcdf file for LAKE TYPES" + iret = nf_create(trim(output_flnm), ior(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#endif + + if (iret /= 0) then + print*,"Lakes: Problem nf_create" + call hydro_stop("output_lake_types") + endif + + iret = nf_def_dim(ncid, "link", inNLINKS, linkdim) + + !-- link id + iret = nf_def_var(ncid, "LINKID", NF_INT, 1, (/linkdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',10,'Link ID') + + !- lake reach type, var + iret = nf_def_var(ncid, "TYPEL", NF_INT, 1, (/linkdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',15,'Lake reach type') + + iret = nf_enddef(ncid) + + !-- write id + iret = nf_inq_varid(ncid,"LINKID", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/inNLINKS/), linkId) + + !-- write type + iret = nf_inq_varid(ncid,"TYPEL", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/inNLINKS/), typeL) + + iret = nf_close(ncid) + +#ifdef MPP_LAND + endif +#endif + if(allocated(linkId)) deallocate(linkId) + if(allocated(typeL)) deallocate(typeL) + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif +#ifdef HYDRO_D + write(6,*) "end of output_lake_types" + flush(6) +#endif +#ifdef MPP_LAND + endif +#endif + +end subroutine output_lake_types + + +end module module_HYDRO_io diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F b/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F new file mode 100644 index 00000000..8a1fde3b --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F @@ -0,0 +1,417 @@ +! Program Name: +! 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_HYDRO_utils + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt +#ifdef MPP_LAND + use module_mpp_land, only: global_nx, global_ny, my_id, IO_id, & + decompose_data_real, write_io_real, MPP_LAND_COM_REAL, & + write_io_int, mpp_land_bcast_real, global_rt_nx, global_rt_ny, & + decompose_rt_real, write_io_rt_real + use MODULE_mpp_GWBUCKET, only: gw_decompose_real +#endif + + + implicit none + logical lr_dist_flag !land routing distance calculated or not. + +contains + + integer function get2d_real(var_name,out_buff,ix,jx,fileName) + implicit none +# include "netcdf.inc" + integer :: ivar, iret,varid,ncid,ix,jx + real out_buff(ix,jx) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: fileName + get2d_real = -1 + + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) + if (iret .ne. 0) then +#ifdef HYDRO_D + print*,"Failed to open the netcdf file: ",trim(fileName) +#endif + out_buff = -9999. + return + endif + ivar = nf_inq_varid(ncid,trim(var_name), varid) + if(ivar .ne. 0) then + ivar = nf_inq_varid(ncid,trim(var_name//"_M"), varid) + if(ivar .ne. 0) then +#ifdef HYDRO_D + write(6,*) "Read Error: could not find ",var_name +#endif + return + endif + end if + iret = nf_get_var_real(ncid, varid, out_buff) + iret = nf_close(ncid) + get2d_real = ivar + end function get2d_real + + +! this module create the distance dx, dy and diagnoal for routing +! 8 direction as the slop: +! 1: i,j+1 +! 2: i+1, j+1 +! 3: i+1, j +! 4: i+1, j-1 +! 5: i, j-1 +! 6: i-1, j-1 +! 7: i-1, j +! 8: i-1, j+1 + real function get_dy(i,j,v,ix,jx) + ! south north + integer :: i,j,ix,jx + real,dimension(ix,jx,9) :: v + if( v(i,j,1) .le. 0) then + get_dy = v(i,j,5) + else if( v(i,j,5) .le. 0) then + get_dy = v(i,j,1) + else + get_dy = (v(i,j,1) + v(i,j,5) ) / 2 + endif + return + end function get_dy + + real function get_dx(i,j,v,ix,jx) + ! east-west + integer :: i,j, ix,jx + real,dimension(ix,jx,9) :: v + if( v(i,j,3) .le. 0) then + get_dx = v(i,j,7) + else if( v(i,j,7) .le. 0) then + get_dx = v(i,j,3) + else + get_dx = (v(i,j,3) + v(i,j,7) ) / 2 + endif + return + end function get_dx + + real function get_ll_d(lat1_in, lat2_in, lon1_in, lon2_in) + implicit none + real:: lat1, lat2, lon1, lon2 + real:: lat1_in, lat2_in, lon1_in, lon2_in + real:: r, pai, a,c, dlat, dlon, b1,b2 + pai = 3.14159 + lat1 = lat1_in * pai/180 + lat2 = lat2_in * pai/180 + lon1 = lon1_in * pai/180 + lon2 = lon2_in * pai/180 + r = 6378.1*1000 + dlat = lat2 -lat1 + dlon = lon2 -lon1 + a = sin(dlat/2)*sin(dlat/2) + cos(lat1)*cos(lat2)*sin(dlon/2)*sin(dlon/2) + b1 = sqrt(a) + b2 = sqrt(1-a) + c = 2.0*atan2(b1,b2) + get_ll_d = R*c + return + + end function get_ll_d + + real function get_ll_d_tmp(lat1_in, lat2_in, lon1_in, lon2_in) + implicit none + real:: lat1, lat2, lon1, lon2 + real:: lat1_in, lat2_in, lon1_in, lon2_in + real:: r, pai + pai = 3.14159 + lat1 = lat1_in * pai/180 + lat2 = lat2_in * pai/180 + lon1 = lon1_in * pai/180 + lon2 = lon2_in * pai/180 + r = 6371*1000 + get_ll_d_tmp = acos(sin(lat1)*sin(lat2)+cos(lat1)*cos(lat2)*cos(lon2-lon1))*r + return + + end function get_ll_d_tmp + + subroutine get_rt_dxdy_ll(did) +! use the land lat and lon to derive the routing distrt + implicit none + integer:: did, k + integer iret +! external get2d_real +! real get2d_real +#ifdef MPP_LAND + real, dimension(global_rt_nx,global_rt_ny):: latrt, lonrt + real, dimension(global_rt_nx,global_rt_ny,9):: dist + if(my_id .eq. IO_id) then + ! read the lat and lon. + iret = get2d_real("LONGITUDE",lonrt,global_rt_nx,global_rt_ny,& + trim(nlst_rt(did)%GEO_FINEGRID_FLNM )) + iret = get2d_real("LATITUDE",latrt,global_rt_nx,global_rt_ny,& + trim(nlst_rt(did)%GEO_FINEGRID_FLNM )) + call get_dist_ll(dist,latrt,lonrt,global_rt_nx,global_rt_ny) + end if + do k = 1 , 9 + call decompose_RT_real(dist(:,:,k),rt_domain(did)%dist(:,:,k), & + global_rt_nx,global_rt_ny,rt_domain(did)%ixrt,rt_domain(did)%jxrt) + end do +#else + real, dimension(rt_domain(did)%ixrt,rt_domain(did)%jxrt):: latrt, lonrt + ! read the lat and lon. + iret = get2d_real("LONGITUDE",lonrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,& + trim(nlst_rt(did)%GEO_FINEGRID_FLNM )) + iret = get2d_real("LATITUDE",latrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,& + trim(nlst_rt(did)%GEO_FINEGRID_FLNM )) + call get_dist_ll(rt_domain(did)%dist,latrt,lonrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt) +#endif + + end subroutine get_rt_dxdy_ll + +! get dx and dy of lat and lon + subroutine get_dist_ll(dist,lat,lon,ix,jx) + implicit none + integer:: ix,jx + real, dimension(ix,jx,9):: dist + real, dimension(ix,jx):: lat, lon + integer:: i,j + real x,y + dist = -1 + do j = 1, jx + do i = 1, ix + if(j .lt. jx) dist(i,j,1) = & + get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1)) + if(j .lt. jx .and. i .lt. ix) dist(i,j,2) = & + get_ll_d(lat(i,j), lat(i+1,j+1), lon(i,j), lon(i+1,j+1)) + if(i .lt. ix) dist(i,j,3) = & + get_ll_d(lat(i,j), lat(i+1,j), lon(i,j), lon(i+1,j)) + if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = & + get_ll_d(lat(i,j), lat(i+1,j-1), lon(i,j), lon(i+1,j-1)) + if(j .gt. 1 ) dist(i,j,5) = & + get_ll_d(lat(i,j), lat(i,j-1), lon(i,j), lon(i,j-1)) + if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = & + get_ll_d(lat(i,j), lat(i-1,j-1), lon(i,j), lon(i-1,j-1)) + if(i .gt. 1) dist(i,j,7) = & + get_ll_d(lat(i,j), lat(i-1,j), lon(i,j), lon(i-1,j)) + if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = & + get_ll_d(lat(i,j), lat(i-1,j+1), lon(i,j), lon(i-1,j+1)) + end do + end do + do j = 1, jx + do i = 1, ix + if(j.eq.1) then + y = get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1)) + else if(j.eq.jx) then + y = get_ll_d(lat(i,j-1), lat(i,j), lon(i,j-1), lon(i,j)) + else + y = get_ll_d(lat(i,j-1), lat(i,j+1), lon(i,j-1), lon(i,j+1))/2.0 + endif + + if(i.eq.ix) then + x = get_ll_d(lat(i,j), lat(i-1,j), lon(i,j), lon(i-1,j)) + else if(i.eq.1) then + x = get_ll_d(lat(i,j), lat(i+1,j), lon(i,j), lon(i+1,j)) + else + x = get_ll_d(lat(i-1,j), lat(i+1,j), lon(i-1,j), lon(i+1,j))/2.0 + endif + dist(i,j,9) = x * y + end do + end do +#ifdef HYDRO_D + write(6,*) "finished get_dist_ll" +#endif + end subroutine get_dist_ll + +! get dx and dy of map projected + subroutine get_dxdy_mp(dist,ix,jx,dx,dy) + implicit none + integer:: ix,jx + real :: dx,dy + integer:: i,j + real :: v1 + ! out variable + real, dimension(ix,jx,9)::dist + dist = -1 + v1 = sqrt(dx*dx + dy*dy) + do j = 1, jx + do i = 1, ix + if(j .lt. jx) dist(i,j,1) = dy + if(j .lt. jx .and. i .lt. ix) dist(i,j,2) = v1 + if(i .lt. ix) dist(i,j,3) = dx + if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = v1 + if(j .gt. 1 ) dist(i,j,5) = dy + if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = v1 + if(i .gt. 1) dist(i,j,7) = dx + if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = v1 + dist(i,j,9) = dx * dy + end do + end do +#ifdef HYDRO_D + write(6,*) "finished get_dxdy_mp " +#endif + end subroutine get_dxdy_mp + + subroutine get_dist_lsm(did) + integer did +#ifdef MPP_LAND + integer ix,jx,ixrt,jxrt, k + real , dimension(global_nx,global_ny):: latitude,longitude + real, dimension(global_nx,global_ny,9):: dist + if(nlst_rt(did)%dxrt0 .lt. 0) then + ! lat and lon grid + call write_io_real(rt_domain(did)%lat_lsm,latitude) + call write_io_real(rt_domain(did)%lon_lsm,longitude) + if(my_id.eq.IO_id) then + call get_dist_ll(dist,latitude,longitude, & + global_nx,global_ny) + endif + + else + ! mapp projected grid. + if(my_id.eq.IO_id) then + call get_dxdy_mp(dist,global_nx,global_ny, & + nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT,nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT) + endif + endif + do k = 1 , 9 + call decompose_data_real(dist(:,:,k),rt_domain(did)%dist_lsm(:,:,k)) + end do +#else + if(nlst_rt(did)%dxrt0 .lt. 0) then + ! lat and lon grid + call get_dist_ll(rt_domain(did)%dist_lsm,rt_domain(did)%lat_lsm,rt_domain(did)%lon_lsm, & + rt_domain(did)%ix,rt_domain(did)%jx) + else + ! mapp projected grid. + call get_dxdy_mp(rt_domain(did)%dist_lsm,rt_domain(did)%ix,rt_domain(did)%jx, & + nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT,nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT) + endif +#endif + + + end subroutine get_dist_lsm + + subroutine get_dist_lrt(did) + integer did, k + +! real :: tmp_dist(global_rt_nx, global_rt_ny,9) + +! calculate the distance for land routing from the lat /lon of land surface model + if(nlst_rt(did)%dxrt0 .lt. 0) then + ! using lat and lon grid when channel routing is off + call get_rt_dxdy_ll(did) + else + ! mapp projected grid. + call get_dxdy_mp(rt_domain(did)%dist,rt_domain(did)%ixrt,rt_domain(did)%jxrt, & + nlst_rt(did)%dxrt0,nlst_rt(did)%dxrt0) +#ifdef MPP_LAND + do k = 1, 9 + call MPP_LAND_COM_REAL(rt_domain(did)%dist(:,:,k),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) + end do +#endif + endif + + + end subroutine get_dist_lrt + +! subroutine get_dist_crt(did) +! integer did, k +! calculate the distance from channel routing +! if(nlst_rt(did)%dxrt0 .lt. 0) then +! ! lat and lon grid +! if(rt_domain(did)%dist(1,1,9) .eq. -999) & +! call get_dist_ll(rt_domain(did)%dist,rt_domain(did)%latval,rt_domain(did)%lonval, & +! rt_domain(did)%ixrt,rt_domain(did)%jxrt) +! else +! ! mapp projected grid. +! if(rt_domain(did)%dist(1,1,9) .eq. -999) & +! call get_dxdy_mp(rt_domain(did)%dist,rt_domain(did)%ixrt,rt_domain(did)%jxrt, & +! nlst_rt(did)%dxrt0,nlst_rt(did)%dxrt0) +! endif +!#ifdef MPP_LAND +! do k = 1, 9 +! call MPP_LAND_COM_REAL(rt_domain(did)%dist(:,:,k),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) +! end do +!#endif +! end subroutine get_dist_crt + + subroutine get_basn_area(did) + implicit none + integer :: did, ix,jx, k + real :: basns_area(rt_domain(did)%gnumbasns) +#ifdef MPP_LAND + integer :: mask(global_nx, global_ny) + real :: dist_lsm(global_nx, global_ny,9) +#else + integer :: mask(rt_domain(did)%ix, rt_domain(did)%jx) + real :: dist_lsm(rt_domain(did)%ix, rt_domain(did)%jx,9) +#endif +#ifdef MPP_LAND + ix = global_nx + jx = global_ny + call write_IO_int(rt_domain(did)%GWSUBBASMSK,mask) + do k = 1, 9 + call write_IO_real(rt_domain(did)%dist_lsm(:,:,k),dist_lsm(:,:,k)) + end do +#else + ix = rt_domain(did)%ix + jx = rt_domain(did)%jx + mask = rt_domain(did)%GWSUBBASMSK + dist_lsm = rt_domain(did)%dist_lsm +#endif + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then + call get_area_g(basns_area,mask, rt_domain(did)%gnumbasns,ix,jx,dist_lsm) + end if +! call mpp_land_bcast_real(rt_domain(did)%numbasns,rt_domain(did)%basns_area) + + call gw_decompose_real(rt_domain(did)%gnumbasns, rt_domain(did)%numbasns, & + rt_domain(did)%basnsInd, basns_area,rt_domain(did)%basns_area) +#else + call get_area_g(rt_domain(did)%basns_area,mask, rt_domain(did)%gnumbasns,ix,jx,dist_lsm) +#endif + end subroutine get_basn_area + + subroutine get_area_g(basns_area,GWSUBBASMSK, numbasns,ix,jx,dist) + integer :: i,j, n, ix,jx, numbasns + integer :: count(numbasns) + real :: basns_area(numbasns) , dist(ix,jx,9) + integer :: GWSUBBASMSK(ix,jx) + basns_area = 0 + count = 0 + do j = 1, jx + do i = 1, ix + n = GWSUBBASMSK(i,j) + if(n .gt. 0) then + basns_area(n) = basns_area(n)+dist(i,j,9) + count(n) = count(n) + 1 + endif + end do + end do + do i = 1, numbasns + if(count(i) .gt. 0) then + basns_area(i) = basns_area(i) / count(i) + end if + end do + end subroutine get_area_g + + + subroutine get_node_area(did) + integer :: did + call get_area_g(rt_domain(did)%node_area,rt_domain(did)%CH_NETLNK, & + rt_domain(did)%NLINKS,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%dist) + end subroutine get_node_area + + +end module module_HYDRO_utils diff --git a/wrfv2_fire/hydro/Routing/module_RT.F b/wrfv2_fire/hydro/Routing/module_RT.F new file mode 100644 index 00000000..ab36ef19 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_RT.F @@ -0,0 +1,1290 @@ +! Program Name: +! 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_Routing +#ifdef MPP_LAND + use module_gw_baseflow, only: pix_ct_1 + use module_HYDRO_io, only: mpp_read_routedim, read_routing_seq, mpp_read_chrouting_new, & + mpp_read_simp_gw + use MODULE_mpp_ReachLS, only: ReachLS_ini, getlocalindx, getToInd + USE module_mpp_land, only : left_id, up_id, right_id, down_id, mpp_land_com_integer, mpp_land_bcast_int, & + updateLake_seq + use module_mpp_GWBUCKET, only : collectSizeInd +#else + !yw use module_HYDRO_io, only: read_routedim, read_routing_old, read_chrouting,read_simp_gw + use module_HYDRO_io, only: read_routedim, read_routing_seq, read_chrouting1,read_simp_gw, get_nlinksl +#endif + use module_HYDRO_io, only: readgw2d, simp_gw_ind,read_GWBUCKPARM, get_gw_strm_msk_lind, readBucket_nhd, read_NSIMLAKES + use module_HYDRO_utils + + use module_UDMAP, only: LNUMRSL, LUDRSL, UDMP_ini + 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 +#endif +#endif + +CONTAINS + + subroutine rt_allocate(did,ix,jx,ixrt,jxrt,nsoil,CHANRTSWCRT) + use module_RT_data, only: rt_domain + implicit none + integer ixrt,jxrt, ix,jx,nsoil,NLINKS, CHANRTSWCRT, NLAKES, NLINKSL + integer istatus, did, nsizes + if(rt_domain(did)%allo_status .eq. 1) return + rt_domain(did)%allo_status = 1 + + rt_domain(did)%ix = ix + rt_domain(did)%jx = jx + rt_domain(did)%ixrt = ixrt + rt_domain(did)%jxrt = jxrt +! ixrt = rt_domain(did)%ixrt +! jxrt = rt_domain(did)%jxrt + +! if( nlst_rt(did)%channel_option .eq. 1 .or. nlst_rt(did)%channel_option .eq. 2 ) then +! rt_domain(did)%NLINKS = rt_domain(did)%NLINKSL +! endif + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + if(rt_domain(did)%NLINKS .lt. rt_domain(did)%NLINKSL) then + rt_domain(did)%NLINKS = rt_domain(did)%NLINKSL + endif + endif + + NLINKS = rt_domain(did)%NLINKS + NLAKES = rt_domain(did)%NLAKES + NLINKSL = rt_domain(did)%NLINKSL + + if(NLINKSL .gt. NLINKS) then + nsizes = nlinksl + else + nsizes = nlinks +! write(6,*) "Fatal Error: NLINKSL .gt. NLINKS .. " +! call hydro_stop("not solved, contact WRF-Hydro group. ") + endif + rt_domain(did)%nlinksize = nsizes + + + if(rt_domain(did)%NLINKS .eq. 0) NLINKS = 1 + if(rt_domain(did)%NLAKES .eq. 0) NLAKES = 1 + if(rt_domain(did)%NLINKSL .eq. 0) NLINKSL = 1 + +!DJG Allocate routing and disaggregation arrays + +#ifdef HYDRO_D + write(6,*) " rt_allocate ***** ixrt,jxrt, nsoil", ixrt,jxrt, nsoil +#endif + + + allocate( rt_domain(did)%DSMC (NSOIL) ) + rt_domain(did)%dsmc = 0 + + + allocate( rt_domain(did)%SMCRTCHK (NSOIL) ) + rt_domain(did)%SMCRTCHK = 0 + + allocate( rt_domain(did)%SH2OAGGRT (NSOIL) ) + rt_domain(did)%SH2OAGGRT = 0 + allocate( rt_domain(did)%STCAGGRT (NSOIL) ) + allocate( rt_domain(did)%SMCAGGRT (NSOIL) ) + rt_domain(did)%STCAGGRT = 0 + rt_domain(did)%SMCAGGRT = 0 + + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + allocate ( RT_DOMAIN(did)%landRunOff (ixrt,jxrt) ) + endif + + + allocate( rt_domain(did)%SMCRT (IXRT,JXRT,NSOIL) ) + allocate( rt_domain(did)%soiltypRT (IXRT,JXRT) ) + allocate( rt_domain(did)%ELRT (IXRT,JXRT) ) + allocate( rt_domain(did)%SOXRT (IXRT,JXRT) ) + allocate( rt_domain(did)%SOYRT (IXRT,JXRT) ) + allocate( rt_domain(did)%SO8RT (IXRT,JXRT,8) ) + allocate( rt_domain(did)%SO8RT_D (IXRT,JXRT,3) ) + allocate( rt_domain(did)%OVROUGHRT (IXRT,JXRT) ) +! allocate( rt_domain(did)%QSUBBDRYTRT (IXRT,JXRT) ) +! rt_domain(did)%QSUBBDRYTRT = 0.0 + + allocate( rt_domain(did)%OVROUGHRTFAC (IXRT,JXRT) ) + allocate( rt_domain(did)%RETDEPRT (IXRT,JXRT) ) + allocate( rt_domain(did)%RETDEPRTFAC (IXRT,JXRT) ) + allocate( rt_domain(did)%SFCHEADSUBRT(IXRT,JXRT) ) + allocate( rt_domain(did)%INFXSUBRT (IXRT,JXRT) ) + allocate( rt_domain(did)%INFXSWGT (IXRT,JXRT) ) + allocate( rt_domain(did)%LKSATRT (IXRT,JXRT) ) + allocate( rt_domain(did)%LKSATFAC (IXRT,JXRT) ) + allocate( rt_domain(did)%QSUBRT (IXRT,JXRT) ) + allocate( rt_domain(did)%ZWATTABLRT (IXRT,JXRT) ) + allocate( rt_domain(did)%QSUBBDRYRT (IXRT,JXRT) ) + allocate( rt_domain(did)%SOLDEPRT (IXRT,JXRT) ) + allocate( rt_domain(did)%q_sfcflx_x (IXRT,JXRT) ) + allocate( rt_domain(did)%q_sfcflx_y (IXRT,JXRT) ) + allocate( rt_domain(did)%SMCMAXRT (IXRT,JXRT,NSOIL) ) + allocate( rt_domain(did)%SMCWLTRT (IXRT,JXRT,NSOIL) ) + allocate( rt_domain(did)%SH2OWGT (IXRT,JXRT,NSOIL) ) + allocate( rt_domain(did)%INFXSAGGRT (IXRT,JXRT) ) + allocate( rt_domain(did)%DHRT (IXRT,JXRT) ) + allocate( rt_domain(did)%QSTRMVOLRT (IXRT,JXRT) ) + + + allocate( rt_domain(did)%QSTRMVOLRT_TS (IXRT,JXRT) ) + allocate( rt_domain(did)%QSTRMVOLRT_DUM (IXRT,JXRT) ) + allocate( rt_domain(did)%QBDRYRT (IXRT,JXRT) ) + + allocate( rt_domain(did)%CH_NETRT (IXRT,JXRT) ) + + allocate( rt_domain(did)%LAKE_MSKRT (IXRT,JXRT) ) + allocate( rt_domain(did)%LAKE_INFLORT(IXRT,JXRT) ) + allocate( rt_domain(did)%LAKE_INFLORT_TS(IXRT,JXRT) ) + allocate( rt_domain(did)%LAKE_INFLORT_DUM(IXRT,JXRT) ) + + allocate( rt_domain(did)%SUB_RESID (ixrt,jxrt) ) + allocate( rt_domain(did)%LATVAL (ixrt,jxrt) ) + allocate( rt_domain(did)%LONVAL (ixrt,jxrt) ) + allocate( rt_domain(did)%dist (ixrt,jxrt,9) ) + +! tmp array + allocate( rt_domain(did)%SMCREFRT (IXRT,JXRT,NSOIL) ) +!!!! tmp + + rt_domain(did)%dist = -999 + rt_domain(did)%SMCRT = 0.0 + rt_domain(did)%ELRT = 0.0 + rt_domain(did)%SOXRT = 0.0 + rt_domain(did)%SOYRT = 0.0 + rt_domain(did)%SO8RT = -999 + rt_domain(did)%SO8RT_D = 0.0 + rt_domain(did)%OVROUGHRT = 0.0 + rt_domain(did)%SFCHEADSUBRT= 0.0 + rt_domain(did)%INFXSUBRT = 0.0 + rt_domain(did)%INFXSWGT = 0.0 + rt_domain(did)%LKSATRT = 0.0 + rt_domain(did)%LKSATFAC = 0.0 + rt_domain(did)%QSUBRT = 0.0 + rt_domain(did)%ZWATTABLRT = 0.0 + rt_domain(did)%QSUBBDRYRT = 0.0 + rt_domain(did)%SOLDEPRT = 0.0 + rt_domain(did)%q_sfcflx_x = 0.0 + rt_domain(did)%q_sfcflx_y = 0.0 + rt_domain(did)%SMCMAXRT = 0.0 + rt_domain(did)%SMCWLTRT = 0.0 + rt_domain(did)%SH2OWGT = 0.0 + rt_domain(did)%INFXSAGGRT = 0.0 + rt_domain(did)%DHRT = 0.0 + rt_domain(did)%QSTRMVOLRT = 0.0 + rt_domain(did)%QSTRMVOLRT_DUM = 0.0 + rt_domain(did)%QBDRYRT = 0.0 + + rt_domain(did)%CH_NETRT = 0.0 + + rt_domain(did)%LAKE_MSKRT = -9999 + rt_domain(did)%LAKE_INFLORT= 0.0 + rt_domain(did)%LAKE_INFLORT_DUM= 0.0 + + rt_domain(did)%SUB_RESID = 0.0 + rt_domain(did)%LATVAL = 0.0 + rt_domain(did)%LONVAL = 0.0 + + + rt_domain(did)%timestep_flag = 1 ! default is cold start + + allocate( rt_domain(did)%CH_LNKRT (IXRT,JXRT) ) + rt_domain(did)%CH_LNKRT = 0.0 + + IF (CHANRTSWCRT.EQ.1 .or. CHANRTSWCRT .eq. 2) THEN !IF/then for channel routing + allocate( rt_domain(did)%CH_NETLNK (IXRT,JXRT) ) + rt_domain(did)%CH_NETLNK = 0.0 + + allocate( rt_domain(did)%GCH_NETLNK (IXRT,JXRT) ) + rt_domain(did)%GCH_NETLNK = 0.0 + + + +!DJG,DNY Allocate channel routing and lake routing arrays + +#ifdef MPP_LAND + allocate( rt_domain(did)%LAKE_INDEX(NLAKES) ) + allocate( rt_domain(did)%nlinks_INDEX(nsizes) ) + allocate( rt_domain(did)%Link_location(ixrt,jxrt)) +#endif + + allocate( rt_domain(did)%CH_LNKRT_SL (IXRT,JXRT) ) + rt_domain(did)%CH_LNKRT_SL = -99 + +!tmp if( nlst_rt(did)%channel_option .eq. 1 .or. nlst_rt(did)%channel_option .eq. 3 ) then +!tmp NLINKS = rt_domain(did)%NLINKSL +!tmp NLAKES = rt_domain(did)%NLINKSL +!tmp endif + + allocate( rt_domain(did)%LINKID(nsizes) ) + allocate( rt_domain(did)%gages(nsizes) ) + allocate( rt_domain(did)%TO_NODE(nsizes) ) + allocate( rt_domain(did)%FROM_NODE(nsizes) ) + allocate( rt_domain(did)%CHLAT(nsizes) ) !-latitutde of channel grid point + allocate( rt_domain(did)%CHLON(nsizes) ) !-longitude of channel grid point + allocate( rt_domain(did)%ZELEV(nsizes) ) + allocate( rt_domain(did)%TYPEL(nsizes) ) + allocate( rt_domain(did)%ORDER(nsizes) ) + allocate( rt_domain(did)%QLINK(nsizes,2) ) +#ifdef WRF_HYDRO_NUDGING + allocate( rt_domain(did)%nudge(nsizes) ) +#endif + allocate( rt_domain(did)%MUSK(nsizes) ) + allocate( rt_domain(did)%MUSX(nsizes) ) + allocate( rt_domain(did)%CHANLEN(nsizes) ) + allocate( rt_domain(did)%MannN(nsizes)) + allocate( rt_domain(did)%So(nsizes) ) + allocate( rt_domain(did)%ChSSlp(nsizes) ) + allocate( rt_domain(did)%Bw(nsizes) ) + allocate( rt_domain(did)%LAKEIDA(nsizes) ) + allocate( rt_domain(did)%LAKEIDX(nsizes) ) + + if(NLAKES .gt. 0) then + allocate( rt_domain(did)%LAKEIDM(NLAKES) ) + allocate( rt_domain(did)%HRZAREA(NLAKES) ) + allocate( rt_domain(did)%LAKEMAXH(NLAKES) ) + allocate( rt_domain(did)%WEIRH(NLAKES) ) + allocate( rt_domain(did)%WEIRC(NLAKES) ) + allocate( rt_domain(did)%WEIRL(NLAKES) ) + allocate( rt_domain(did)%ORIFICEC(NLAKES) ) + allocate( rt_domain(did)%ORIFICEA(NLAKES) ) + allocate( rt_domain(did)%ORIFICEE(NLAKES) ) + rt_domain(did)%HRZAREA = 0.0 + rt_domain(did)%WEIRH = 0.0 + rt_domain(did)%WEIRC = 0.0 + rt_domain(did)%WEIRL = 0.0 + rt_domain(did)%LAKEMAXH = 0.0 + rt_domain(did)%ORIFICEC = 0.0 + rt_domain(did)%ORIFICEA = 0.0 + rt_domain(did)%ORIFICEE = 0.0 + endif + + +! allocate( rt_domain(did)%LAKEMAXH(nsizes) ) +! allocate( rt_domain(did)%WEIRC(nsizes) ) +! allocate( rt_domain(did)%WEIRL(nsizes) ) +! allocate( rt_domain(did)%ORIFICEC(nsizes) ) +! allocate( rt_domain(did)%ORIFICEA(nsizes) ) +! allocate( rt_domain(did)%ORIFICEE(nsizes) ) + + if(nsizes .gt. 0) then + allocate( rt_domain(did)%accLndRunOff(nsizes) ) + allocate( rt_domain(did)%accQLateral(nsizes) ) + allocate( rt_domain(did)%accStrmvolrt(nsizes) ) + allocate( rt_domain(did)%accBucket(nsizes) ) + rt_domain(did)%accLndRunOff = 0 + rt_domain(did)%accQLateral = 0 + rt_domain(did)%accStrmvolrt = 0 + rt_domain(did)%accBucket = 0 + allocate( rt_domain(did)%QLateral(nsizes) ) + rt_domain(did)%QLateral = 0 + allocate( rt_domain(did)%velocity(nsizes) ) + rt_domain(did)%velocity = 0 + endif + + if( nlst_rt(did)%channel_option .eq. 1 .or. nlst_rt(did)%channel_option .eq. 2 ) then + NLINKS = rt_domain(did)%NLINKS + NLAKES = rt_domain(did)%NLAKES + endif + + allocate( rt_domain(did)%LINK(nsizes) ) + allocate( rt_domain(did)%STRMFRXSTPTS(nsizes) ) + allocate( rt_domain(did)%CHANXI(nsizes) ) + allocate( rt_domain(did)%CHANYJ(nsizes) ) + allocate( rt_domain(did)%CVOL(nsizes) ) + allocate( rt_domain(did)%LATLAKE(NLAKES) ) + allocate( rt_domain(did)%LONLAKE(NLAKES) ) + allocate( rt_domain(did)%ELEVLAKE(NLAKES) ) + allocate( rt_domain(did)%LAKENODE(nsizes) ) + allocate( rt_domain(did)%RESHT(NLAKES),STAT=istatus ) + allocate( rt_domain(did)%QLAKEI(NLAKES),STAT=istatus ) + allocate( rt_domain(did)%QLAKEO(NLAKES),STAT=istatus ) + + allocate( rt_domain(did)%HLINK(nsizes) ) !--used for diffusion only + + allocate( rt_domain(did)%node_area(nsizes) ) + +!!!! tmp + if(nsizes .gt. 0) then + rt_domain(did)%LINK = 0.0 + rt_domain(did)%gages = rt_domain(did)%gageMiss + rt_domain(did)%TO_NODE = 0.0 + rt_domain(did)%FROM_NODE = 0 + rt_domain(did)%TYPEL = -999 + rt_domain(did)%ORDER = 0.0 + rt_domain(did)%STRMFRXSTPTS = 0.0 + rt_domain(did)%MUSK = 0.0 + rt_domain(did)%MUSX = 0.0 + rt_domain(did)%CHANXI = 0.0 + rt_domain(did)%CHANYJ = 0.0 + rt_domain(did)%CHLAT = 0.0 !-latitutde of channel grid point + rt_domain(did)%CHLON = 0.0 !-longitude of channel grid point + rt_domain(did)%CHANLEN = 0.0 + rt_domain(did)%ChSSlp = 0.0 + rt_domain(did)%Bw = 0.0 + rt_domain(did)%ZELEV = 0.0 + rt_domain(did)%CVOL = 0.0 + rt_domain(did)%LAKEIDA = 0 + rt_domain(did)%LAKEIDX = 0 + + rt_domain(did)%LATLAKE = 0.0 + rt_domain(did)%LONLAKE = 0.0 + rt_domain(did)%ELEVLAKE = 0.0 + rt_domain(did)%LAKENODE = 0.0 + rt_domain(did)%RESHT = 0.0 + rt_domain(did)%QLAKEI = 0.0 + rt_domain(did)%QLAKEO = 0.0 + rt_domain(did)%QLINK = 0 +#ifdef WRF_HYDRO_NUDGING + rt_domain(did)%nudge = 0 +#endif + + rt_domain(did)%HLINK = 0.0 !--used for diffusion only + rt_domain(did)%MannN = 0.0 + rt_domain(did)%LINKID = 0.0 + + + rt_domain(did)%So = 0.01 + endif + + rt_domain(did)%restQSTRM = .true. + + END IF !IF/then for channel routing + + + !DJG Allocate routing and disaggregation arrays + allocate(rt_domain(did)%qinflowbase (IXRT,JXRT) ) + allocate(rt_domain(did)%gw_strm_msk (IXRT,JXRT) ) + allocate(rt_domain(did)%gw_strm_msk_lind (IXRT,JXRT) ) + +!!! allocate land surface grid variables + allocate( rt_domain(did)%SMC (IX,JX,NSOIL) ) + allocate( rt_domain(did)%SICE (IX,JX,NSOIL) ) +! allocate( rt_domain(did)%dist_lsm (ixrt,jxrt,9) ) +! allocate( rt_domain(did)%lat_lsm (ixrt,jxrt) ) +! allocate( rt_domain(did)%lon_lsm (ixrt,jxrt) ) + allocate( rt_domain(did)%dist_lsm (ix,jx,9) ) + allocate( rt_domain(did)%lat_lsm (ix,jx) ) + allocate( rt_domain(did)%lon_lsm (ix,jx) ) + +! allocate( rt_domain(did)%SICE (IX,JX,NSOIL) ) + allocate( rt_domain(did)%SMCMAX1 (IX,JX) ) + allocate( rt_domain(did)%STC (IX,JX,NSOIL) ) + allocate( rt_domain(did)%SH2OX(IX,JX,NSOIL) ) + allocate( rt_domain(did)%SMCWLT1 (IX,JX) ) + allocate( rt_domain(did)%SMCREF1 (IX,JX) ) + allocate( rt_domain(did)%VEGTYP (IX,JX) ) + allocate( rt_domain(did)%SOILTYP (IX,JX) ) + allocate( rt_domain(did)%GWSUBBASMSK (IX,JX) ) + allocate( rt_domain(did)%SLDPTH(NSOIL) ) + allocate( rt_domain(did)%SO8LD_D (IX,JX,3) ) + allocate( rt_domain(did)%SO8LD_Vmax (IX,JX) ) + allocate( rt_domain(did)%SFCHEADRT (IX,JX) ) + allocate( rt_domain(did)%INFXSRT (IX,JX) ) + allocate( rt_domain(did)%TERRAIN (IX,JX) ) + allocate( rt_domain(did)%LKSAT (IX,JX) ) + allocate( rt_domain(did)%SOLDRAIN (IX,JX) ) + + + rt_domain(did)%dist_lsm = 0.0 + + rt_domain(did)%qinflowbase = 0.0 + rt_domain(did)%gw_strm_msk = 0 + rt_domain(did)%SMC = 0.25 + rt_domain(did)%SICE = 0. +! rt_domain(did)%SMCMAX1 = 0.434 + rt_domain(did)%SMCMAX1 = 0.0 + rt_domain(did)%STC = 282.0 + rt_domain(did)%SH2OX = rt_domain(did)%SMC + rt_domain(did)%SMCWLT1 = 0.0 + rt_domain(did)%SMCREF1 = 0.0 + rt_domain(did)%VEGTYP = 0 + rt_domain(did)%GWSUBBASMSK = 0 + rt_domain(did)%SLDPTH = 0.0 + rt_domain(did)%SO8LD_D = 0.0 + rt_domain(did)%SO8LD_Vmax = 0.0 + rt_domain(did)%SFCHEADRT = 0.0 + rt_domain(did)%INFXSRT = 0.0 + rt_domain(did)%TERRAIN = 0.0 + rt_domain(did)%LKSAT = 0.0 + rt_domain(did)%SOLDRAIN = 0.0 + + rt_domain(did)%out_counts = 0 + rt_domain(did)%his_out_counts = 0 + rt_domain(did)%rst_counts = 1 + +#ifdef HYDRO_D + write(6,*) "***** finish rt_allocate " +#endif + + end subroutine rt_allocate + + subroutine getChanDim(did) + + + use module_namelist, only: nlst_rt + use module_RT_data, only: rt_domain + implicit none + + integer ixrt,jxrt, ix,jx, did, i,j + INTEGER, allocatable,dimension(:,:) :: CH_NETLNK, GCH_NETLNK +! INTEGER, dimension( rt_domain(did)%ixrt,GCH_NETLNK(ixrt,jxrt)) :: GCH_NETLNK, CH_NETLNK + + real :: Vmax + + ix = rt_domain(did)%ix + jx = rt_domain(did)%jx + ixrt = rt_domain(did)%ixrt + jxrt = rt_domain(did)%jxrt + + if(nlst_rt(did)%rtFlag .eq. 0) return + + allocate(CH_NETLNK(ixrt,jxrt)) + allocate(GCH_NETLNK(ixrt,jxrt)) + + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN !IF/then for channel routing +#ifdef MPP_LAND + CALL MPP_READ_ROUTEDIM(did, rt_domain(did)%g_IXRT,rt_domain(did)%g_JXRT, & + GCH_NETLNK, rt_domain(did)%GNLINKS, & +#else + CALL READ_ROUTEDIM( & +#endif + IXRT, JXRT, nlst_rt(did)%route_chan_f, nlst_rt(did)%route_link_f, & + nlst_rt(did)%route_direction_f, & + rt_domain(did)%NLINKS, & + CH_NETLNK, nlst_rt(did)%channel_option, nlst_rt(did)%geo_finegrid_flnm, & + rt_domain(did)%NLINKSL, nlst_rt(did)%udmp_opt ) +#ifndef MPP_LAND + call get_NLINKSL(rt_domain(did)%NLINKSL, nlst_rt(did)%channel_option, nlst_rt(did)%route_link_f) +#endif + + +#ifdef HYDRO_D + write(6,*) "before rt_allocate after READ_ROUTEDIM" +#endif + + + if(nlst_rt(did)%channel_option .eq. 1 .or. nlst_rt(did)%channel_option .eq. 2) then + rt_domain(did)%GNLINKSL = rt_domain(did)%NLINKSL + +#ifdef MPP_LAND + + call ReachLS_ini(rt_domain(did)%GNLINKSL,rt_domain(did)%nlinksl, & + rt_domain(did)%linklsS, rt_domain(did)%linklsE ) +#else + rt_domain(did)%linklsS = 1 + rt_domain(did)%linklsE = rt_domain(did)%NLINKSL +#endif + else + rt_domain(did)%GNLINKSL = 1 + rt_domain(did)%NLINKSL = 1 + endif + +#ifndef MPP_LAND + GCH_NETLNK = CH_NETLNK +#endif + + endif + + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + call read_NSIMLAKES(rt_domain(did)%NLAKES,nlst_rt(did)%route_lake_f) + endif + + call rt_allocate(did,rt_domain(did)%ix,rt_domain(did)%jx,& + rt_domain(did)%ixrt,rt_domain(did)%jxrt, nlst_rt(did)%nsoil,nlst_rt(did)%CHANRTSWCRT) + + + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN !IF/then for channel routing + rt_domain(did)%CH_NETLNK = CH_NETLNK + rt_domain(did)%GCH_NETLNK = GCH_NETLNK + endif + + if(allocated(CH_NETLNK)) deallocate(CH_NETLNK) + if(allocated(GCH_NETLNK)) deallocate(GCH_NETLNK) + + end subroutine getChanDim + +!=================================================================================================== +subroutine LandRT_ini(did) + +use module_noah_chan_param_init_rt +use module_namelist, only: nlst_rt +use module_RT_data, only: rt_domain +use module_gw_gw2d_data, only: gw2d +#ifdef HYDRO_D +use module_HYDRO_io, only: output_lake_types +#endif + +#ifdef OUTPUT_CHAN_CONN +use module_nudging_io, only: output_chan_connectivity +#endif + +implicit none + +integer :: did +real :: Vmax + +integer :: bas +character(len=19) :: header +character(len=1) :: jnk + +real, dimension(50) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table +integer :: i,j,k, ll, count + + integer, allocatable, dimension(:) :: tmp_int + real, allocatable, dimension(:) :: tmp_real + integer, allocatable, dimension(:) :: buf + real, allocatable, dimension(:) :: tmpRESHT + +#ifdef OUTPUT_CHAN_CONN +real :: connCalcTimeStart, connCalcTimeEnd +#endif +!------------------------------------------------------------------------ +!DJG Routing Processing +!------------------------------------------------------------------------ +!DJG IF/then to get routing terrain fields if either routing module is +!DJG activated + +if(nlst_rt(did)%rtFlag .eq. 0) return + +if (nlst_rt(did)%SUBRTSWCRT .eq.1 .or. & + nlst_rt(did)%OVRTSWCRT .eq.1 .or. & + nlst_rt(did)%GWBASESWCRT .ne. 0) then + +#ifdef HYDRO_D + print *, "Terrain routing initialization..." +#endif + + call READ_ROUTING_seq ( & + rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, & + rt_domain(did)%CH_LNKRT, & + rt_domain(did)%LKSATFAC,trim(nlst_rt(did)%route_topo_f),& + nlst_rt(did)%route_chan_f,nlst_rt(did)%geo_finegrid_flnm , & + rt_domain(did)%OVROUGHRTFAC,rt_domain(did)%RETDEPRTFAC, & + nlst_rt(did)%channel_option, nlst_rt(did)%udmp_opt) + + !yw CALL READ_ROUTING_old(rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, & + + if (nlst_rt(did)%CHANRTSWCRT.eq.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) then !IF/then for channel routing + +#ifdef MPP_LAND + CALL MPP_READ_CHROUTING_new( & +#else + CALL READ_CHROUTING1( & +#endif + rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, & + rt_domain(did)%CH_LNKRT, rt_domain(did)%LAKE_MSKRT, & + rt_domain(did)%FROM_NODE, rt_domain(did)%TO_NODE, rt_domain(did)%TYPEL, rt_domain(did)%ORDER, & + rt_domain(did)%MAXORDER,rt_domain(did)%NLINKS, & + rt_domain(did)%NLAKES, rt_domain(did)%MUSK, rt_domain(did)%MUSX, rt_domain(did)%QLINK,& + rt_domain(did)%CHANLEN, rt_domain(did)%MannN, rt_domain(did)%So, rt_domain(did)%ChSSlp, rt_domain(did)%Bw, & + rt_domain(did)%LAKEIDA, & + rt_domain(did)%HRZAREA, rt_domain(did)%LAKEMAXH, rt_domain(did)%WEIRH, rt_domain(did)%WEIRC, & + rt_domain(did)%WEIRL, rt_domain(did)%ORIFICEC, & + rt_domain(did)%ORIFICEA, rt_domain(did)%ORIFICEE, rt_domain(did)%LATLAKE, rt_domain(did)%LONLAKE, & + rt_domain(did)%ELEVLAKE, rt_domain(did)%LAKEIDM, rt_domain(did)%LAKEIDX, & + nlst_rt(did)%route_link_f,nlst_rt(did)%route_lake_f, & + nlst_rt(did)%route_direction_f, nlst_rt(did)%route_order_f, & + nlst_rt(did)%CHANRTSWCRT,rt_domain(did)%dist, rt_domain(did)%ZELEV, rt_domain(did)%LAKENODE, rt_domain(did)%CH_NETLNK, & + rt_domain(did)%CHANXI, rt_domain(did)%CHANYJ, & + rt_domain(did)%CHLAT, rt_domain(did)%CHLON, nlst_rt(did)%channel_option,& + rt_domain(did)%latval, rt_domain(did)%lonval,& + rt_domain(did)%STRMFRXSTPTS,nlst_rt(did)%geo_finegrid_flnm, rt_domain(did)%NLINKSL, rt_domain(did)%LINKID, rt_domain(did)%GNLINKSL & + ,nlst_rt(did)%UDMP_OPT & + +#ifdef MPP_LAND + ,rt_domain(did)%g_IXRT,rt_domain(did)%g_JXRT & + ,rt_domain(did)%gnlinks,rt_domain(did)%GCH_NETLNK, rt_domain(did)%map_l2g & + ,rt_domain(did)%link_location, rt_domain(did)%yw_mpp_nlinks,rt_domain(did)%lake_index,rt_domain(did)%nlinks_index & +#endif + ,rt_domain(did)%gages, rt_domain(did)%gageMiss ) + +!ADCHANGE: Add lake reach output +#ifdef HYDRO_D + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + call output_lake_types( rt_domain(did)%GNLINKSL, rt_domain(did)%LINKID, rt_domain(did)%TYPEL ) + endif +#endif + +#ifdef OUTPUT_CHAN_CONN +#ifdef MPP_LAND + connCalcTimeEnd = MPI_Wtime() +#else + call cpu_time(connCalcTimeEnd) +#endif + if (nlst_rt(did)%channel_option .eq. 3) then + call output_chan_connectivity( & + rt_domain(did)%CHLAT, & !! Channel grid lat + rt_domain(did)%CHLON, & !! Channel grid lat + rt_domain(did)%CHANLEN, & !! The distance between channel grid centers in m. + rt_domain(did)%FROM_NODE, & !! Index of a given cell and ... + rt_domain(did)%TO_NODE, & !! ... the index which it flows to. + rt_domain(did)%CHANXI, & !! Index on fine/routing + rt_domain(did)%CHANYJ, & !! grid of grid cells. + rt_domain(did)%TYPEL, & !! Link type + rt_domain(did)%LAKENODE & !! Lake indexing + ) + end if + + !if(my_id .eq. io_id) & + print '("Time to calculate channel connectivity= ",f6.3," seconds.")', & + connCalcTimeEnd-connCalcTimeStart + call exit(17) !! bail if you're just calculating output connectivity. +#endif +! end OUTPUT_CHAN_CONN + + + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + ! get NHDPLUS mapping function. +! call UDMP_ini(rt_domain(did)%GNLINKSL,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%CH_LNKRT , & + call UDMP_ini(rt_domain(did)%GNLINKSL,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%CH_NETRT , & + nlst_rt(did)%OVRTSWCRT, nlst_rt(did)%SUBRTSWCRT, rt_domain(did)%dist(:,:,9) ) +#ifdef HYDRO_D + write(6,*) "after UDMP_ini " + call flush(6) +#endif + endif + + if (nlst_rt(did)%channel_option .eq. 1 .or. nlst_rt(did)%channel_option .eq. 2) then +#ifdef MPP_LAND + if(nlst_rt(did)%UDMP_OPT .eq. 1) then + ! NHDPLUS + rt_domain(did)%LNLINKSL = LNUMRSL + allocate(rt_domain(did)%LLINKID(rt_domain(did)%LNLINKSL)) + do k = 1,LNUMRSL + rt_domain(did)%LLINKID(k) = LUDRSL(k)%myid + end do + else + allocate (buf(rt_domain(did)%GNLINKS) ) + buf = -99 + do j = 1, rt_domain(did)%jxrt + do i = 1, rt_domain(did)%ixrt + if( .not. ( (i .eq. 1 .and. left_id .ge. 0) .or. (i .eq. rt_domain(did)%ixrt .and. right_id .ge. 0) .or. & + (j .eq. 1 .and. down_id .ge. 0) .or. (j .eq. rt_domain(did)%jxrt .and. up_id .ge. 0) ) ) then + if(rt_domain(did)%CH_LNKRT(i,j) .gt. 0) then + k = rt_domain(did)%CH_LNKRT(i,j) + buf(k) = k + endif + endif + end do + end do + + rt_domain(did)%LNLINKSL = 0 + do k = 1, rt_domain(did)%GNLINKS + if(buf(k) .gt. 0) then + rt_domain(did)%LNLINKSL = rt_domain(did)%LNLINKSL + 1 + endif + end do + +#ifdef HYDRO_D + write(6,*) "LNLINKSL, NLINKS, GNLINKS =",rt_domain(did)%LNLINKSL,rt_domain(did)%NLINKSL,rt_domain(did)%GNLINKSL + call flush(6) +#endif + + allocate(rt_domain(did)%LLINKID(rt_domain(did)%LNLINKSL)) + + k = 0 + do i = 1, rt_domain(did)%GNLINKS + if(buf(i) .gt. 0) then + k = k + 1 + rt_domain(did)%LLINKID(k) = buf(i) + endif + end do + + if(allocated(buf)) deallocate(buf) + + endif ! end if block for UDMP_OPT + + do k = 1, rt_domain(did)%LNLINKSL + do j = 1, rt_domain(did)%jxrt + do i = 1, rt_domain(did)%ixrt + if( .not. ( (i .eq. 1 .and. left_id .ge. 0) .or. (i .eq. rt_domain(did)%ixrt .and. right_id .ge. 0) .or. & + (j .eq. 1 .and. down_id .ge. 0) .or. (j .eq. rt_domain(did)%jxrt .and. up_id .ge. 0) ) ) then + if(rt_domain(did)%CH_LNKRT(i,j) .eq. rt_domain(did)%LLINKID(k) ) then + rt_domain(did)%CH_LNKRT_SL(i,j) = k !! mapping + endif + endif + end do + end do + end do + + call getLocalIndx(rt_domain(did)%gnlinksl,rt_domain(did)%LINKID, rt_domain(did)%LLINKID) + + call getToInd(rt_domain(did)%LINKID,rt_domain(did)%to_node,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd,rt_domain(did)%gtoNode) +#else + do k = 1, rt_domain(did)%NLINKSL + do j = 1, rt_domain(did)%jxrt + do i = 1, rt_domain(did)%ixrt + if(rt_domain(did)%CH_LNKRT(i,j) .eq. rt_domain(did)%LINKID(k) ) then + rt_domain(did)%CH_LNKRT_SL(i,j) = k !! mapping + endif + end do + end do + end do + +#endif + +!!$ ! use gage information in RouteLink like strmfrxstpts +!!$ rt_domain(did)%STRMFRXSTPTS = -9999 !! existing info useless for link-based routing +!!$ count = 1 +!!$ do ll=1,rt_domain(did)%NLINKSL +!!$ if(trim(rt_domain(did)%gages(ll)) .ne. trim(rt_domain(did)%gageMiss)) then +!!$ rt_domain(did)%STRMFRXSTPTS(count) = ll +!!$ count = count + 1 +!!$ end if +!!$ end do + + endif ! end of channel option if block + + endif + END IF + + +!yw allocate(tmp_int(rt_domain(did)%GNLINKS)) +!yw allocate(tmp_real(rt_domain(did)%GNLINKS)) + + + +!DJG Temporary hardwire of RETDEPRT,RETDEP_CHAN +!DJG will later make this a function of SOLTYP and VEGTYP +! OVROUGHRT(i,j) = 0.01 + +rt_domain(did)%RETDEPRT = 0.001 ! units (mm) +rt_domain(did)%RETDEP_CHAN = 0.001 + + +!DJG Need to insert call for acquiring routing fields here... +!DJG include as a subroutine in module module_Noahlsm_wrfcode_input.F +!DJG Calculate terrain slopes 'SOXRT,SOYRT' from subgrid elevation 'ELRT' + + +rt_domain(did)%so8rt = -999 +Vmax = 0.0 +do j=2,rt_domain(did)%JXRT-1 + do i=2,rt_domain(did)%IXRT-1 + rt_domain(did)%SOXRT(i,j)=(rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j))/rt_domain(did)%dist(i,j,3) + rt_domain(did)%SOYRT(i,j)=(rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j+1))/rt_domain(did)%dist(i,j,1) + !DJG Introduce reduction in retention depth as a linear function of terrain slope + if (nlst_rt(did)%RT_OPTION.eq.2) then + if (rt_domain(did)%SOXRT(i,j).gt.rt_domain(did)%SOYRT(i,j)) then + Vmax=rt_domain(did)%SOXRT(i,j) + else + Vmax=rt_domain(did)%SOYRT(i,j) + end if + + if (Vmax.gt.0.1) then + rt_domain(did)%RETDEPRT(i,j)=0. + else + rt_domain(did)%RETDEPFRAC=Vmax/0.1 + rt_domain(did)%RETDEPRT(i,j)=rt_domain(did)%RETDEPRT(i,j)*(1.-rt_domain(did)%RETDEPFRAC) + if (rt_domain(did)%RETDEPRT(i,j).lt.0.) rt_domain(did)%RETDEPRT(i,j)=0. + end if + end if + + rt_domain(did)%SO8RT(i,j,1) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j+1))/rt_domain(did)%dist(i,j,1) + rt_domain(did)%SO8RT_D(i,j,1) = i + rt_domain(did)%SO8RT_D(i,j,2) = j + 1 + rt_domain(did)%SO8RT_D(i,j,3) = 1 + Vmax = rt_domain(did)%SO8RT(i,j,1) + + rt_domain(did)%SO8RT(i,j,2) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j+1))/rt_domain(did)%dist(i,j,2) + if(rt_domain(did)%SO8RT(i,j,2) .gt. Vmax ) then + rt_domain(did)%SO8RT_D(i,j,1) = i + 1 + rt_domain(did)%SO8RT_D(i,j,2) = j + 1 + rt_domain(did)%SO8RT_D(i,j,3) = 2 + Vmax = rt_domain(did)%SO8RT(i,j,2) + end if + + rt_domain(did)%SO8RT(i,j,3) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j))/rt_domain(did)%dist(i,j,3) + if(rt_domain(did)%SO8RT(i,j,3) .gt. Vmax ) then + rt_domain(did)%SO8RT_D(i,j,1) = i + 1 + rt_domain(did)%SO8RT_D(i,j,2) = j + rt_domain(did)%SO8RT_D(i,j,3) = 3 + Vmax = rt_domain(did)%SO8RT(i,j,3) + end if + + rt_domain(did)%SO8RT(i,j,4) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j-1))/rt_domain(did)%dist(i,j,4) + if(rt_domain(did)%SO8RT(i,j,4) .gt. Vmax ) then + rt_domain(did)%SO8RT_D(i,j,1) = i + 1 + rt_domain(did)%SO8RT_D(i,j,2) = j - 1 + rt_domain(did)%SO8RT_D(i,j,3) = 4 + Vmax = rt_domain(did)%SO8RT(i,j,4) + end if + + rt_domain(did)%SO8RT(i,j,5) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j-1))/rt_domain(did)%dist(i,j,5) + if(rt_domain(did)%SO8RT(i,j,5) .gt. Vmax ) then + rt_domain(did)%SO8RT_D(i,j,1) = i + rt_domain(did)%SO8RT_D(i,j,2) = j - 1 + rt_domain(did)%SO8RT_D(i,j,3) = 5 + Vmax = rt_domain(did)%SO8RT(i,j,5) + end if + + rt_domain(did)%SO8RT(i,j,6) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j-1))/rt_domain(did)%dist(i,j,6) + if(rt_domain(did)%SO8RT(i,j,6) .gt. Vmax ) then + rt_domain(did)%SO8RT_D(i,j,1) = i - 1 + rt_domain(did)%SO8RT_D(i,j,2) = j - 1 + rt_domain(did)%SO8RT_D(i,j,3) = 6 + Vmax = rt_domain(did)%SO8RT(i,j,6) + end if + + rt_domain(did)%SO8RT(i,j,7) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j))/rt_domain(did)%dist(i,j,7) + if(rt_domain(did)%SO8RT(i,j,7) .gt. Vmax ) then + rt_domain(did)%SO8RT_D(i,j,1) = i - 1 + rt_domain(did)%SO8RT_D(i,j,2) = j + rt_domain(did)%SO8RT_D(i,j,3) = 7 + Vmax = rt_domain(did)%SO8RT(i,j,7) + end if + + rt_domain(did)%SO8RT(i,j,8) = & + (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j+1))/rt_domain(did)%dist(i,j,8) + if(rt_domain(did)%SO8RT(i,j,8) .gt. Vmax ) then + rt_domain(did)%SO8RT_D(i,j,1) = i - 1 + rt_domain(did)%SO8RT_D(i,j,2) = j + 1 + rt_domain(did)%SO8RT_D(i,j,3) = 8 + Vmax = rt_domain(did)%SO8RT(i,j,8) + end if + + !DJG Introduce reduction in retention depth as a linear function of terrain slope + if (nlst_rt(did)%RT_OPTION.eq.1) then + if (Vmax.gt.0.75) then + rt_domain(did)%RETDEPRT(i,j)=0. + else + rt_domain(did)%RETDEPFRAC=Vmax/0.75 + rt_domain(did)%RETDEPRT(i,j)=rt_domain(did)%RETDEPRT(i,j)*(1.-rt_domain(did)%RETDEPFRAC) + if (rt_domain(did)%RETDEPRT(i,j).lt.0.) rt_domain(did)%RETDEPRT(i,j)=0. + end if + end if + + + end do +end do + + +!Apply calibration scaling factors to sfc roughness and retention depth here... +rt_domain(did)%RETDEPRT = rt_domain(did)%RETDEPRT * rt_domain(did)%RETDEPRTFAC +rt_domain(did)%OVROUGHRT = rt_domain(did)%OVROUGHRT * rt_domain(did)%OVROUGHRTFAC + + +! calculate the slope for boundary +#ifdef MPP_LAND +if(right_id .lt. 0) rt_domain(did)%SOXRT(rt_domain(did)%IXRT,:)= & + rt_domain(did)%SOXRT(rt_domain(did)%IXRT-1,:) +if(left_id .lt. 0) rt_domain(did)%SOXRT(1,:)=rt_domain(did)%SOXRT(2,:) +if(up_id .lt. 0) rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT)= & + rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT-1) +if(down_id .lt. 0) rt_domain(did)%SOYRT(:,1)=rt_domain(did)%SOYRT(:,2) +#else +rt_domain(did)%SOXRT(rt_domain(did)%IXRT,:)=rt_domain(did)%SOXRT(rt_domain(did)%IXRT-1,:) +rt_domain(did)%SOXRT(1,:)=rt_domain(did)%SOXRT(2,:) +rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT)=rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT-1) +rt_domain(did)%SOYRT(:,1)=rt_domain(did)%SOYRT(:,2) +#endif + +#ifdef MPP_LAND +! communicate the value to +call MPP_LAND_COM_REAL(rt_domain(did)%RETDEPRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) +call MPP_LAND_COM_REAL(rt_domain(did)%SOXRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) +call MPP_LAND_COM_REAL(rt_domain(did)%SOYRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) +do i = 1, 8 + call MPP_LAND_COM_REAL(rt_domain(did)%SO8RT(:,:,i),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) +end do +do i = 1, 3 + call MPP_LAND_COM_INTEGER(rt_domain(did)%SO8RT_D(:,:,i),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99) +end do +#endif + + +if(nlst_rt(did)%UDMP_OPT .eq. 1) then + allocate (rt_domain(did)%qout_gwsubbas (rt_domain(did)%nlinksL)) + rt_domain(did)%qout_gwsubbas = 0 + ! use different baseflow for NHDPlus + IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN + rt_domain(did)%numbasns = rt_domain(did)%NLINKSL + RT_DOMAIN(did)%gnumbasns = rt_domain(did)%gNLINKSL + + allocate (rt_domain(did)%z_gwsubbas (rt_domain(did)%numbasns )) + allocate (rt_domain(did)%nhdBuckMask(rt_domain(did)%numbasns )) ! default is -999 + + allocate (rt_domain(did)%qin_gwsubbas (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%gwbas_pix_ct (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%ct2_bas (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%bas_pcp (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%gw_buck_coeff (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%bas_id (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%gw_buck_exp(rt_domain(did)%numbasns)) + allocate (rt_domain(did)%z_max (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%basns_area (rt_domain(did)%numbasns)) + + rt_domain(did)%qin_gwsubbas = 0 + rt_domain(did)%z_gwsubbas = 0 + rt_domain(did)%gwbas_pix_ct = 0 + rt_domain(did)%bas_pcp = 0 + + rt_domain(did)%gw_buck_coeff = 0.04 + rt_domain(did)%gw_buck_exp = 0.2 + rt_domain(did)%z_max = 0.1 + +!Temporary hardwire... + rt_domain(did)%z_gwsubbas = 0.05 ! This gets updated with spun-up GW level in GWBUCKPARM.TBL + + call readBucket_nhd(trim(nlst_rt(did)%GWBUCKPARM_file), rt_domain(did)%numbasns, & + rt_domain(did)%gw_buck_coeff, rt_domain(did)%gw_buck_exp, & + rt_domain(did)%z_max, rt_domain(did)%LINKID(1:rt_domain(did)%numbasns), & + rt_domain(did)%nhdBuckMask ) +#ifdef HYDRO_D + write(6,*) "finish readBucket_nhd " + call flush(6) +#endif + endif +else +!--------------------------------------------------------------------- +!DJG If GW/Baseflow activated...Read in req'd fields... +!---------------------------------------------------------------------- +if (nlst_rt(did)%GWBASESWCRT.ge.1) then + if (nlst_rt(did)%GWBASESWCRT.eq.1.or.nlst_rt(did)%GWBASESWCRT.eq.2) then +#ifdef HYDRO_D + print *, "new Simple GW-Bucket Scheme selected, retrieving files..." +#endif +#ifdef MPP_LAND + call MPP_READ_SIMP_GW( & +#else + call READ_SIMP_GW( & +#endif + rt_domain(did)%IX,rt_domain(did)%JX,rt_domain(did)%IXRT,& + rt_domain(did)%JXRT,rt_domain(did)%GWSUBBASMSK,nlst_rt(did)%gwbasmskfil,& + rt_domain(did)%gw_strm_msk,rt_domain(did)%numbasns,rt_domain(did)%ch_netrt,nlst_rt(did)%AGGFACTRT) + + + call SIMP_GW_IND(rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%GWSUBBASMSK, & + rt_domain(did)%numbasns,rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd) + +#ifdef HYDRO_D + write(6,*) "rt_domain(did)%gnumbasns, rt_domain(did)%numbasns, ", rt_domain(did)%gnumbasns , rt_domain(did)%numbasns + +#endif +#ifdef MPP_LAND + call collectSizeInd(rt_domain(did)%numbasns) +#endif + + call get_gw_strm_msk_lind (rt_domain(did)%IXRT, rt_domain(did)%JXRT, rt_domain(did)%gw_strm_msk,& + rt_domain(did)%numbasns,rt_domain(did)%basnsInd,rt_domain(did)%gw_strm_msk_lind) + + + allocate (rt_domain(did)%qout_gwsubbas (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%qin_gwsubbas (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%z_gwsubbas (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%gwbas_pix_ct (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%ct2_bas (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%bas_pcp (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%gw_buck_coeff (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%bas_id (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%gw_buck_exp(rt_domain(did)%numbasns)) + allocate (rt_domain(did)%z_max (rt_domain(did)%numbasns)) + allocate (rt_domain(did)%basns_area (rt_domain(did)%numbasns)) + +#ifdef HYDRO_D + write(6,*) "end Simple GW-Bucket ..." + print *, "Simple GW-Bucket Scheme selected, retrieving files..." +#endif + +!Temporary hardwire... + rt_domain(did)%z_gwsubbas = 1. ! This gets updated with spun-up GW level in GWBUCKPARM.TBL + + + call read_GWBUCKPARM(rt_domain(did)%numbasns,rt_domain(did)%gnumbasns, rt_domain(did)%basnsInd, & + rt_domain(did)%gw_buck_coeff, rt_domain(did)%gw_buck_exp, rt_domain(did)%z_max, & + rt_domain(did)%z_gwsubbas, rt_domain(did)%bas_id,rt_domain(did)%basns_area) + + + +!!! Determine number of stream pixels per GW basin for distribution... + +#ifdef MPP_LAND + call pix_ct_1(rt_domain(did)%gw_strm_msk,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%gwbas_pix_ct,rt_domain(did)%numbasns, & + rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd) +#else + rt_domain(did)%gwbas_pix_ct = 0. +! do k = 1, rt_domain(did)%numbasns +! bas = rt_domain(did)%basnsInd(k) + do i=1,rt_domain(did)%ixrt + do j=1,rt_domain(did)%jxrt + if (rt_domain(did)%gw_strm_msk(i,j).gt.0) then + bas = rt_domain(did)%gw_strm_msk(i,j) + rt_domain(did)%gwbas_pix_ct(bas) = & + rt_domain(did)%gwbas_pix_ct(bas) + 1.0 + endif + end do + end do +! end do +#endif + + +#ifdef HYDRO_D + print *, "Starting GW basin levels...",rt_domain(did)%z_gwsubbas +#endif + + + ! BF gw2d model + elseif (nlst_rt(did)%GWBASESWCRT.ge.3) then + + call readGW2d(gw2d(did)%ix, gw2d(did)%jx, & + gw2d(did)%hycond, gw2d(did)%ho, & + gw2d(did)%bot, gw2d(did)%poros, & + gw2d(did)%ltype, nlst_rt(did)%gwIhShift) + + gw2d(did)%elev = rt_domain(did)%elrt + + end if + +end if +!--------------------------------------------------------------------- +!DJG End if GW/Baseflow activated... +!---------------------------------------------------------------------- +endif !!! end if block for UDMP_OPT .eq. 1 + + + +!--------------------------------------------------------------------- +!DJG,DNY If channel routing activated... +!---------------------------------------------------------------------- + +if (nlst_rt(did)%CHANRTSWCRT.eq.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) then + + !--------------------------------------------------------------------- + !DJG,DNY Initalize lake and channel heights, this may be overwritten by RESTART + !-------------------------------------------------------------------- + + if (nlst_rt(did)%channel_option .eq. 3) then +#ifdef MPP_LAND + call mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) !Read chan parms from table... +#else + call CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) !Read chan parms from table... +#endif + end if + if (nlst_rt(did)%channel_option .ne. 3) then +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + allocate(tmpRESHT(rt_domain(did)%nlakes)) + tmpRESHT = rt_domain(did)%RESHT +#ifdef MPP_LAND + endif +#endif + do j=1,rt_domain(did)%NLINKSL + do k = 1, rt_domain(did)%NLAKES + if(rt_domain(did)%LAKEIDM(k) .eq. rt_domain(did)%LINKID(j)) then + if (rt_domain(did)%TYPEL(j) .eq. 1) then !- for sparse network method this is a lake (type 0 is river) + rt_domain(did)%RESHT(k) = rt_domain(did)%LAKEMAXH(k) * 0.935 !-- assumes lake is ~90% MA, should put in Lake Parm + endif + endif + end do + end do +#ifdef MPP_LAND + call updateLake_seq(rt_domain(did)%RESHT, rt_domain(did)%NLAKES,tmpRESHT) + if(my_id .eq. io_id) then + if(allocated(tmpRESHT)) deallocate(tmpRESHT) + endif +#endif + + else !-- parameterize according to order of diffusion scheme, or if read from hi res file, use its value + !-- put condition within the if/then structure, which will assign a value if something is missing in hi res + do j=1,rt_domain(did)%NLINKS + + if (rt_domain(did)%ORDER(j) .eq. 1) then !-- smallest stream reach + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j)) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j)) + elseif (rt_domain(did)%ORDER(j) .eq. 2) then + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j)) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j)) + elseif (rt_domain(did)%ORDER(j) .eq. 3) then + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j)) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j)) + elseif (rt_domain(did)%ORDER(j) .eq. 4) then + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j)) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j)) + elseif (rt_domain(did)%ORDER(j) .eq. 5) then + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j)) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j)) + elseif (rt_domain(did)%ORDER(j) .eq. 6) then + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j)) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j)) + elseif (rt_domain(did)%ORDER(j) .ge. 7) then + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j)) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j)) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j)) + else !-- the outlets won't have orders since there's no nodes, so + !-- assign the order 5 values + + if(rt_domain(did)%Bw(j) .eq. 0.0) then + rt_domain(did)%Bw(j) = BOTWID(5) + endif + if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then !if id didn't get set from the hi res file, use the CHANPARAM + rt_domain(did)%ChSSlp(j) = CHAN_SS(5) + endif + if(rt_domain(did)%MannN(j) .eq. 0.0) then + rt_domain(did)%MannN(j) = CHMann(5) + endif + rt_domain(did)%HLINK(j) = HLINK_INIT(5) + endif + + rt_domain(did)%CVOL(j) = (rt_domain(did)%Bw(j)+ 1/rt_domain(did)%ChSSLP(j)*rt_domain(did)%HLINK(j))*rt_domain(did)%HLINK(j)*rt_domain(did)%CHANLEN(j) !-- initalize channel volume + end do + endif !Endif channel option eq 3 + + do j=1,rt_domain(did)%NLAKES + rt_domain(did)%RESHT(j) = rt_domain(did)%LAKEMAXH(j) * 0.935 !-- lake is 99% full at start + end do + +end if ! Endif for channel routing setup +!----------------------------------------------------------------------- + +rt_domain(did)%INFXSWGT = 1./(nlst_rt(did)%AGGFACTRT*nlst_rt(did)%AGGFACTRT) +rt_domain(did)%SH2OWGT = 1. +rt_domain(did)%SOLDEPRT = -1.0 * nlst_rt(did)%ZSOIL8(nlst_rt(did)%NSOIL) +rt_domain(did)%QSUBRT = 0.0 +rt_domain(did)%ZWATTABLRT = 0.0 +rt_domain(did)%QSUBBDRYRT = 0.0 +rt_domain(did)%QSTRMVOLRT = 0.0 +rt_domain(did)%QSTRMVOLRT = 0.0 +rt_domain(did)%QBDRYRT = 0.0 +rt_domain(did)%SFCHEADSUBRT = 0.0 +rt_domain(did)%INFXSUBRT = 0.0 +rt_domain(did)%DHRT = 0.0 +rt_domain(did)%LAKE_INFLORT = 0.0 +! rt_domain(did)%LAKE_INFLORT_DUM = 0.0 +rt_domain(did)%LAKE_CT = 0 +rt_domain(did)%STRM_CT = 0 +! rt_domain(did)%QSTRMVOLRT_DUM = 0.0 +rt_domain(did)%SOLDRAIN = 0.0 +rt_domain(did)%qinflowbase = 0.0 + +! rt_domain(did)%BASIN_MSK = 1 +! !DJG Initialize mass balance check variables... +rt_domain(did)%SMC_INIT=0. +rt_domain(did)%DSMC=0. +rt_domain(did)%DACRAIN=0. +rt_domain(did)%DSFCEVP=0. +rt_domain(did)%DCANEVP=0. +rt_domain(did)%DEDIR=0. +rt_domain(did)%DETT=0. +rt_domain(did)%DEPND=0. +rt_domain(did)%DESNO=0. +rt_domain(did)%DSFCRNFF=0. +rt_domain(did)%DQBDRY=0. +rt_domain(did)%SUMINFXS1=0. + +end subroutine LandRT_ini + + subroutine deriveFromNode(did) + implicit none + integer :: did + integer :: i,j, kk, maxv + integer :: tmp(rt_domain(did)%nlinks) + tmp = 0 + maxv = 1 + do i = 1, rt_domain(did)%nlinks + if(rt_domain(did)%to_node(i) .gt. 0) then + kk = rt_domain(did)%to_node(i) + tmp(kk) = tmp(kk) + 1 + if(maxv .lt. tmp(kk)) maxv = tmp(kk) + end if + end do + allocate(rt_domain(did)%pnode(rt_domain(did)%nlinks,maxv+1) ) + rt_domain(did)%maxv_p = maxv+1 + rt_domain(did)%pnode = -99 + rt_domain(did)%pnode(:,1) = 1 + do i = 1, rt_domain(did)%nlinks + if(rt_domain(did)%to_node(i) .gt. 0) then + j = rt_domain(did)%to_node(i) + rt_domain(did)%pnode(j,1) = rt_domain(did)%pnode(j,1) + 1 + kk = rt_domain(did)%pnode(j,1) + rt_domain(did)%pnode(j,kk) = i + end if + end do + + end subroutine deriveFromNode + + + +END MODULE module_Routing diff --git a/wrfv2_fire/hydro/Routing/module_UDMAP.F b/wrfv2_fire/hydro/Routing/module_UDMAP.F new file mode 100644 index 00000000..e2983ddb --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_UDMAP.F @@ -0,0 +1,569 @@ +! Program Name: +! 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: + +! This subrouting includs the data structure and tools used for NHDPlus network mapping. +module module_UDMAP + +use module_namelist, only: nlst_rt +#ifdef MPP_LAND +use module_mpp_land, only: my_id, local_startx_rt, local_starty_rt, & + local_endx_rt,local_endy_rt, left_id, right_id, down_id, up_id, mpp_collect_1d_int_mem, & + IO_id , numprocs +use module_mpp_land, only: mpp_land_bcast_int, mpp_land_bcast_real8_1d, mpp_land_bcast_int1 + +use module_mpp_land, only: sum_int1d, global_rt_nx, global_rt_ny, write_IO_rt_int, MPP_LAND_COM_INTEGER + +use MODULE_mpp_ReachLS, only : updatelinkv, ReachLS_write_io, com_write1dInt, & + com_decomp1dInt, pack_decomp_int, pack_decomp_real8 + +#endif + +implicit none + +#ifndef MPP_LAND + integer, parameter :: numprocs=1 +#endif + +#include + +type userDefineMapping + integer, allocatable, dimension(:) :: grid_i, grid_j + real, allocatable, dimension(:) :: weight, nodeArea, cellArea + integer :: ngrids + integer :: myid +! for bucket model definition + real, allocatable, dimension(:) :: cellWeight + integer, allocatable, dimension(:) :: cell_i, cell_j + integer :: ncell +end type userDefineMapping + +TYPE ( userDefineMapping ), allocatable, DIMENSION (:) :: LUDRSL + +integer, allocatable, dimension(:) :: bufid +real*8 , allocatable, dimension(:) :: bufw +integer :: LNUMRSL ! number of local links +integer :: ter_rt_flag +real*8, allocatable, dimension(:) :: basns_area +integer :: gnpid, lnsize +integer, allocatable, dimension(:) :: bufi,bufj + +contains + subroutine UDMP_ini(nlinksl,ixrt,jxrt,rtmask, OVRTSWCRT, SUBRTSWCRT,cell_area) +!This is the driver for user defined mapping file funciton application. + integer :: ixrt, jxrt, OVRTSWCRT, SUBRTSWCRT, nlinksl + integer, intent(in), dimension(ixrt,jxrt):: rtmask + integer :: npid !local variable. + real,dimension(:,:) :: cell_area + ter_rt_flag = 0 + if(OVRTSWCRT .eq. 1 .or. SUBRTSWCRT .eq. 1) then + ter_rt_flag = 1 + endif + call readUDMP(ixrt,jxrt,npid,nlinksl) + call UDMP2LOCAL(npid,ixrt,jxrt,rtmask, ter_rt_flag) + call getUDMP_area(cell_area) + end subroutine UDMP_ini + + subroutine readUDMP(ixrt,jxrt,npid, nlinksl) + implicit none + integer :: i,j,Ndata, did, Npid, nlinksl, k, m, kk + integer,allocatable,dimension(:) :: g1bufid, gbufid, linkid ,bufidflag, & + bufid_tmp, nprocs_map, lnsizes, istart + integer :: ix_bufid, ii, ixrt,jxrt + integer, allocatable, dimension(:) :: gbufi,gbufj,bufsize + real*8 , allocatable, dimension(:) :: gbufw + + did = 1 + call get_dimension(trim(nlst_rt(did)%UDMAP_FILE), ndata, npid) + +#ifdef MPP_LAND + gnpid = npid + allocate (lnsizes(numprocs)) + if(my_id .eq. io_id) then + allocate (istart(numprocs)) + allocate (nprocs_map(ndata)) + allocate(gbufi(ndata)) + allocate(gbufj(ndata)) + call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"i_index",gbufi) + call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"j_index",gbufj) + endif + call get_nprocs_map(ixrt,jxrt,gbufi,gbufj,nprocs_map,ndata) + + if(my_id .eq. io_id) then + lnsizes = 0 + do i =1 , ndata + if(nprocs_map(i) .gt. 0) then + lnsizes(nprocs_map(i)) = lnsizes(nprocs_map(i)) + 1 + endif + enddo + endif + call mpp_land_bcast_int(numprocs,lnsizes) + + if(my_id .eq. io_id ) then + kk = 0 + do i = 1, numprocs + kk = kk + lnsizes(i) + end do + end if + + if(my_id .eq. IO_id) then + ii = 1 + do i = 1, numprocs + istart(i) = ii + if(lnsizes(i) .gt. 0) then + ii = lnsizes(i) + ii + else + istart(i) = -999 + endif + end do + endif + + if(lnsizes(my_id+1) .gt. 0) allocate(bufi(lnsizes(my_id+1) )) + call pack_decomp_int(gbufi, ndata, nprocs_map, lnsizes, istart,bufi) + if(my_id .eq. io_id) then + if(allocated(gbufi)) deallocate(gbufi) + endif + + + if(lnsizes(my_id+1) .gt. 0) allocate(bufj(lnsizes(my_id+1) )) + call pack_decomp_int(gbufj, ndata, nprocs_map, lnsizes, istart,bufj) + if(my_id .eq. io_id) then + if(allocated(gbufj)) deallocate(gbufj) + endif + + +! check bufid +! check polyid and linkid + allocate(linkid(nlinksl)) + if(my_id .eq. io_id) then + call get1d_int(trim(nlst_rt(did)%route_link_f),"link",linkid) + allocate(gbufid(npid)) + call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"polyid",gbufid) + endif +#ifdef MPP_LAND + if(nlinksl .gt. 0) then + call mpp_land_bcast_int(nlinksl,linkid) + endif + call com_decomp1dInt(gbufid,npid,bufid_tmp,ix_bufid) +#endif + if(ix_bufid .gt. 0) then + allocate(bufidflag(ix_bufid)) + bufidflag = -999 + endif + + do i = 1, ix_bufid + do j = 1, nlinksl + if(bufid_tmp(i) .eq. linkid(j)) then + bufidflag(i) = bufid_tmp(i) + goto 102 + endif + end do +102 continue + end do + +#ifdef MPP_LAND + call com_write1dInt(bufidflag,ix_bufid,gbufid,npid) +#endif + if(ix_bufid .gt. 0) then + if(allocated(bufidflag)) deallocate(bufidflag) + if(allocated(bufid_tmp)) deallocate(bufid_tmp) + endif + if(allocated(linkid)) deallocate(linkid) + if(my_id .eq. io_id) then + allocate(bufsize(npid)) + allocate(g1bufid(ndata)) + call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"overlaps",bufsize) + g1bufid = -999 + i = 1 + do k = 1, npid + do j = 1, bufsize(k) + g1bufid(i) = gbufid(k) + i = i + 1 + end do + enddo + if(allocated(bufsize)) deallocate(bufsize) + endif + + + if(my_id .eq. io_id) then + if(allocated(gbufid)) deallocate(gbufid) + endif + + + if(lnsizes(my_id+1) .gt. 0) allocate(bufid(lnsizes(my_id+1) )) + call pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) + if(my_id .eq. io_id) then + if(allocated(g1bufid)) deallocate(g1bufid) + endif + + + if(my_id .eq. io_id) then + allocate(gbufw(ndata)) + call get1d_real8(trim(nlst_rt(did)%UDMAP_FILE),"regridweight",gbufw) + endif + if(lnsizes(my_id+1) .gt. 0) allocate(bufw(lnsizes(my_id+1) )) + call pack_decomp_real8(gbufw, ndata, nprocs_map, lnsizes, istart,bufw) + if(my_id .eq. io_id) then + if(allocated(gbufw)) deallocate(gbufw) + endif + + + if(my_id .eq. io_id) then + if(allocated(nprocs_map)) deallocate (nprocs_map) + if(allocated(istart)) deallocate (istart) + endif + lnsize = lnsizes(my_id + 1) + if(allocated(lnsizes)) deallocate(lnsizes) +#else + call hydro_stop("FATAL ERROR in UDMP : sequential not defined.") +#endif + + end subroutine readUDMP + + subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) + implicit none + integer :: i,j,k, ngrids, ix,jx, starti,startj, endi,endj, ii,jj, npid, kk + integer, intent(in), dimension(ix,jx) :: rtmask + integer, dimension(lnsize) :: lndflag,gridflag , tmpgridflag + integer :: ter_rt_flag, m, c + + +! find ngrids is 0 so that we need to mapping from subsurface runoff. +#ifdef MPP_LAND + if(left_id .ge. 0) then + starti = local_startx_rt + 1 + else + starti = local_startx_rt + endif + if(down_id .ge. 0) then + startj = local_starty_rt + 1 + else + startj = local_starty_rt + endif + if(right_id .ge. 0) then + endi = local_startx_rt + ix -2 + else + endi = local_startx_rt + ix -1 + endif + if(up_id .ge. 0) then + endj = local_starty_rt + jx -2 + else + endj = local_starty_rt + jx -1 + endif +#else + starti = 1 + startj = 1 + endi = ix + endj = jx +#endif + gridflag = 0 + lndflag = 0 + +#ifdef MPP_LAND + k = 0 + do i = 1, lnsize + if(bufid(i) .gt. 0) then + if(bufi(i) .ge. starti .and. bufj(i) .ge. startj .and. & + bufi(i) .le. endi .and. bufj(i) .le. endj) then + if(k .eq. 0) then + k = 1 + else + if(bufid(i) .ne. bufid(i-1)) k = k + 1 + endif + lndflag(k) = lndflag(k) + 1 + if(ter_rt_flag .eq. 1) then + if(rtmask(bufi(i)-local_startx_rt+1,bufj(i)-local_starty_rt+1) .ge. 0) then + gridflag(k) = gridflag(k) + 1 + endif + endif + endif + endif + end do + +! decide how many mapping land grids on current domain +! tmpgridflag = gridflag +#ifdef MPP_LAND +! call mpp_collect_1d_int_mem(npid,tmpgridflag) +#endif + +! decide how many user defined links on current domain + kk = k + LNUMRSL = 0 + do k = 1, lnsize + if(lndflag(k) .gt. 0) LNUMRSL = LNUMRSL + 1 + enddo + + + if(LNUMRSL .gt. 0) then + allocate(LUDRSL(LNUMRSL)) + allocate( basns_area(LNUMRSL) ) + else + write(6,*) "Warning: no routing links found." + call cleanBuf() + return + endif + + kk = 0 + do k = 1, lnsize + if( bufid(k) .ge. 0 ) then + if (bufi(k) .ge. starti .and. bufj(k) .ge. startj .and. & + bufi(k) .le. endi .and. bufj(k) .le. endj ) then + if(kk .eq. 0) then + kk = 1 + else + if(bufid(k) .ne. bufid(k-1)) kk = kk + 1 + endif + LUDRSL(kk)%myid = bufid(k) + LUDRSL(kk)%ngrids = -999 + if(gridflag(kk) .gt. 0) then + LUDRSL(kk)%ngrids = gridflag(kk) + if(.not. allocated(LUDRSL(kk)%weight) ) then + allocate( LUDRSL(kk)%weight(LUDRSL(kk)%ngrids )) + allocate( LUDRSL(kk)%grid_i(LUDRSL(kk)%ngrids )) + allocate( LUDRSL(kk)%grid_j(LUDRSL(kk)%ngrids )) + allocate( LUDRSL(kk)%nodeArea(LUDRSL(kk)%ngrids )) + endif + endif +! define bucket variables + LUDRSL(kk)%ncell = lndflag(kk) + if(.not. allocated(LUDRSL(kk)%cellweight) ) then + allocate( LUDRSL(kk)%cellweight(LUDRSL(kk)%ncell)) + allocate( LUDRSL(kk)%cell_i(LUDRSL(kk)%ncell)) + allocate( LUDRSL(kk)%cell_j(LUDRSL(kk)%ncell)) + allocate( LUDRSL(kk)%cellArea(LUDRSL(kk)%ncell)) + endif + endif + endif + enddo + + +! maping grid_i, grid_j and weight + kk = 0 + m = 1 + c = 1 + do i = 1, lnsize + if( (bufid(i) .ge. 0) ) then + if(bufi(i) .ge. starti .and. bufj(i) .ge. startj .and. & + bufi(i) .le. endi .and. bufj(i) .le. endj) then + if(kk .eq. 0) then + kk = 1 + else + if(bufid(i) .ne. bufid(i-1)) then + kk = kk + 1 + m = 1 + c = 1 + endif + endif + + if(LUDRSL(kk)%ngrids .gt. 0) then + if(rtmask(bufi(i)-local_startx_rt+1,bufj(i)-local_starty_rt+1) .ge. 0) then + LUDRSL(kk)%grid_i(m) = bufi(i) - local_startx_rt+1 + LUDRSL(kk)%grid_j(m) = bufj(i) - local_starty_rt+1 + LUDRSL(kk)%weight(m) = bufw(i) + m = m + 1 + endif + endif +!! begin define bucket variables + LUDRSL(kk)%cell_i(c) = bufi(i) - local_startx_rt+1 + LUDRSL(kk)%cell_j(c) = bufj(i) - local_starty_rt+1 + LUDRSL(kk)%cellWeight(c) = bufw(i) + c = c + 1 +!! end define bucket variables + endif + endif + end do + + call cleanBuf() + +#else + call hydro_stop("FATAL ERROR in UDMP: Sequential not work.") +#endif + + end subroutine UDMP2LOCAL + + subroutine cleanBuf() + if(allocated(bufi)) deallocate(bufi) + if(allocated(bufj)) deallocate(bufj) + if(allocated(bufw)) deallocate(bufw) + if(allocated(bufid)) deallocate(bufid) + end subroutine cleanBuf + + subroutine get_dimension(fileName, ndata,npid) + implicit none + character(len=*) fileName + integer ncid , iret, ndata,npid, dimid +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + iret = nf_open(fileName, NF_NOWRITE, ncid) + if (iret /= 0) then + write(*,'("FATAL ERROR: Problem opening mapping file: ''", A, "''")') & + trim(fileName) + call hydro_stop("In get_dimension() - Problem opening mapping file.") + endif + + iret = nf_inq_dimid(ncid, "polyid", dimid) + + if (iret /= 0) then + print*, "nf_inq_dimid: polyid" + call hydro_stop("In get_dimension() - nf_inq_dimid: polyid") + endif + + iret = nf_inq_dimlen(ncid, dimid, npid) + + iret = nf_inq_dimid(ncid, "data", dimid) + if (iret /= 0) then + print*, "nf_inq_dimid: data" + call hydro_stop("In get_file_dimension() - nf_inq_dimid: data") + endif + + iret = nf_inq_dimlen(ncid, dimid, ndata) + iret = nf_close(ncid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(ndata) + call mpp_land_bcast_int1(npid) +#endif + return + end subroutine get_dimension + + subroutine get1d_real8(fileName,var_name,out_buff) + implicit none + integer :: ivar, iret,varid,ncid + real*8 out_buff(:) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: fileName + + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) + if (iret .ne. 0) then + print*,"failed to open the netcdf file: ",trim(fileName) + call hydro_stop("In get1d_real8() - failed to open the netcdf file.") + return + endif + ivar = nf_inq_varid(ncid,trim(var_name), varid) + if(ivar .ne. 0) then + write(6,*) "Read Variable Error file: ",trim(fileName) + write(6,*) "Read Error: could not find ",trim(var_name) + call hydro_stop("In get1d_real8() - failed to read netcdf varialbe name. ") + end if + iret = nf_get_var_double(ncid, varid, out_buff) + iret = nf_close(ncid) + end subroutine get1d_real8 + + subroutine get1d_int(fileName,var_name,out_buff) + implicit none + integer :: ivar, iret,varid,ncid + integer out_buff(:) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: fileName + + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) + if (iret .ne. 0) then + print*,"FATAL ERROR: Failed to open the netcdf file: ",trim(fileName) + call hydro_stop("In get1d_int() - Failed to open the netcdf file") + return + endif + ivar = nf_inq_varid(ncid,trim(var_name), varid) + if(ivar .ne. 0) then + write(6,*) "Read Variable Error file: ",trim(fileName) + write(6,*) "Read Error: could not find ",trim(var_name) + call hydro_stop("In get1d_int() - failed to read netcdf variable name.") + end if + iret = nf_get_var_int(ncid, varid, out_buff) + iret = nf_close(ncid) + end subroutine get1d_int + + subroutine getUDMP_area(cell_area) + implicit none + integer i,j,k, m + real, dimension(:,:) :: cell_area + do k = 1, LNUMRSL + if(LUDRSL(k)%ngrids .gt. 0) then + do m = 1, LUDRSL(k)%ngrids + LUDRSL(k)%nodeArea(m) = cell_area(LUDRSL(k)%grid_i(m),LUDRSL(k)%grid_j(m)) + enddo + endif + do m = 1, LUDRSL(k)%ncell + LUDRSL(k)%cellArea(m) = cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) + enddo + + basns_area(k) = 0 + do m = 1, LUDRSL(k)%ncell + basns_area(k) = basns_area(k) + & + cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) * LUDRSL(k)%cellWeight(m) + enddo + + end do + end subroutine getUDMP_area + + subroutine get_basn_area_nhd(inOut) + implicit none + real, dimension(:) :: inOut + real, dimension(gnpid) :: buf +#ifdef MPP_LAND + call updateLinkV(basns_area, inOut) +#else + inOut = basns_area +#endif + + + end subroutine get_basn_area_nhd + + subroutine get_nprocs_map(ix,jx,bufi,bufj,nprocs_map,ndata) + implicit none + integer,dimension(:) :: bufi, bufj,nprocs_map +! integer, allocatable, dimension(:) :: lbufi,lbufj, lmap + integer :: ndata, lsize, ix,jx + integer, dimension(ix,jx) :: mask + integer, allocatable,dimension(:,:) :: gmask + + integer :: i,j,k, starti,startj, endi,endj, ii,jj, npid, kk +#ifdef MPP_LAND + + mask = my_id + 1 + if(my_id .eq. IO_id) allocate(gmask(global_rt_nx, global_rt_ny)) + + call MPP_LAND_COM_INTEGER(mask,IX,JX,99) + call write_IO_rt_int(mask, gmask) + + if(my_id .eq. io_id ) then + nprocs_map = -999 + do i = 1, ndata + if( (bufi(i) .gt. 0 .and. bufi(i) .le. global_rt_nx) .and. & + (bufj(i) .gt. 0 .and. bufj(i) .le. global_rt_ny) ) then + nprocs_map(i) = gmask(bufi(i), bufj(i)) + if( gmask(bufi(i), bufj(i)) .lt. 0) then + write(6,*) "mapping error in gmask : ", bufi(i) ,bufj(i) + endif + else + write(6,*) "no mapping for i,j : ", bufi(i) ,bufj(i) + endif + end do + + if(allocated(gmask)) deallocate(gmask) + endif +#else + call hydro_stop("FATAL ERROR in UDMP: Sequential not work.") +#endif + + + end subroutine get_nprocs_map + + +end module module_UDMAP diff --git a/wrfv2_fire/hydro/Routing/module_channel_routing.F b/wrfv2_fire/hydro/Routing/module_channel_routing.F new file mode 100644 index 00000000..5c1b2746 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_channel_routing.F @@ -0,0 +1,2277 @@ +! Program Name: +! 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_channel_routing +#ifdef MPP_LAND + USE module_mpp_land + use MODULE_mpp_ReachLS, only : updatelinkv, & + ReachLS_write_io, gbcastvalue, & + gbcastreal2 + +#endif + IMPLICIT NONE + + contains + +! ------------------------------------------------ +! FUNCTION MUSKING +! ------------------------------------------------ + REAL FUNCTION MUSKING(idx,qup,quc,qdp,dt,Km,X) + + IMPLICIT NONE + +!--local variables + REAL :: C1, C2, C3 + REAL :: Km !K travel time in hrs in reach + REAL :: X !weighting factors 0<=X<=0.5 + REAL :: dt !routing period in hrs + REAL :: avgbf !average base flow for initial condition + REAL :: qup !inflow from previous timestep + REAL :: quc !inflow of current timestep + REAL :: qdp !outflow of previous timestep + REAL :: dth !timestep in hours + INTEGER :: idx ! index + + dth = dt/3600 !hours in timestep + C1 = (dth - 2*Km*X)/(2*Km*(1-X)+dth) + C2 = (dth+2*Km*X)/(2*Km*(1-X)+dth) + C3 = (2*Km*(1-X)-dth)/(2*Km*(1-X)+dth) + MUSKING = (C1*quc)+(C2*qup)+(C3*qdp) + +! ---------------------------------------------------------------- + END FUNCTION MUSKING +! ---------------------------------------------------------------- + +! ------------------------------------------------ +! SUBROUTINE LEVELPOOL +! ------------------------------------------------ + +SUBROUTINE LEVELPOOL(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,oe,oc,oa) + + !! ---------------------------- argument variables + !! All elevations should be relative to a common base (often belev(k)) + + real, intent(INOUT) :: H ! water elevation height (m) + real, intent(IN) :: dt ! routing period [s] + real, intent(IN) :: qi0 ! inflow at previous timestep (cms) + real, intent(IN) :: qi1 ! inflow at current timestep (cms) + real, intent(OUT) :: qo1 ! outflow at current timestep + real, intent(IN) :: ql ! lateral inflow + real, intent(IN) :: ar ! area of reservoir (km^2) + real, intent(IN) :: we ! bottom of weir elevation + real, intent(IN) :: wc ! weir coeff. + real, intent(IN) :: wl ! weir length (m) + real, intent(IN) :: oe ! orifice elevation + real, intent(IN) :: oc ! orifice coeff. + real, intent(IN) :: oa ! orifice area (m^2) + real, intent(IN) :: maxh ! max depth of reservoir before overtop (m) + integer, intent(IN) :: ln ! lake number + + !!DJG Add lake option switch here...move up to namelist in future versions... + integer :: LAKE_OPT ! Lake model option (move to namelist later) + real :: Htmp ! Temporary assign of incoming lake el. (m) + + !! ---------------------------- local variables + real :: sap ! local surface area values + real :: discharge ! storage discharge m^3/s + real :: tmp1, tmp2 + real :: dh, dh1, dh2, dh3 ! height function and 3 order RK + real :: It, Itdt_3, Itdt_2_3 + real :: maxWeirDepth !maximum capacity of weir + !! ---------------------------- subroutine body: from chow, mad mays. pg. 252 + !! -- determine from inflow hydrograph + + + !!DJG Set hardwire for LAKE_OPT...move specification of this to namelist in + !future versions... + LAKE_OPT = 2 + Htmp = H !temporary set of incoming lake water elevation... + + + !!DJG IF-block for lake model option 1 - outflow=inflow, 2 - Chow et al level + !pool, ..... + if (LAKE_OPT.eq.1) then ! If-block for simple pass through scheme.... + + qo1 = qi1 ! Set outflow equal to inflow at current time + H = Htmp ! Set new lake water elevation to incoming lake el. + + else if (LAKE_OPT.eq.2) then ! If-block for Chow et al level pool scheme + + It = qi0 + Itdt_3 = (qi0 + (qi1 + ql))/3 + Itdt_2_3 = (qi0 + (qi1 + ql))/3 + Itdt_3 + maxWeirDepth = maxh - we + + !-- determine Q(dh) from elevation-discharge relationship + !-- and dh1 + dh = H - we + if (dh .gt. maxWeirDepth) then + dh = maxWeirDepth + endif + + if (dh .gt. 0.0 ) then !! orifice and overtop discharge + tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + tmp2 = wc * wl * (dh ** 2./3.) + discharge = tmp1 + tmp2 + + if (H .gt. 0.0) then + sap = (ar * 1.0E6 ) * (1 + (H - we) / H) + else + sap = 0.0 + endif + + else if ( H .gt. oe ) then !! only orifice flow,not full + discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + sap = ar * 1.0E6 + else + discharge = 0.0 + sap = ar * 1.0E6 + endif + + if (sap .gt. 0) then + dh1 = ((It - discharge)/sap)*dt + else + dh1 = 0.0 + endif + + !-- determine Q(H + dh1/3) from elevation-discharge relationship + !-- dh2 + dh = (H+dh1/3) - we + if (dh .gt. maxWeirDepth) then + dh = maxWeirDepth + endif + + if (dh .gt. 0.0 ) then !! orifice and overtop discharge + tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + tmp2 = wc * wl * (dh ** 2./3.) + discharge = tmp1 + tmp2 + + if (H .gt. 0.0) then + sap = (ar * 1.0E6 ) * (1 + (H - we) / H) + else + sap = 0.0 + endif + + else if ( H .gt. oe ) then !! only orifice flow,not full + discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + sap = ar * 1.0E6 + else + discharge = 0.0 + sap = ar * 1.0E6 + endif + + if (sap .gt. 0.0) then + dh2 = ((Itdt_3 - discharge)/sap)*dt + else + dh2 = 0.0 + endif + + !-- determine Q(H + 2/3 dh2) from elevation-discharge relationship + !-- dh3 + dh = (H + (0.667*dh2)) - we + if (dh .gt. maxWeirDepth) then + dh = maxWeirDepth + endif + + if (dh .gt. 0.0 ) then !! orifice and overtop discharge + tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + tmp2 = wc * wl * (dh ** 2./3.) + discharge = tmp1 + tmp2 + + if (H .gt. 0.0) then + sap = (ar * 1.0E6 ) * (1 + (H - we) / H) + else + sap = 0.0 + endif + + else if ( H .gt. oe ) then !! only orifice flow,not full + discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + sap = ar * 1.0E6 + else + discharge = 0.0 + sap = ar * 1.0E6 + endif + + if (sap .gt. 0.0) then + dh3 = ((Itdt_2_3 - discharge)/sap)*dt + else + dh3 = 0.0 + endif + + !-- determine dh and H + dh = (dh1/4.) + (0.75*dh3) + H = H + dh + + !-- compute final discharge + dh = H - we + if (dh .gt. maxWeirDepth) then + dh = maxWeirDepth + endif + if (dh .gt. 0.0 ) then !! orifice and overtop discharge + tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + tmp2 = wc * wl * (dh ** 2./3.) + discharge = tmp1 + tmp2 + + if (H .gt. 0.0) then + sap = (ar * 1.0E6 ) * (1 + (H - we) / H) + else + sap = 0.0 + endif + + else if ( H .gt. oe ) then !! only orifice flow,not full + discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) ) + sap = ar * 1.0E6 + else + discharge = 0.0 + sap = ar * 1.0E6 + endif + + if(H .ge. maxh) then ! overtop condition + discharge = qi1 + H = maxh + endif + + qo1 = discharge ! return the flow rate from reservoir + +23 format('botof H dh orf wr Q',f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.2) +24 format('ofonl H dh sap Q ',f8.4,2x,f8.4,2x,f8.0,2x,f8.2) + + + ELSE ! ELSE for LAKE_OPT.... + ENDIF ! ENDIF for LAKE_OPT.... + + RETURN + +! ---------------------------------------------------------------- + END SUBROUTINE LEVELPOOL +! ---------------------------------------------------------------- + + +! ------------------------------------------------ +! FUNCTION Diffusive wave +! ------------------------------------------------ + REAL FUNCTION DIFFUSION(nod,z1,z20,h1,h2,dx,n, & + Bw, Cs) + IMPLICIT NONE +!-- channel geometry and characteristics + REAL :: Bw !-bottom width (meters) + REAL :: Cs !-Channel side slope slope + REAL :: dx !-channel lngth (m) + REAL,intent(in) :: n !-mannings coefficient + REAL :: R !-Hydraulic radius + REAL :: AREA !- wetted area + REAL :: h1,h2 !-tmp height variables + REAL :: z1,z2 !-z1 is 'from', z2 is 'to' elevations + REAL :: z !-channel side distance + REAL :: w !-upstream weight + REAL :: Ku,Kd !-upstream and downstream conveyance + REAL :: Kf !-final face conveyance + REAL :: Sf !-friction slope + REAL :: sgn !-0 or 1 + INTEGER :: nod !- node + REAL :: z20, dzx + +! added by Wei Yu for bad data. + + dzx = (z1 - z20)/dx + if(dzx .lt. 0.002) then + z2 = z1 - dx*0.002 + else + z2 = z20 + endif +!end + + if (n.le.0.0.or.Cs.le.0.or.Bw.le.0) then + print *, "Error in Diffusion function ->channel coefficients" + print *, "nod, n, Cs, Bw", nod, n, Cs, Bw + call hydro_stop("In DIFFUSION() - Error channel coefficients.") + endif + +! Sf = ((z1+h1)-(z2+h2))/dx !-- compute the friction slope + !if(z1 .eq. z2) then + ! Sf = ((z1-(z2-0.01))+(h1-h2))/dx !-- compute the friction slope + !else +! Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope + !endif + +!modifieed by Wei Yu for false geography data + if(abs(z1-z2) .gt. 1.0E5) then +#ifdef HYDRO_D + print*, "WARNING: huge slope rest to 0 for channel grid.", z1,z2 +#endif + Sf = ((h1-h2))/dx !-- compute the friction slope + else + Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope + endif +!end modfication + + sgn = SGNf(Sf) !-- establish sign + + w = 0.5*(sgn + 1.) !-- compute upstream or downstream weighting + + z = 1/Cs !--channel side distance (m) + R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z*z)) !-- Hyd Radius + AREA = (Bw+z*h1)*h1 !-- Flow area + Ku = (1/n)*(R**(2./3.))*AREA !-- convenyance + + R = ((Bw+z*h2)*h2)/(Bw+2*h2*sqrt(1+z*z)) !-- Hyd Radius + AREA = (Bw+z*h2)*h2 !-- Flow area + Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance + + Kf = (1-w)*Kd + w*Ku !-- conveyance + DIFFUSION = Kf * sqrt(abs(Sf))*sgn + + +100 format('z1,z2,h1,h2,kf,Dif, Sf, sgn ',f8.3,2x,f8.3,2x,f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.0) + + END FUNCTION DIFFUSION +! ---------------------------------------------------------------- + +! ------------------------------------------------ +! FUNCTION MUSKINGUM CUNGE +! ------------------------------------------------ + REAL FUNCTION MUSKINGCUNGE(idx,qup, quc, qdp, ql,& + dt,So,dx,n,Cs,Bw) + IMPLICIT NONE + +!--local variables + REAL :: C1, C2, C3, C4 + REAL :: Km !K travel time in hrs in reach + REAL :: X !weighting factors 0<=X<=0.5 + REAL :: dt !routing period in seconds + REAL :: qup !flow upstream previous timestep + REAL :: quc !flow upstream current timestep + REAL :: qdp !flow downstream previous timestep +! REAL :: qdc !flow downstream current timestep + REAL :: ql !lateral inflow through reach (m^3/sec) + REAL :: Ck ! wave celerity (m/s) + +!-- channel geometry and characteristics + REAL :: Bw ! bottom width (meters) + REAL :: Cs ! Channel side slope slope + REAL :: So ! Channel bottom slope % + REAL :: dx ! channel lngth (m) + REAL :: n ! mannings coefficient + REAL :: Tw ! top width at peak flow + REAL :: AREA ! Cross sectional area m^2 + REAL :: Z ! trapezoid distance (m) + REAL :: R ! Hydraulic radius + REAL :: WP ! wetted perimmeter + REAL :: h ! depth of flow + REAL :: h_0,h_1 ! secant method estimates + REAL :: Qj_0 ! secant method estimates + REAL :: Qj ! intermediate flow estimate + REAL :: D,D1 ! diffusion coeff + REAL :: dtr ! required timestep, minutes + REAL :: error + REAL :: hp !courant, previous height + INTEGER :: maxiter !maximum number of iterations + + +!-- local variables.. needed if channel is sub-divded + REAL :: a,b,c + INTEGER :: i,idx !-- channel segment counter + +!yw add + goto 101 + C1 = 0 + C2 = 0 + C3 = 0 + C4 = 0 + Km = 0 + X = 0 !weighting factors 0<=X<=0.5 + Ck = 0 + Tw = 0 ! top width at peak flow + AREA = 0 ! Cross sectional area m^2 + Z = 0 ! trapezoid distance (m) + R = 0 ! Hydraulic radius + WP = 0 ! wetted perimmeter + h = 0 ! depth of flow + h_0 = 0 + h_1 = 0 ! secant method estimates + Qj_0 = 0 ! secant method estimates + D = 0 + D1 = 0 ! diffusion coeff + dtr = 0 ! required timestep, minutes + error = 1.0 + hp = 0 !courant, previous height + maxiter = 0 + a = 0 +101 continue +!end yw + + c = 0.52 !-- coefficnets for finding dx/Ckdt + b = 1.15 + + if(Cs .eq.0) then + z = 1.0 + else + z = 1/Cs !channel side distance (m) + endif + + !qC = quc + ql !current upstream in reach + + if (n .le.0 .or. So .le. 0 .or. z .le. 0 .or. Bw .le. 0) then + print*, "Error in channel coefficients -> Muskingum cunge",n,So,z,Bw + call hydro_stop("In MUSKINGCUNGE() - Error in channel coefficients") + end if + + error = 1.0 + maxiter = 0 + a = 0.0 + + if ((quc+ql) .lt. 100) then + b=5 + else + b= 20 + endif + +!------------- Secant Method + h = (a+b)/2 !- upper interval + h_0 = 0.0 !- lower interval + Qj_0 = 0.0 !- initial flow of lower interval + + do while ((error .gt. 0.05 .and. maxiter .le. 100 .and. h .gt. 0.01)) + + !----- lower interval -------------------- + Tw = Bw + 2*z*h_0 !--top width of the channel inflow + Ck = (sqrt(So)/n)*(5./3.)*(h_0**0.667) !-- pg 287 Chow, Mdt, Mays + if(Ck .gt. 0.0) then + Km = dx/Ck !-- seconds Muskingum Param + if(Km .lt. dt) then + Km = dt + endif + else + Km = dt + endif + + if(Tw*So*Ck*dx .eq. 0.0) then + X = 0.25 + else + X = 0.5-(Qj_0/(2*Tw*So*Ck*dx)) + endif + + if(X .le. 0.0) then + X = 0.25 + elseif(X .gt. 0.35) then + X = 0.35 + endif + + D = (Km*(1 - X) + dt/2) !--seconds + if(D .eq. 0.0) then + print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D + call hydro_stop("In MUSKINGCUNGE() - D is 0.") + endif + + C1 = (Km*X + dt/2)/D + C2 = (dt/2 - Km*X)/D + C3 = (Km*(1-X)-dt/2)/D + C4 = (ql*dt)/D !-- ql already multipled by the dx length + + if(h_0 .le. 0.0) then + AREA= 0.0 + WP = 0.0 + else + AREA = (Bw * h_0 + z * (h_0*h_0) ) + WP = (Bw * h_0 + z * (h_0*h_0)) / (Bw + 2 * h_0 * sqrt(1+z*z)) + endif + + if(WP .le. 0.0) then + Qj_0 = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) + else + Qj_0 = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) - ((1/n) * AREA * (WP**(2./3.)) * sqrt(So)) !f(x) + endif + + !--upper interval ----------- + Tw = Bw + 2*z*h !--top width of the channel inflow + Ck = (sqrt(So)/n)*(5./3.)*(h**0.667) !-- pg 287 Chow, Mdt, Mays + if(Ck .gt. 0.0) then + Km = dx/Ck !-- seconds Muskingum Param + if(Km .lt. dt) then + Km = dt + endif + else + Km = dt + endif + + if(Tw*So*Ck*dx .eq. 0.0) then + X = 0.25 + else + X = 0.5-(((C1*qup)+(C2*quc)+(C3*qdp) + C4)/(2*Tw*So*Ck*dx)) + endif + + if(X .le. 0.0) then + X = 0.25 + elseif(X .gt. 0.35) then + X = 0.35 + endif + + D = (Km*(1 - X) + dt/2) !--seconds + if(D .eq. 0.0) then + print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D + call hydro_stop("In MUSKINGCUNGE() - D is 0.") + endif + + C1 = (Km*X + dt/2)/D + C2 = (dt/2 - Km*X)/D + C3 = (Km*(1-X)-dt/2)/D + C4 = (ql*dt)/D !-- ql already multipled by the dx length + + if(h .le. 0) then + AREA = 0.0 + WP = 0.0 + else + AREA = (Bw * h + z * (h*h) ) + WP = (Bw * h + z * (h*h)) / (Bw + 2 * h * sqrt(1+z*z)) + endif + + if(WP .le. 0.0) then + Qj = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) + else + Qj = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) -((1/n) * AREA * (WP**(2./3.)) * sqrt(So)) + endif + + if(Qj_0-Qj .ne. 0.0) then + h_1 = h - ((Qj * (h_0 - h))/(Qj_0 - Qj)) !update h, 3rd estimate + if(h_1 .lt. 0.0) then + h_1 = h + endif + else + h_1 = h + endif + + error = abs((h_1 - h)/h) !error is new estatimate and 2nd estimate + +! if(idx .eq. 626) then +! write(6,*) h_0,h,h_1,error +! endif + + h_0 = h + h = h_1 + maxiter = maxiter + 1 + + end do + + if((maxiter .ge. 100 .and. error .gt. 0.05) .or. h .gt. 100) then + + print*, "WARNING:" + print*, "id,err,iters,h", idx, error, maxiter, h + print*, "n,z,B,So,dx,X,dt,Km",n,z,Bw,So,dx,X,dt,Km + print*, "qup,quc,qdp,ql", qup,quc,qdp,ql + if(h.gt.100) then + print*, "FATAL ERROR: Water Elevation Calculation is Diverging" + call hydro_stop("In MUSKINGCUNGE() - Water Elevation Calculation is Diverging") + endif + endif + +! if(idx .eq. 626) then +! write(6,*) ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber +! endif + +! MUSKINGCUNGE = h +!yw MUSKINGCUNGE = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber + +!yw added for test + + if(((C1*qup)+(C2*quc)+(C3*qdp) + C4) .lt. 0.0) then + MUSKINGCUNGE = MAX( ( (C1*qup)+(C2*quc) + C4),((C1*qup)+(C3*qdp) + C4) ) + else + MUSKINGCUNGE = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber + endif + + +! ---------------------------------------------------------------- + + END FUNCTION MUSKINGCUNGE + + + SUBROUTINE SUBMUSKINGCUNGE(qdc,vel,idx,qup,quc,qdp,ql,dt,So,dx,n,Cs,Bw) + + IMPLICIT NONE + + REAL, intent(IN) :: dt !routing period in seconds + REAL, intent(IN) :: qup !flow upstream previous timestep + REAL, intent(IN) :: quc !flow upstream current timestep + REAL, intent(IN) :: qdp !flow downstream previous timestep + REAL, intent(INOUT) :: qdc !flow downstream current timestep + REAL, intent(IN) :: ql !lateral inflow through reach (m^3/sec) + REAL, intent(IN) :: Bw ! bottom width (meters) + REAL, intent(IN) :: Cs ! Channel side slope slope + REAL, intent(IN) :: So ! Channel bottom slope % + REAL, intent(IN) :: dx ! channel lngth (m) + REAL, intent(IN) :: n ! mannings coefficient + REAL, intent(INOUT) :: vel ! mannings coefficient + INTEGER, intent(IN) :: idx ! channel id + +!--local variables + REAL :: C1, C2, C3, C4 + REAL :: Km !K travel time in hrs in reach + REAL :: X !weighting factors 0<=X<=0.5 + REAL :: Ck ! wave celerity (m/s) + +!-- channel geometry and characteristics + REAL :: Tw ! top width at peak flow + REAL :: AREA ! Cross sectional area m^2 + REAL :: Z ! trapezoid distance (m) + REAL :: R ! Hydraulic radius + REAL :: WP ! wetted perimmeter + REAL :: h ! depth of flow + REAL :: h_0,h_1 ! secant method estimates + REAL :: Qj_0 ! secant method estimates + REAL :: Qj ! intermediate flow estimate + REAL :: D,D1 ! diffusion coeff + REAL :: dtr ! required timestep, minutes + REAL :: error + REAL :: hp !courant, previous height + INTEGER :: maxiter !maximum number of iterations + +!-- local variables.. needed if channel is sub-divded + REAL :: a,b,c + INTEGER :: i !-- channel segment counter + +!yw add + goto 101 + C1 = 0 + C2 = 0 + C3 = 0 + C4 = 0 + Km = 0 + X = 0 !weighting factors 0<=X<=0.5 + Ck = 0 + Tw = 0 ! top width at peak flow + AREA = 0 ! Cross sectional area m^2 + Z = 0 ! trapezoid distance (m) + R = 0 ! Hydraulic radius + WP = 0 ! wetted perimmeter + h = 0 ! depth of flow + h_0 = 0 + h_1 = 0 ! secant method estimates + Qj_0 = 0 ! secant method estimates + D = 0 + D1 = 0 ! diffusion coeff + dtr = 0 ! required timestep, minutes + error = 1.0 + hp = 0 !courant, previous height + maxiter = 0 + a = 0 +101 continue +!end yw + + c = 0.52 !-- coefficnets for finding dx/Ckdt + b = 1.15 + + if(Cs .eq.0) then + z = 1.0 + else + z = 1/Cs !channel side distance (m) + endif + + !qC = quc + ql !current upstream in reach + + if (n .le.0 .or. So .le. 0 .or. z .le. 0 .or. Bw .le. 0) then + print*, "Error in channel coefficients -> Muskingum cunge",n,So,z,Bw + call hydro_stop("In MUSKINGCUNGE() - Error in channel coefficients") + end if + + error = 1.0 + maxiter = 0 + a = 0.0 + + if ((quc+ql) .lt. 100) then + b=5 + else + b= 20 + endif + +!------------- Secant Method + h = (a+b)/2 !- upper interval + h_0 = 0.0 !- lower interval + Qj_0 = 0.0 !- initial flow of lower interval + + do while ((error .gt. 0.05 .and. maxiter .le. 100 .and. h .gt. 0.01)) + + !----- lower interval -------------------- + Tw = Bw + 2*z*h_0 !--top width of the channel inflow + Ck = (sqrt(So)/n)*(5./3.)*(h_0**0.667) !-- pg 287 Chow, Mdt, Mays + if(Ck .gt. 0.0) then + Km = dx/Ck !-- seconds Muskingum Param + if(Km .lt. dt) then + Km = dt + endif + else + Km = dt + endif + + if(Tw*So*Ck*dx .eq. 0.0) then + X = 0.25 + else + X = 0.5-(Qj_0/(2*Tw*So*Ck*dx)) + endif + + if(X .le. 0.0) then + X = 0.25 + elseif(X .gt. 0.35) then + X = 0.35 + endif + + D = (Km*(1 - X) + dt/2) !--seconds + if(D .eq. 0.0) then + print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D + call hydro_stop("In MUSKINGCUNGE() - D is 0.") + endif + + C1 = (Km*X + dt/2)/D + C2 = (dt/2 - Km*X)/D + C3 = (Km*(1-X)-dt/2)/D + C4 = (ql*dt)/D !-- ql already multipled by the dx length + + if(h_0 .le. 0.0) then + AREA= 0.0 + WP = 0.0 + else + AREA = (Bw * h_0 + z * (h_0*h_0) ) + WP = (Bw * h_0 + z * (h_0*h_0)) / (Bw + 2 * h_0 * sqrt(1+z*z)) + endif + + if(WP .le. 0.0) then + Qj_0 = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) + else + Qj_0 = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) - ((1/n) * AREA * (WP**(2./3.)) * sqrt(So)) !f(x) + endif + + !--upper interval ----------- + Tw = Bw + 2*z*h !--top width of the channel inflow + Ck = (sqrt(So)/n)*(5./3.)*(h**0.667) !-- pg 287 Chow, Mdt, Mays + if(Ck .gt. 0.0) then + Km = dx/Ck !-- seconds Muskingum Param + if(Km .lt. dt) then + Km = dt + endif + else + Km = dt + endif + + if(Tw*So*Ck*dx .eq. 0.0) then + X = 0.25 + else + X = 0.5-(((C1*qup)+(C2*quc)+(C3*qdp) + C4)/(2*Tw*So*Ck*dx)) + endif + + if(X .le. 0.0) then + X = 0.25 + elseif(X .gt. 0.35) then + X = 0.35 + endif + + D = (Km*(1 - X) + dt/2) !--seconds + if(D .eq. 0.0) then + print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D + call hydro_stop("In MUSKINGCUNGE() - D is 0.") + endif + + C1 = (Km*X + dt/2)/D + C2 = (dt/2 - Km*X)/D + C3 = (Km*(1-X)-dt/2)/D + C4 = (ql*dt)/D !-- ql already multipled by the dx length + + if(h .le. 0) then + AREA = 0.0 + WP = 0.0 + else + AREA = (Bw * h + z * (h*h) ) + WP = (Bw * h + z * (h*h)) / (Bw + 2 * h * sqrt(1+z*z)) + endif + + if(WP .le. 0.0) then + Qj = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) + else + Qj = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) -((1/n) * AREA * (WP**(2./3.)) * sqrt(So)) + endif + + if(Qj_0-Qj .ne. 0.0) then + h_1 = h - ((Qj * (h_0 - h))/(Qj_0 - Qj)) !update h, 3rd estimate + if(h_1 .lt. 0.0) then + h_1 = h + endif + else + h_1 = h + endif + + error = abs((h_1 - h)/h) !error is new estatimate and 2nd estimate + +! if(idx .eq. 626) then +! write(6,*) h_0,h,h_1,error +! endif + + h_0 = h + h = h_1 + maxiter = maxiter + 1 + + end do + + if((maxiter .ge. 100 .and. error .gt. 0.05) .or. h .gt. 100) then + + print*, "WARNING:" + print*, "id,err,iters,h", idx, error, maxiter, h + print*, "n,z,B,So,dx,X,dt,Km",n,z,Bw,So,dx,X,dt,Km + print*, "qup,quc,qdp,ql", qup,quc,qdp,ql + if(h.gt.100) then + print*, "FATAL ERROR: Water Elevation Calculation is Diverging" + call hydro_stop("In MUSKINGCUNGE() - Water Elevation Calculation is Diverging") + endif + endif + +!yw added for test + if(((C1*qup)+(C2*quc)+(C3*qdp) + C4) .lt. 0.0) then +! MUSKINGCUNGE = MAX( ( (C1*qup)+(C2*quc) + C4),((C1*qup)+(C3*qdp) + C4) ) + qdc = MAX( ( (C1*qup)+(C2*quc) + C4),((C1*qup)+(C3*qdp) + C4) ) + + else +! MUSKINGCUNGE = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber + qdc = ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber + + endif + + Tw = Bw + (2*z*h) + R = (h*(Bw + Tw) / 2) / (Bw + 2*(((Tw - Bw) / 2)**2 + h**2)**0.5) + vel = (1./n) * (R **(2./3.)) * sqrt(So) ! average velocity in m/s + +! ---------------------------------------------------------------- +!END FUNCTION MUSKINGCUNGE +END SUBROUTINE SUBMUSKINGCUNGE +! ---------------------------------------------------------------- + +! ------------------------------------------------ +! FUNCTION KINEMATIC +! ------------------------------------------------ + REAL FUNCTION KINEMATIC() + + IMPLICIT NONE + +! -------- DECLARATIONS ----------------------- + +! REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH + + KINEMATIC = 1 +!---------------------------------------------------------------- + END FUNCTION KINEMATIC +!---------------------------------------------------------------- + + +! ------------------------------------------------ +! SUBROUTINE drive_CHANNEL +! ------------------------------------------------ +! ------------------------------------------------ + Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & + QSUBRT, LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, & + TYPEL, ORDER, MAXORDER, NLINKS, CH_NETLNK, CH_NETRT, CH_LNKRT, & + LAKE_MSKRT, DT, DTCT, DTRT_CH,MUSK, MUSX, QLINK, & + HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, & + RESHT, HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, & + dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN, & + NLINKSL, LINKID, node_area & +#ifdef MPP_LAND + , lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks & + , LNLINKSL, LLINKID & + , gtoNode,toNodeInd,nToNodeInd & +#endif + , CH_LNKRT_SL & + ,gwBaseSwCRT, gwHead, qgw_chanrt, gwChanCondSw, gwChanCondConstIn, & + gwChanCondConstOut) + + + IMPLICIT NONE + +! -------- DECLARATIONS ------------------------ + + INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option + INTEGER, INTENT(IN) :: NLINKS,NLAKES, NLINKSL + integer, INTENT(INOUT) :: KT ! flag of cold start (1) or continue run. + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSUBRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKEINFLORT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QINFLOWBASE + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT_SL + + real , dimension(ixrt,jxrt):: latval,lonval + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: ORDER, TYPEL !--link + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: TO_NODE, FROM_NODE + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: CHANXI, CHANYJ + REAL, INTENT(IN), DIMENSION(NLINKS) :: ZELEV !--elevation of nodes + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CVOL + REAL, INTENT(IN), DIMENSION(NLINKS) :: MUSK, MUSX + REAL, INTENT(IN), DIMENSION(NLINKS) :: CHANLEN + REAL, INTENT(IN), DIMENSION(NLINKS) :: So, MannN + REAL, INTENT(IN), DIMENSION(NLINKS) :: ChSSlp,Bw !--properties of nodes or links + REAL :: Km, X + REAL , INTENT(INOUT), DIMENSION(:,:) :: QLINK + REAL , DIMENSION(NLINKS,2) :: tmpQLINK + REAL , INTENT(INOUT), DIMENSION(NLINKS) :: HLINK + REAL, INTENT(IN) :: DT !-- model timestep + REAL, INTENT(IN) :: DTRT_CH !-- routing timestep + REAL, INTENT(INOUT) :: DTCT + real :: minDTCT !BF minimum routing timestep + REAL :: dist(ixrt,jxrt,9) + REAL :: RETDEP_CHAN + INTEGER, INTENT(IN) :: MAXORDER, SUBRTSWCRT, & + gwBaseSwCRT, gwChanCondSw + real, intent(in) :: gwChanCondConstIn, gwChanCondConstOut ! aquifer-channel conductivity constant from namelist + REAL , INTENT(IN), DIMENSION(NLINKS) :: node_area + +!DJG GW-chan coupling variables... + REAL, DIMENSION(NLINKS) :: dzGwChanHead + REAL, DIMENSION(NLINKS) :: Q_GW_CHAN_FLUX !DJG !!! Change 'INTENT' to 'OUT' when ready to update groundwater state... + REAL, DIMENSION(IXRT,JXRT) :: ZWATTBLRT !DJG !!! Match with subsfce/gw routing & Change 'INTENT' to 'INOUT' when ready to update groundwater state... + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: gwHead !DJG !!! groundwater head from Fersch-2d gw implementation...units (m ASL) + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: qgw_chanrt !DJG !!! Channel-gw flux as used in Fersch 2d gw implementation...units (m^3/s)...Change 'INTENT' to 'OUT' when ready to update groundwater state... + + + + !-- lake params + REAL, INTENT(IN), DIMENSION(NLAKES) :: HRZAREA !-- horizontal area (km^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: LAKEMAXH !-- maximum lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRH !-- lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRC !-- weir coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRL !-- weir length (m) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEC !-- orrifice coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEA !-- orrifice area (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEE !-- orrifce elevation (m) + + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: RESHT !-- reservoir height (m) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEI !-- lake inflow (cms) + REAL, DIMENSION(NLAKES) :: QLAKEIP !-- lake inflow previous timestep (cms) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEO !-- outflow from lake used in diffusion scheme + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: LAKENODE !-- outflow from lake used in diffusion scheme + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: LINKID !-- id of channel elements for linked scheme + REAL, DIMENSION(NLINKS) :: QLateral !--lateral flow + REAL, DIMENSION(NLINKS) :: QSUM !--mass bal of node + REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme + +!-- Local Variables + INTEGER :: i,j,k,t,m,jj,kk,KRT,node + INTEGER :: DT_STEPS !-- number of timestep in routing + REAL :: Qup,Quc !--Q upstream Previous, Q Upstream Current, downstream Previous + REAL :: bo !--critical depth, bnd outflow just for testing + REAL :: AREA,WP !--wetted area and perimiter for MuskingC. routing + + REAL ,DIMENSION(NLINKS) :: HLINKTMP,CVOLTMP !-- temporarily store head values and volume values + REAL ,DIMENSION(NLINKS) :: CD !-- critical depth + real, DIMENSION(IXRT,JXRT) :: tmp + real, dimension(nlinks) :: tmp2 + +#ifdef MPP_LAND + integer lake_index(nlakes) + integer nlinks_index(nlinks) + integer mpp_nlinks, iyw, yw_mpp_nlinks + integer link_location(ixrt,jxrt) + real ywtmp(ixrt,jxrt) + integer LNLINKSL + INTEGER, dimension(LNLINKSL) :: LLINKID + real*8, dimension(LNLINKSL) :: LQLateral +! real*4, dimension(LNLINKSL) :: LQLateral + integer, dimension(:) :: toNodeInd + integer, dimension(:,:) :: gtoNode + integer :: nToNodeInd + real, dimension(nToNodeInd,2) :: gQLINK +#else + REAL*8, DIMENSION(NLINKS) :: LQLateral !--lateral flow +#endif + integer flag + + integer :: n, kk2, nt, nsteps ! tmp + + QLAKEIP = 0 + HLINKTMP = 0 + CVOLTMP = 0 + CD = 0 + node = 1 + QLateral = 0 + QSUM = 0 + QLLAKE = 0 + + +!yw print *, "DRIVE_channel,option,nlinkl,nlinks!!", channel_option,NLINKSL,NLINKS + + dzGwChanHead = 0. + + IF(channel_option .ne. 3) then !--muskingum methods ROUTE ON DT timestep, not DTRT!! + + nsteps = (DT+0.5)/DTRT_CH + +#ifdef MPP_LAND + LQLateral = 0 !-- initial lateral flow to 0 for this reach + DO iyw = 1,yw_MPP_NLINKS + jj = nlinks_index(iyw) + !--------river grid points, convert depth in mm to rate across reach in m^3/sec + if( .not. ( (CHANXI(jj) .eq. 1 .and. left_id .ge. 0) .or. & + (CHANXI(jj) .eq. ixrt .and. right_id .ge. 0) .or. & + (CHANYJ(jj) .eq. 1 .and. down_id .ge. 0) .or. & + (CHANYJ(jj) .eq. jxrt .and. up_id .ge. 0) & + ) ) then + if (CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj)) .gt. 0) then + k = CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj)) + LQLateral(k) = LQLateral(k)+((QSTRMVOLRT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 & + *node_area(jj)/DT) + elseif ( (LAKE_MSKRT(CHANXI(jj),CHANYJ(jj)) .gt. 0)) then !-lake grid + k = LAKE_MSKRT(CHANXI(jj),CHANYJ(jj)) + LQLateral(k) = LQLateral(k) +((LAKEINFLORT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 & + *node_area(jj)/DT) + endif + endif + end do ! jj + + +! assign LQLATERAL to QLATERAL + call updateLinkV(LQLateral, QLateral(1:NLINKSL)) + +#else + LQLateral = 0 !-- initial lateral flow to 0 for this reach + do jj = 1, NLINKS + !--------river grid points, convert depth in mm to rate across reach in m^3/sec + + if (CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj)) .gt. 0 ) then + k = CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj)) + LQLateral(k) = LQLateral(k)+((QSTRMVOLRT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 & + *node_area(jj)/DT) + elseif ( (LAKE_MSKRT(CHANXI(jj),CHANYJ(jj)) .gt. 0)) then !-lake grid + k = LAKE_MSKRT(CHANXI(jj),CHANYJ(jj)) + LQLateral(k) = LQLateral(k) +((LAKEINFLORT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 & + *node_area(jj)/DT) + endif + + end do ! jj + QLateral = LQLateral +#endif + +! QLateral = QLateral / nsteps + + do nt = 1, nsteps + + +!---------- route order 1 reaches which have no upstream inflow + do k=1, NLINKSL + if (ORDER(k) .eq. 1) then !-- first order stream has no headflow + + + if(TYPEL(k) .eq. 1) then !-- level pool route of reservoir + !CALL LEVELPOOL(1,0.0, 0.0, qd, QLINK(k,2), QLateral(k), & + ! DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & + ! WEIRC(k), WEIRL(k), ORIFICEE(i), ORIFICEC(k), ORIFICEA(k) ) + elseif (channel_option .eq. 1) then + Km = MUSK(k) + X = MUSX(k) + QLINK(k,2) = MUSKING(k,0.0, QLateral(k), QLINK(k,1), DTRT_CH, Km, X) !--current outflow + elseif (channel_option .eq. 2) then !-- upstream is assumed constant initial condition + + ! HLINK(k) = MUSKINGCUNGE(k,0.0,0.0,QLINK(k,1), & + QLINK(k,2) = MUSKINGCUNGE(k,0.0,0.0,QLINK(k,1), & + QLateral(k), DTRT_CH, So(k), CHANLEN(k), & + MannN(k), ChSSlp(k), Bw(k)) + + ! AREA = (Bw(k) * HLINK(k) + 1/ChSSlp(k) * HLINK(k)**2) + ! WP = (Bw(k) * HLINK(k) + 1/ChSSlp(k) * HLINK(k)**2) / (Bw(k) + 2 * HLINK(k) * sqrt(1+(1/ChSSlp(k))**2)) + ! QLINK(k,2) = 1/MannN(k) * AREA * WP**(2./3.) * sqrt(So(k)) + + else + print *, "FATAL ERROR: No channel option selected" + call hydro_stop("In drive_CHANNEL() -No channel option selected ") + endif + endif + end do + +#ifdef MPP_LAND + gQLINK = 0 + call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,2), NLINKSL, gQLINK(:,2)) + call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,1), NLINKSL, gQLINK(:,1)) +#endif + + !---------- route other reaches, with upstream inflow + tmpQlink = 0 + do k = 1,NLINKSL + if (ORDER(k) .gt. 1 ) then !-- exclude first order stream + Quc = 0 + Qup = 0 + +#ifdef MPP_LAND +!using mapping index + do n = 1, gtoNODE(k,1) + m = gtoNODE(k,n+1) +!yw if (LINKID(k) .eq. m) then + Quc = Quc + gQLINK(m,2) !--accum of upstream inflow of current timestep (2) + Qup = Qup + gQLINK(m,1) !--accum of upstream inflow of previous timestep (1) + + ! if(LINKID(k) .eq. 3259 .or. LINKID(k) .eq. 3316 .or. LINKID(k) .eq. 3219) then + ! write(6,*) "id,Uc,Up",LINKID(k),Quc,Qup + ! call flush(6) + ! endif + +!yw endif + end do ! do i + +#else + do m = 1, NLINKSL + if (LINKID(k) .eq. TO_NODE(m)) then + Quc = Quc + QLINK(m,2) !--accum of upstream inflow of current timestep (2) + Qup = Qup + QLINK(m,1) !--accum of upstream inflow of previous timestep (1) + endif + end do ! do m +#endif + + if(TYPEL(k) .eq. 1) then !--link is a reservoir + + ! CALL LEVELPOOL(1,QLINK(k,1), Qup, QLINK(k,1), QLINK(k,2), & + ! QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & + ! WEIRC(k), WEIRL(k),ORIFICEE(k), ORIFICEC(k), ORIFICEA(k)) + + elseif (channel_option .eq. 1) then !muskingum routing + Km = MUSK(k) + X = MUSX(k) + tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plust lateral inflow + elseif (channel_option .eq. 2) then ! muskingum cunge + + !HLINK(k) = MUSKINGCUNGE(k,Qup, Quc, QLINK(k,1), & + tmpQLINK(k,2) = MUSKINGCUNGE(k,Qup, Quc, QLINK(k,1), & + QLateral(k), DTRT_CH, So(k), CHANLEN(k), & + MannN(k), ChSSlp(k), Bw(k) ) + + ! AREA = (Bw(k) * HLINK(k) + 1/ChSSLP(k) * HLINK(k)**2) + ! WP = (Bw(k) * HLINK(k) + 1/ChSSLP(k) * HLINK(k)**2) / (Bw(k) + 2 * HLINK(k) * sqrt(1+(1/ChSSLP(k))**2)) + ! tmpQLINK(k,2) = ((1/MannN(k)) * AREA * WP**(2./3.) * sqrt(So(k))) + + else + print *, "FATAL ERROR: no channel option selected" + call hydro_stop("In drive_CHANNEL() - no channel option selected") + endif + endif !!! order(1) .ne. 1 + end do !--k links + +!yw check +! gQLINK = 0.0 +! call ReachLS_write_io(tmpQLINK(:,2), gQLINK(:,2)) +! call ReachLS_write_io(tmpQLINK(:,1), gQLINK(:,1)) +! write(6,*) " io_id = ", io_id +! if(my_id .eq. io_id) then +! write(71,*) gQLINK(:,1) +! call flush(71) +! call flush(72) +! endif + + do k = 1, NLINKSL + if(TYPEL(k) .ne. 1) then + QLINK(k,2) = tmpQLINK(k,2) + endif + QLINK(k,1) = QLINK(k,2) !assing link flow of current to be previous for next time step + end do + +!#ifdef MPP_LAND +! call ReachLS_write_io(QLINK(:,2),buf1) +! if(my_id .eq. IO_id) write(73,*) buf1 +!#else +! write(73,*) QLINK(1:NLINKSL,2) +!#endif + +#ifdef HYDRO_D + print *, "END OF ALL REACHES...",KRT,DT_STEPS +#endif + + end do ! nsteps + +! END DO !-- krt timestep for muksingumcunge routing + + elseif(channel_option .eq. 3) then !--- route using the diffusion scheme on nodes not links + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINK,NLINKS,99) + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOL,NLINKS,99) +#endif + + KRT = 0 !-- initialize the time counter + minDTCT = 0.01 ! define minimum routing sub-timestep (s), simulation will end with smaller timestep + DTCT = min(max(DTCT*2.0, minDTCT),DTRT_CH) + + HLINKTMP = HLINK !-- temporary storage of the water elevations (m) + CVOLTMP = CVOL !-- temporary storage of the volume of water in channel (m^3) + QLAKEIP = QLAKEI !-- temporary lake inflow from previous timestep (cms) + +! call check_channel(77,HLINKTMP,1,nlinks) +! call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,ZELEV,NLINKS,99) + crnt: DO !-- loop on the courant condition + QSUM = 0 !-- initialize the total flow out of each cell to zero + QLAKEI = 0 !-- set the lake inflow as zero + QLLAKE = 0 !-- initialize each lake's lateral inflow to zero + DT_STEPS=INT(DT/DTCT) !-- fix the timestep + QLateral = 0. +!DJG GW-chan coupling variables... + if(gwBaseSwCRT == 3) then + Q_GW_CHAN_FLUX = 0. + qgw_chanrt = 0. + end if + +! ZWATTBLRT=1.0 !--HARDWIRE, remove this and pass in from subsfc/gw routing routines... + + +!-- vectorize +!--------------------- +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS +#endif + + if(node_area(i) .eq. 0) then + write(6,*) "FATAL ERROR: node_area(i) is zero. i=", i + call hydro_stop("In drive_CHANNEL() - Error node_area") + endif + + + +nodeType:if((CH_NETRT(CHANXI(i), CHANYJ(i) ) .eq. 0) .and. & + (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .lt.0) ) then !--a reg. node + +gwOption: if(gwBaseSwCRT == 3) then + + ! determine potential gradient between groundwater head and channel stage + ! units in (m) + dzGwChanHead(i) = gwHead(CHANXI(i),CHANYJ(i)) - (HLINK(i)+ZELEV(i)) + + if(gwChanCondSw .eq. 0) then + + qgw_chanrt(CHANXI(i),CHANYJ(i)) = 0. + + else if(gwChanCondSw .eq. 1 .and. dzGwChanHead(i) > 0) then + + ! channel bed interface, units in (m^3/s), flux into channel... + ! BF todo: consider channel width + qgw_chanrt(CHANXI(i),CHANYJ(i)) = gwChanCondConstIn * dzGwChanHead(i) & + * CHANLEN(i) * 2. + + else if(gwChanCondSw .eq. 1 .and. dzGwChanHead(i) < 0) then + + ! channel bed interface, units in (m^3/s), flux out of channel... + ! BF todo: consider channel width + qgw_chanrt(CHANXI(i),CHANYJ(i)) = max(-0.005, gwChanCondConstOut * dzGwChanHead(i) & + * CHANLEN(i) * 2.) +! else if(gwChanCondSw .eq. 2 .and. dzGwChanHead(i) > 0) then TBD: exponential dependency +! else if(gwChanCondSw .eq. 2 .and. dzGwChanHead(i) > 0) then + + else + + qgw_chanrt(CHANXI(i),CHANYJ(i)) = 0. + + end if + + Q_GW_CHAN_FLUX(i) = qgw_chanrt(CHANXI(i),CHANYJ(i)) +! if ( i .eq. 1001 ) then +! print *, Q_GW_CHAN_FLUX(i), dzGwChanHead(i), ELRT(CHANXI(i),CHANYJ(i)), HLINK(i), ZELEV(i) +! end if +! if ( Q_GW_CHAN_FLUX(i) .lt. 0. ) then !-- temporary hardwire for only allowing flux into channel...REMOVE later... +! Q_GW_CHAN_FLUX(i) = 0. +! qgw_chanrt(CHANXI(i),CHANYJ(i)) = 0. +! end if + + else + Q_GW_CHAN_FLUX(i) = 0. + end if gwOption + + + QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & +!DJG awaiting gw-channel exchg... Q_GW_CHAN_FLUX(i)+& ...obsolete-> ((QSUBRT(CHANXI(i),CHANYJ(i))+& + Q_GW_CHAN_FLUX(i)+& + ((QSTRMVOLRT(CHANXI(i),CHANYJ(i))+& + QINFLOWBASE(CHANXI(i),CHANYJ(i))) & + /DT_STEPS*node_area(i)/1000/DTCT) + if((QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))).lt.0.) .and. (gwChanCondSw == 0)) then +#ifdef HYDRO_D + print*, "i, CHANXI(i),CHANYJ(i) = ", i, CHANXI(i),CHANYJ(i) + print *, "NEGATIVE Lat inflow...",QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))), & + QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)), & + QINFLOWBASE(CHANXI(i),CHANYJ(i)) +#endif + end if + elseif(LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .gt. 0 .and. & + (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. -9999)) then !--a lake node + QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) = & + QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) + & + (LAKEINFLORT(CHANXI(i),CHANYJ(i))+ & + QINFLOWBASE(CHANXI(i),CHANYJ(i)) & + /DT_STEPS*node_area(i)/1000/DTCT) + elseif(CH_NETRT(CHANXI(i),CHANYJ(i)) .gt. 0) then !pour out of lake + QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & + QLAKEO(CH_NETRT(CHANXI(i),CHANYJ(i))) !-- previous timestep + endif nodeType + ENDDO + + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLateral,NLINKS,99) + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) + endif +#endif + + !-- compute conveyances, with known depths (just assign to QLINK(,1) + !--QLINK(,2) will not be used), QLINK is the flow across the node face + !-- units should be m3/second.. consistent with QL (lateral flow) + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS +#endif + if (TYPEL(i) .eq. 0 .AND. HLINKTMP(FROM_NODE(i)) .gt. RETDEP_CHAN) then + if(from_node(i) .ne. to_node(i) .and. (to_node(i) .gt. 0) .and.(from_node(i) .gt. 0) ) & ! added by Wei Yu + QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & + HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & + CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) + else !-- we are just computing critical depth for outflow points + QLINK(i,1) =0. + endif + ENDDO + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) +#endif + + + !-- compute total flow across face, into node +#ifdef MPP_LAND + DO iyw = 1,yw_mpp_nlinks + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS !-- inflow to node across each face +#endif + if(TYPEL(i) .eq. 0) then !-- only regular nodes have to attribute + QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1) + endif + END DO + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,0) +#endif + + + +#ifdef MPP_LAND + DO iyw = 1,yw_mpp_nlinks + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS !-- outflow from node across each face +#endif + QSUM(FROM_NODE(i)) = QSUM(FROM_NODE(i)) - QLINK(i,1) + END DO +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99) +#endif + + + flag = 99 + + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1, NLINKS !--- compute volume and depth at each node +#endif + + if( TYPEL(i).eq.0 .and. CVOLTMP(i) .ge. 0.001 .and.(CVOLTMP(i)-QSUM(i)*DTCT)/CVOLTMP(i) .le. -0.01 ) then + flag = -99 +#ifdef HYDRO_D + write(6,*) "******* start diag ***************" + write(6,*) "Unstable at node ",i, "i=",CHANXI(i),"j=",CHANYJ(i) + write(6,*) "Unstatble at node ",i, "lat=",latval(CHANXI(i),CHANYJ(i)), "lon=",lonval(CHANXI(i),CHANYJ(i)) + write(6,*) "TYPEL, CVOLTMP, QSUM, QSUM*DTCT",TYPEL(i), CVOLTMP(i), QSUM(i), QSUM(i)*DTCT + write(6,*) "qsubrt, qstrmvolrt,qlink",QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)),qlink(i,1),qlink(i,2) +! write(6,*) "current nodes, z, h", ZELEV(FROM_NODE(i)),HLINKTMP(FROM_NODE(i)) +! if(TO_NODE(i) .gt. 0) then +! write(6,*) "to nodes, z, h", ZELEV(TO_NODE(i)), HLINKTMP(TO_NODE(i)) +! else +! write(6,*) "no to nodes " +! endif + write(6,*) "CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) ", CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) + write(6,*) "*******end of diag ***************" +#endif + + goto 999 + endif + enddo + +999 continue +#ifdef MPP_LAND + call mpp_same_int1(flag) +#endif + + + if(flag < 0 .and. DTCT >0.1) then + + ! call smoth121(HLINK,nlinks,maxv_p,pnode,to_node) + + if(DTCT .gt. minDTCT) then !-- timestep in seconds + DTCT = max(DTCT/2 , minDTCT) !-- 1/2 timestep + KRT = 0 !-- restart counter + HLINKTMP = HLINK !-- set head and vol to start value of timestep + CVOLTMP = CVOL + CYCLE crnt !-- start cycle over with smaller timestep + else + write(6,*) "Courant error with smallest routing timestep DTCT: ",DTCT +! call hydro_stop("drive_CHANNEL") + DTCT = 0.1 + HLINKTMP = HLINK !-- set head and volume to start values of timestep + CVOLTMP = CVOL + goto 998 + end if + endif + +998 continue + + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1, NLINKS !--- compute volume and depth at each node +#endif + + if(TYPEL(i) .eq. 0) then !-- regular channel grid point, compute volume + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) )* DTCT + if((CVOLTMP(i) .lt. 0) .and. (gwChanCondSw == 0)) then +#ifdef HYDRO_D + print *, "WARNING! channel volume less than 0:i,CVOL,QSUM,QLat", & + i, CVOLTMP(i),QSUM(i),QLateral(i),HLINK(i) +#endif + CVOLTMP(i) =0 + endif + + elseif(TYPEL(i) .eq. 1) then !-- pour point, critical depth downstream + + if (QSUM(i)+QLateral(i) .lt. 0) then + else + +!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) + CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... + endif + + ! change in volume is inflow, lateral flow, and outflow + !yw DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*DXRT),HLINKTMP(i), & + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & + DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & + CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT + elseif (TYPEL(i) .eq. 2) then !--- into a reservoir, assume critical depth + if ((QSUM(i)+QLateral(i) .lt. 0) .and. (gwChanCondSw == 0)) then +#ifdef HYDRO_D + print *, i, 'CrtDpth Qsum+QLat into lake< 0',QSUM(i), QLateral(i) +#endif + else +!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) + CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... + endif + + !-- compute volume in reach (m^3) + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & + DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & + CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT + !-- compute flow rate into lake from all contributing nodes (cms) + QLAKEI(LAKENODE(i)) = QLAKEI(LAKENODE(i)) + QLINK(FROM_NODE(i),1) + + else + print *, "FATAL ERROR: This node does not have a type.. error TYPEL =", TYPEL(i) + call hydro_stop("In drive_CHANNEL() - error TYPEL") + endif + + if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow + HLINKTMP(i) = HEAD(i, CVOLTMP(i)/CHANLEN(i),Bw(i),1/ChSSlp(i)) !--updated depth + else + HLINKTMP(i) = CD(i) !!! CRITICALDEPTH(i,QSUM(i)+QLateral(i), Bw(i), 1./ChSSlp(i)) !--critical depth is head + endif + + END DO !--- done processing all the links + + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOLTMP,NLINKS,99) + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CD,NLINKS,99) + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) + endif + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINKTMP,NLINKS,99) +#endif +! call check_channel(83,CVOLTMP,1,nlinks) +! call check_channel(84,CD,1,nlinks) +! call check_channel(85,HLINKTMP,1,nlinks) +! call check_lake(86,QLAKEI,lake_index,nlakes) + + + + + + do i = 1, NLAKES !-- mass balances of lakes +#ifdef MPP_LAND + if(lake_index(i) .gt. 0) then +#endif + CALL LEVELPOOL(i,QLAKEIP(i), QLAKEI(i), QLAKEO(i), QLLAKE(i), & + DTCT, RESHT(i), HRZAREA(i), WEIRH(i), LAKEMAXH(i), WEIRC(i), & + WEIRL(i), ORIFICEE(i), ORIFICEC(i), ORIFICEA(i)) + QLAKEIP(i) = QLAKEI(i) !-- store total lake inflow for this timestep +#ifdef MPP_LAND + endif +#endif + enddo +#ifdef MPP_LAND + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLLAKE,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99) + endif +#endif + + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1, NLINKS !--- compute volume and depth at each node +#endif + if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow + QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & + HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & + CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) + endif + enddo + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) +#endif + + KRT = KRT + 1 !-- iterate on the timestep + IF(KRT .eq. DT_STEPS) EXIT crnt !-- up to the maximum time in interval + + END DO crnt !--- DTCT timestep of DT_STEPS + + HLINK = HLINKTMP !-- update head based on final solution in timestep + CVOL = CVOLTMP !-- update volume + else !-- no channel option apparently selected + print *, "FATAL ERROR: no channel option selected" + call hydro_stop("In drive_CHANNEL() - no channel option selected") + endif + +#ifdef HYDRO_D + write(6,*) "finished call drive_CHANNEL" +#endif + + if (KT .eq. 1) KT = KT + 1 + + + END SUBROUTINE drive_CHANNEL +! ---------------------------------------------------------------- + +!-======================================= + REAL FUNCTION AREAf(AREA,Bw,h,z) + REAL :: AREA, Bw, z, h + AREAf = (Bw+z*h)*h-AREA !-- Flow area + END FUNCTION AREAf + +!-====critical depth function ========== + REAL FUNCTION CDf(Q,Bw,h,z) + REAL :: Q, Bw, z, h + if(h .le. 0) then + print *, "FATAL ERROR: head is zero, will get division by zero error" + call hydro_stop("In CDf() - head is zero") + else + CDf = (Q/((Bw+z*h)*h))/(sqrt(9.81*(((Bw+z*h)*h)/(Bw+2*z*h))))-1 !--critical depth function + endif + END FUNCTION CDf + +!=======find flow depth in channel with bisection Chapra pg. 131 + REAL FUNCTION HEAD(idx,AREA,Bw,z) !-- find the water elevation given wetted area, + !--bottom widith and side channel.. index was for debuggin + REAL :: Bw,z,AREA,test + REAL :: hl, hu, hr, hrold + REAL :: fl, fr,error !-- function evaluation + INTEGER :: maxiter, idx + + error = 1.0 + maxiter = 0 + hl = 0.00001 !-- minimum depth is small + hu = 30. !-- assume maximum depth is 30 meters + + if (AREA .lt. 0.00001) then + hr = 0. + else + do while ((AREAf(AREA,BW,hl,z)*AREAf(AREA,BW,hu,z)).gt.0 .and. maxiter .lt. 100) + !-- allows for larger , smaller heads + if(AREA .lt. 1.) then + hl=hl/2 + else + hu = hu * 2 + endif + maxiter = maxiter + 1 + + end do + + maxiter =0 + hr = 0 + fl = AREAf(AREA,Bw,hl,z) + do while (error .gt. 0.0001 .and. maxiter < 1000) + hrold = hr + hr = (hl+hu)/2 + fr = AREAf(AREA,Bw,hr,z) + maxiter = maxiter + 1 + if (hr .ne. 0) then + error = abs((hr - hrold)/hr) + endif + test = fl * fr + if (test.lt.0) then + hu = hr + elseif (test.gt.0) then + hl=hr + fl = fr + else + error = 0.0 + endif + end do + endif + HEAD = hr + +22 format("i,hl,hu,Area",i5,2x,f12.8,2x,f6.3,2x,f6.3,2x,f6.3,2x,f9.1,2x,i5) + + END FUNCTION HEAD +!================================= + REAL FUNCTION MANNING(h1,n,Bw,Cs) + + REAL :: Bw,h1,Cs,n + REAL :: z, AREA,R,Kd + + z=1/Cs + R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z*z)) !-- Hyd Radius + AREA = (Bw+z*h1)*h1 !-- Flow area + Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance +#ifdef HYDRO_D + print *,"head, kd", h1,Kd +#endif + MANNING = Kd + + END FUNCTION MANNING + +!=======find flow depth in channel with bisection Chapra pg. 131 + REAL FUNCTION CRITICALDEPTH(lnk,Q,Bw,z) !-- find the critical depth + REAL :: Bw,z,Q,test + REAL :: hl, hu, hr, hrold + REAL :: fl, fr,error !-- function evaluation + INTEGER :: maxiter + INTEGER :: lnk + + error = 1.0 + maxiter = 0 + hl = 1e-5 !-- minimum depth is 0.00001 meters +! hu = 35. !-- assume maximum critical depth 25 m + hu = 100. !-- assume maximum critical depth 25 m + + if(CDf(Q,BW,hl,z)*CDf(Q,BW,hu,z) .gt. 0) then + if(Q .gt. 0.001) then +#ifdef HYDRO_D + print *, "interval won't work to find CD of lnk ", lnk + print *, "Q, hl, hu", Q, hl, hu + print *, "cd lwr, upr", CDf(Q,BW,hl,z), CDf(Q,BW,hu,z) + ! call hydro_stop("In CRITICALDEPTH()") + CRITICALDEPTH = -9999 + return +#endif + else + Q = 0.0 + endif + endif + + hr = 0. + fl = CDf(Q,Bw,hl,z) + + if (Q .eq. 0.) then + hr = 0. + else + do while (error .gt. 0.0001 .and. maxiter < 1000) + hrold = hr + hr = (hl+hu)/2 + fr = CDf(Q,Bw,hr,z) + maxiter = maxiter + 1 + if (hr .ne. 0) then + error = abs((hr - hrold)/hr) + endif + test = fl * fr + if (test.lt.0) then + hu = hr + elseif (test.gt.0) then + hl=hr + fl = fr + else + error = 0.0 + endif + + end do + endif + + CRITICALDEPTH = hr + + END FUNCTION CRITICALDEPTH +!================================================ + REAL FUNCTION SGNf(val) !-- function to return the sign of a number + REAL:: val + + if (val .lt. 0) then + SGNf= -1. + elseif (val.gt.0) then + SGNf= 1. + else + SGNf= 0. + endif + + END FUNCTION SGNf +!================================================ + + REAL FUNCTION fnDX(qp,Tw,So,Ck,dx,dt) !-- find channel sub-length for MK method + REAL :: qp,Tw,So,Ck,dx, dt,test + REAL :: dxl, dxu, dxr, dxrold + REAL :: fl, fr, error + REAL :: X + INTEGER :: maxiter + + error = 1.0 + maxiter =0 + dxl = dx*0.9 !-- how to choose dxl??? + dxu = dx + dxr=0 + + do while (fnDXCDT(qp,Tw,So,Ck,dxl,dt)*fnDXCDT(qp,Tw,So,Ck,dxu,dt) .gt. 0 & + .and. dxl .gt. 10) !-- don't let dxl get too small + dxl = dxl/1.1 + end do + + + fl = fnDXCDT(qp,Tw,So,Ck,dxl,dt) + do while (error .gt. 0.0001 .and. maxiter < 1000) + dxrold = dxr + dxr = (dxl+dxu)/2 + fr = fnDXCDT(qp,Tw,So,Ck,dxr,dt) + maxiter = maxiter + 1 + if (dxr .ne. 0) then + error = abs((dxr - dxrold)/dxr) + endif + test = fl * fr + if (test.lt.0) then + dxu = dxr + elseif (test.gt.0) then + dxl=dxr + fl = fr + else + error = 0.0 + endif + end do + FnDX = dxr + + END FUNCTION fnDX +!================================================ + REAL FUNCTION fnDXCDT(qp,Tw,So,Ck,dx,dt) !-- function to help find sub-length for MK method + REAL :: qp,Tw,So,Ck,dx,dt,X + REAL :: c,b !-- coefficients on dx/cdt log approximation function + + c = 0.2407 + b = 1.16065 + X = 0.5-(qp/(2*Tw*So*Ck*dx)) + if (X .le.0) then + fnDXCDT = -1 !0.115 + else + fnDXCDT = (dx/(Ck*dt)) - (c*LOG(X)+b) !-- this function needs to converge to 0 + endif + END FUNCTION fnDXCDT +! ---------------------------------------------------------------------- + + subroutine check_lake(unit,cd,lake_index,nlakes) + use module_RT_data, only: rt_domain + implicit none + integer :: unit,nlakes,i,lake_index(nlakes) + real cd(nlakes) +#ifdef MPP_LAND + call write_lake_real(cd,lake_index,nlakes) +#endif + write(unit,*) cd + call flush(unit) + return + end subroutine check_lake + + subroutine check_channel(unit,cd,did,nlinks) + use module_RT_data, only: rt_domain +#ifdef MPP_LAND + USE module_mpp_land +#endif + implicit none + integer :: unit,nlinks,i, did + real cd(nlinks) +#ifdef MPP_LAND + real g_cd(rt_domain(did)%gnlinks) + call write_chanel_real(cd,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,nlinks,g_cd) + if(my_id .eq. IO_id) then + write(unit,*) "rt_domain(did)%gnlinks = ",rt_domain(did)%gnlinks + write(unit,*) g_cd + endif +#else + write(unit,*) cd +#endif + call flush(unit) + close(unit) + return + end subroutine check_channel + subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) + implicit none + integer,intent(in) :: nlinks, maxv_p + integer, intent(in), dimension(nlinks):: to_node + integer, intent(in), dimension(nlinks):: from_node(nlinks,maxv_p) + real, intent(inout), dimension(nlinks) :: var + real, dimension(nlinks) :: vartmp + integer :: i,j , k, from,to + integer :: plen + vartmp = 0 + do i = 1, nlinks + to = to_node(i) + plen = from_node(i,1) + if(plen .gt. 1) then + do k = 1, plen-1 + from = from_node(i,k+1) + if(to .gt. 0) then + vartmp(i) = vartmp(i)+0.25*(var(from)+2.*var(i)+var(to)) + else + vartmp(i) = vartmp(i)+(2.*var(i)+var(from))/3.0 + endif + end do + vartmp(i) = vartmp(i) /(plen-1) + else + if(to .gt. 0) then + vartmp(i) = vartmp(i)+(2.*var(i)+var(to)/3.0) + else + vartmp(i) = var(i) + endif + endif + end do + var = vartmp + return + end subroutine smoth121 + +! SUBROUTINE drive_CHANNEL for NHDPLUS +! ------------------------------------------------ + + Subroutine drive_CHANNEL_RSL(UDMP_OPT,KT, IXRT,JXRT, & + LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, & + TYPEL, ORDER, MAXORDER, CH_LNKRT, & + LAKE_MSKRT, DT, DTCT, DTRT_CH,MUSK, MUSX, QLINK, & + CHANLEN, MannN, So, ChSSlp, Bw, & + RESHT, HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, CVOL, QLAKEI, QLAKEO, LAKENODE, & + QINFLOWBASE, CHANXI, CHANYJ, channel_option, & + nlinks,NLINKSL, LINKID, node_area, qout_gwsubbas, & + LAKEIDA, LAKEIDM, NLAKES, LAKEIDX, & +#ifdef MPP_LAND + nlinks_index,mpp_nlinks,yw_mpp_nlinks, & + LNLINKSL, & + gtoNode,toNodeInd,nToNodeInd, & +#endif + CH_LNKRT_SL, landRunOff & +#ifdef WRF_HYDRO_NUDGING + , nudge & +#endif + + , accLndRunOff, accQLateral, accStrmvolrt, accBucket & + , QLateral, velocity & + ,nsize , OVRTSWCRT, SUBRTSWCRT ) + + use module_UDMAP, only: LNUMRSL, LUDRSL + +#ifdef WRF_HYDRO_NUDGING + use module_stream_nudging, only: setup_stream_nudging, & + nudge_term_all, & + nudgeWAdvance +#endif + + + IMPLICIT NONE + +! -------- DECLARATIONS ------------------------ + + INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option, OVRTSWCRT, SUBRTSWCRT + INTEGER, INTENT(IN) :: NLAKES, NLINKSL, nlinks + integer, INTENT(INOUT) :: KT ! flag of cold start (1) or continue run. + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKEINFLORT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QINFLOWBASE + real, dimension(ixrt,jxrt) :: landRunOff + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT_SL + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, INTENT(IN), DIMENSION(:) :: ORDER, TYPEL !--link + INTEGER, INTENT(IN), DIMENSION(:) :: TO_NODE, FROM_NODE + INTEGER, INTENT(IN), DIMENSION(:) :: CHANXI, CHANYJ + REAL, INTENT(IN), DIMENSION(:) :: MUSK, MUSX + REAL, INTENT(IN), DIMENSION(:) :: CHANLEN + REAL, INTENT(IN), DIMENSION(:) :: So, MannN + REAL, INTENT(IN), DIMENSION(:) :: ChSSlp,Bw !--properties of nodes or links + REAL :: Km, X + REAL , INTENT(INOUT), DIMENSION(:,:) :: QLINK +#ifdef WRF_HYDRO_NUDGING + real, intent(out), dimension(:) :: nudge +#endif + REAL, DIMENSION(:), intent(out) :: QLateral, velocity !--lateral flow + real, dimension(:), intent(out) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket + + REAL , DIMENSION(NLINKSL,2) :: tmpQLINK + REAL, INTENT(IN) :: DT !-- model timestep + REAL, INTENT(IN) :: DTRT_CH !-- routing timestep + REAL, INTENT(INOUT) :: DTCT + real :: minDTCT !BF minimum routing timestep + INTEGER, INTENT(IN) :: MAXORDER + REAL , INTENT(IN), DIMENSION(:) :: node_area + +!DJG GW-chan coupling variables... + REAL, DIMENSION(NLINKS) :: dzGwChanHead + REAL, DIMENSION(NLINKS) :: Q_GW_CHAN_FLUX !DJG !!! Change 'INTENT' to 'OUT' when ready to update groundwater state... + REAL, DIMENSION(IXRT,JXRT) :: ZWATTBLRT !DJG !!! Match with subsfce/gw routing & Change 'INTENT' to 'INOUT' when ready to update groundwater state... + + !-- lake params + + REAL, INTENT(IN), DIMENSION(:) :: HRZAREA !-- horizontal area (km^2) + REAL, INTENT(IN), DIMENSION(:) :: LAKEMAXH !-- maximum lake depth (m^2) + REAL, INTENT(IN), DIMENSION(:) :: WEIRH !-- lake depth (m^2) + REAL, INTENT(IN), DIMENSION(:) :: WEIRC !-- weir coefficient + REAL, INTENT(IN), DIMENSION(:) :: WEIRL !-- weir length (m) + REAL, INTENT(IN), DIMENSION(:) :: ORIFICEC !-- orrifice coefficient + REAL, INTENT(IN), DIMENSION(:) :: ORIFICEA !-- orrifice area (m^2) + REAL, INTENT(IN), DIMENSION(:) :: ORIFICEE !-- orrifce elevation (m) + INTEGER, INTENT(IN), DIMENSION(:) :: LAKEIDM !-- NHDPLUS lakeid for lakes to be modeled + + REAL, INTENT(INOUT), DIMENSION(:) :: RESHT !-- reservoir height (m) + REAL, INTENT(INOUT), DIMENSION(:) :: QLAKEI !-- lake inflow (cms) + REAL, DIMENSION(NLAKES) :: QLAKEIP !-- lake inflow previous timestep (cms) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEO !-- outflow from lake used in diffusion scheme + + INTEGER, INTENT(IN), DIMENSION(:) :: LAKENODE !-- outflow from lake used in diffusion scheme + INTEGER, INTENT(IN), DIMENSION(:) :: LINKID !-- id of channel elements for linked scheme + INTEGER, INTENT(IN), DIMENSION(:) :: LAKEIDA !-- (don't need) NHDPLUS lakeid for all lakes in domain + INTEGER, INTENT(IN), DIMENSION(:) :: LAKEIDX !-- the sequential index of the lakes id by com id + + REAL, DIMENSION(NLINKS) :: QSUM !--mass bal of node + REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme + integer :: nsize + +!-- Local Variables + INTEGER :: i,j,k,t,m,jj,ii,lakeid, kk,KRT,node, UDMP_OPT + INTEGER :: DT_STEPS !-- number of timestep in routing + REAL :: Qup,Quc !--Q upstream Previous, Q Upstream Current, downstream Previous + REAL :: bo !--critical depth, bnd outflow just for testing + + REAL ,DIMENSION(NLINKS) :: CD !-- critical depth + real, DIMENSION(IXRT,JXRT) :: tmp + real, dimension(nlinks) :: tmp2 + REAL, INTENT(INOUT), DIMENSION(:) :: CVOL + +#ifdef MPP_LAND + real*8, dimension(LNLINKSL) :: LQLateral + real*8, dimension(LNLINKSL) :: tmpLQLateral + real, dimension(NLINKSL) :: tmpQLateral + integer nlinks_index(:) + integer iyw, yw_mpp_nlinks, mpp_nlinks + real ywtmp(ixrt,jxrt) + integer LNLINKSL + integer, dimension(:) :: toNodeInd + integer, dimension(:,:) :: gtoNode + integer :: nToNodeInd + real, dimension(nToNodeInd,2) :: gQLINK +#else + real*8, dimension(NLINKS) :: tmpLQLateral + real, dimension(NLINKSL) :: tmpQLateral + real, dimension(NLINKSL) :: LQLateral +#endif + integer flag + + integer :: n, kk2, nt, nsteps ! tmp + real, dimension(:) :: qout_gwsubbas + real, allocatable,dimension(:) :: tmpQLAKEO, tmpQLAKEI, tmpRESHT + + + real, dimension(NLINKS) :: lcLndRunOff, lcQLateral, lcStrmvolrt, lcBucket ! local variables + + + + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + allocate(tmpQLAKEO(NLAKES)) + allocate(tmpQLAKEI(NLAKES)) + allocate(tmpRESHT(NLAKES)) +#ifdef MPP_LAND + endif +#endif + + QLAKEIP = 0 + CD = 0 + node = 1 + QLateral = 0 + QSUM = 0 + QLLAKE = 0 + dzGwChanHead = 0. + +#ifdef WRF_HYDRO_NUDGING + !! Initialize nudging for the current timestep. + !! This establishes the data structure used to solve the nudges. + call setup_stream_nudging(0) !! always zero b/c at beginning of hydro timestep +#endif /* WRF_HYDRO_NUDGING */ + + nsteps = (DT+0.5)/DTRT_CH + LQLateral = 0 !-- initial lateral flow to 0 for this reach + + + tmpLQLateral = 0 + tmpQLateral = 0 + + ! NHDPLUS maping + if(OVRTSWCRT .eq. 0) then + do k = 1, LNUMRSL + ! get from land grid runoff + do m = 1, LUDRSL(k)%ncell + ii = LUDRSL(k)%cell_i(m) + jj = LUDRSL(k)%cell_j(m) + LQLateral(k) = LQLateral(k)+landRunOff(ii,jj)*LUDRSL(k)%cellweight(m)/1000 & + *LUDRSL(k)%cellArea(m)/DT + tmpLQLateral(k) = tmpLQLateral(k)+landRunOff(ii,jj)*LUDRSL(k)%cellweight(m)/1000 & + *LUDRSL(k)%cellArea(m)/DT + end do + end do +#ifdef MPP_LAND + call updateLinkV(tmpLQLateral, tmpQLateral) +#endif + if(NLINKSL .gt. 0) then + accLndRunOff(1:NLINKSL) = accLndRunOff(1:NLINKSL) + tmpQLateral(1:NLINKSL) * DT + endif + tmpLQLateral = 0 + tmpQLateral = 0 + endif + + if(OVRTSWCRT .ne. 0 .or. SUBRTSWCRT .ne. 0 ) then + do k = 1, LNUMRSL + ! get from channel grid + do m = 1, LUDRSL(k)%ngrids + ii = LUDRSL(k)%grid_i(m) + jj = LUDRSL(k)%grid_j(m) + LQLateral(k) = LQLateral(k) + QSTRMVOLRT(ii,jj)*LUDRSL(k)%weight(m)/1000 & + *LUDRSL(k)%nodeArea(m)/DT + tmpLQLateral(k) = tmpLQLateral(k) + QSTRMVOLRT(ii,jj)*LUDRSL(k)%weight(m)/1000 & + *LUDRSL(k)%nodeArea(m)/DT + end do + end do +#ifdef MPP_LAND + call updateLinkV(tmpLQLateral, tmpQLateral) +#endif + if(NLINKSL .gt. 0) then + accStrmvolrt(1:NLINKSL) = accStrmvolrt(1:NLINKSL) + tmpQLateral(1:NLINKSL) * DT + endif + endif + + +#ifdef MPP_LAND + call updateLinkV(LQLateral, QLateral(1:NLINKSL)) +#else + call hydro_stop("fatal error: NHDPlus only works for parallel now.") + QLateral = LQLateral +#endif + + if(NLINKSL .gt. 0) then + QLateral(1:NLINKSL) = QLateral(1:NLINKSL) + qout_gwsubbas(1:NLINKSL) + endif + + ! accQLateral = accLndRunOff + QLateral * DT + if(NLINKSL .gt. 0) then + accQLateral(1:NLINKSL) = accQLateral(1:NLINKSL) + QLateral(1:NLINKSL) * DT + accBucket(1:NLINKSL) = accBucket(1:NLINKSL) + qout_gwsubbas(1:NLINKSL) * DT + endif + +! QLateral = QLateral / nsteps + + do nt = 1, nsteps + +#ifdef MPP_LAND + + gQLINK = 0 + call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,2), NLINKSL, gQLINK(:,2)) + call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,1), NLINKSL, gQLINK(:,1)) + !---------- route other reaches, with upstream inflow +#endif + + tmpQlink = 0 +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + tmpQLAKEO = QLAKEO + tmpQLAKEI = QLAKEI + tmpRESHT = RESHT +#ifdef MPP_LAND + endif +#endif + + + DO k = 1,NLINKSL + + Quc = 0 + Qup = 0 + + !process as standard link or a lake inflow link, or lake outflow link + ! link flowing out of lake, accumulate all the inflows with the revised TO_NODEs + ! TYPEL = -999 stnd; TYPEL=1 outflow from lake; TYPEL = 3 inflow to a lake + + if(TYPEL(k) .ne. 2) then ! don't process internal lake links only + +#ifdef MPP_LAND +!using mapping index + do n = 1, gtoNODE(k,1) + m = gtoNODE(k,n+1) + if(gQLINK(m,2) .gt. 0) Quc = Quc + gQLINK(m,2) !--accum of upstream inflow of current timestep (2) + if(gQLINK(m,1) .gt. 0) Qup = Qup + gQLINK(m,1) !--accum of upstream inflow of previous timestep (1) + end do ! do i +#else + do m = 1, NLINKSL + + if (LINKID(k) .eq. TO_NODE(m)) then + Quc = Quc + QLINK(m,2) !--accum of upstream inflow of current timestep (2) + Qup = Qup + QLINK(m,1) !--accum of upstream inflow of previous timestep (1) + endif + end do ! do m +#endif + endif !note that we won't process type 2 links, since they are internal to a lake + + +!yw ### process each link k, +! There is a situation that different k point to the same LAKEIDX +! if(TYPEL(k) .eq. 1 .and. LAKEIDX(k) .gt. 0) then !--link is a reservoir + if(TYPEL(k) .eq. 1 ) then !--link is a reservoir + + lakeid = LAKEIDX(k) + if(lakeid .ge. 0) then + CALL LEVELPOOL(lakeid,Qup, Quc, tmpQLINK(k,2), & + QLateral(k), DT, RESHT(lakeid), HRZAREA(lakeid), WEIRH(lakeid), LAKEMAXH(lakeid), & + WEIRC(lakeid), WEIRL(lakeid),ORIFICEE(lakeid), ORIFICEC(lakeid), ORIFICEA(lakeid)) + + QLAKEO(lakeid) = tmpQLINK(k,2) !save outflow to lake + QLAKEI(lakeid) = Quc !save inflow to lake + endif +105 continue + + + elseif (channel_option .eq. 1) then !muskingum routing + Km = MUSK(k) + X = MUSX(k) + tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plust lateral inflow + + elseif (channel_option .eq. 2) then ! muskingum cunge, don't process internal lake nodes TYP=2 +! tmpQLINK(k,2) = MUSKINGCUNGE(k,Qup, Quc, QLINK(k,1), & +! QLateral(k), DTRT_CH, So(k), CHANLEN(k), & +! MannN(k), ChSSlp(k), Bw(k) ) + + CALL SUBMUSKINGCUNGE(tmpQLINK(k,2),velocity(k), k,Qup, Quc, QLINK(k,1), & + QLateral(k), DTRT_CH, So(k), CHANLEN(k), & + MannN(k), ChSSlp(k), Bw(k) ) + + else +#ifdef HYDRO_D + print *, " no channel option selected" +#endif + call hydro_stop("drive_CHANNEL") + endif + + END DO !--k links + +#ifdef MPP_LAND + call updateLake_seq(QLAKEO,nlakes,tmpQLAKEO) + call updateLake_seq(QLAKEI,nlakes,tmpQLAKEI) + call updateLake_seq(RESHT,nlakes,tmpRESHT) +#endif + + do k = 1, NLINKSL !tmpQLINK? + if(TYPEL(k) .ne. 2) then !only the internal lake nodes don't have info.. but need to save QLINK of lake out too + QLINK(k,2) = tmpQLINK(k,2) + endif + QLINK(k,1) = QLINK(k,2) !assigng link flow of current to be previous for next time step + end do + + +#ifdef WRF_HYDRO_NUDGING + if(.not. nudgeWAdvance) call nudge_term_all(qlink, nudge, int(nt*dtrt_ch)) +#endif /* WRF_HYDRO_NUDGING */ + + +!#ifdef HYDRO_D +! print *, "END OF ALL REACHES...",KRT,DT_STEPS +!#endif + + end do ! nsteps + + if (KT .eq. 1) KT = KT + 1 + +#ifdef MPP_LAND + if(my_id .eq. io_id) then + if(allocated(tmpQLAKEO)) deallocate(tmpQLAKEO) + if(allocated(tmpQLAKEI)) deallocate(tmpQLAKEI) + if(allocated(tmpRESHT)) deallocate(tmpRESHT) + endif +#endif + + if (KT .eq. 1) KT = KT + 1 + + END SUBROUTINE drive_CHANNEL_RSL + +! ---------------------------------------------------------------- + +END MODULE module_channel_routing + +#ifdef MPP_LAND + subroutine checkReach(ii, inVar) + use module_mpp_land + use module_RT_data, only: rt_domain + use MODULE_mpp_ReachLS, only : updatelinkv, & + ReachLS_write_io, gbcastvalue, & + gbcastreal2 + implicit none + integer :: ii + real,dimension(rt_domain(1)%nlinksl) :: inVar + real:: g_var(rt_domain(1)%gnlinksl) + call ReachLS_write_io(inVar, g_var) + if(my_id .eq. io_id) then + write(ii,*) g_var + call flush(ii) + endif + end subroutine checkReach +#endif diff --git a/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F new file mode 100644 index 00000000..1b71ea79 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F @@ -0,0 +1,1032 @@ +! Program Name: +! 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_Date_utilities_rt +contains + subroutine geth_newdate (ndate, odate, idt) + implicit none + + ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and + ! delta-time, compute the new date. + + ! on entry - odate - the old hdate. + ! idt - the change in time + + ! on exit - ndate - the new hdate. + + integer, intent(in) :: idt + character (len=*), intent(out) :: ndate + character (len=*), intent(in) :: odate + + ! Local Variables + + ! yrold - indicates the year associated with "odate" + ! moold - indicates the month associated with "odate" + ! dyold - indicates the day associated with "odate" + ! hrold - indicates the hour associated with "odate" + ! miold - indicates the minute associated with "odate" + ! scold - indicates the second associated with "odate" + + ! yrnew - indicates the year associated with "ndate" + ! monew - indicates the month associated with "ndate" + ! dynew - indicates the day associated with "ndate" + ! hrnew - indicates the hour associated with "ndate" + ! minew - indicates the minute associated with "ndate" + ! scnew - indicates the second associated with "ndate" + + ! mday - a list assigning the number of days in each month + + ! i - loop counter + ! nday - the integer number of days represented by "idt" + ! nhour - the integer number of hours in "idt" after taking out + ! all the whole days + ! nmin - the integer number of minutes in "idt" after taking out + ! all the whole days and whole hours. + ! nsec - the integer number of minutes in "idt" after taking out + ! all the whole days, whole hours, and whole minutes. + + integer :: newlen, oldlen + integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + integer :: yrold, moold, dyold, hrold, miold, scold, frold + integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc + logical :: opass + character (len=10) :: hfrc + character (len=1) :: sp + logical :: punct + integer :: yrstart, yrend, mostart, moend, dystart, dyend + integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart + integer :: units + integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) + + ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." + if (odate(5:5) == "-") then + punct = .TRUE. + else + punct = .FALSE. + endif + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + oldlen = LEN(odate) + if (punct) then + yrstart = 1 + yrend = 4 + mostart = 6 + moend = 7 + dystart = 9 + dyend = 10 + hrstart = 12 + hrend = 13 + mistart = 15 + miend = 16 + scstart = 18 + scend = 19 + frstart = 21 + select case (oldlen) + case (10) + ! Days + units = 1 + case (13) + ! Hours + units = 2 + case (16) + ! Minutes + units = 3 + case (19) + ! Seconds + units = 4 + case (21) + ! Tenths + units = 5 + case (22) + ! Hundredths + units = 6 + case (23) + ! Thousandths + units = 7 + case (24) + ! Ten thousandths + units = 8 + case default + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("In geth_newdate() odd length") + end select + + if (oldlen.ge.11) then + sp = odate(11:11) + else + sp = ' ' + end if + + else + + yrstart = 1 + yrend = 4 + mostart = 5 + moend = 6 + dystart = 7 + dyend = 8 + hrstart = 9 + hrend = 10 + mistart = 11 + miend = 12 + scstart = 13 + scend = 14 + frstart = 15 + + select case (oldlen) + case (8) + ! Days + units = 1 + case (10) + ! Hours + units = 2 + case (12) + ! Minutes + units = 3 + case (14) + ! Seconds + units = 4 + case (15) + ! Tenths + units = 5 + case (16) + ! Hundredths + units = 6 + case (17) + ! Thousandths + units = 7 + case (18) + ! Ten thousandths + units = 8 + case default + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("In geth_newdate() - odd length") + end select + endif + + ! Use internal READ statements to convert the CHARACTER string + ! date into INTEGER components. + + read(odate(yrstart:yrend), '(i4)') yrold + read(odate(mostart:moend), '(i2)') moold + read(odate(dystart:dyend), '(i2)') dyold + if (units.ge.2) then + read(odate(hrstart:hrend),'(i2)') hrold + if (units.ge.3) then + read(odate(mistart:miend),'(i2)') miold + if (units.ge.4) then + read(odate(scstart:scend),'(i2)') scold + if (units.ge.5) then + read(odate(frstart:oldlen),*) frold + end if + end if + end if + end if + + ! Set the number of days in February for that year. + + mday(2) = nfeb(yrold) + + ! Check that ODATE makes sense. + + opass = .TRUE. + + ! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold +#endif + opass = .FALSE. + end if + + ! Check that the day of ODATE makes sense. + + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold +#endif + opass = .FALSE. + end if + + ! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold +#endif + opass = .FALSE. + end if + + ! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold +#endif + opass = .FALSE. + end if + + ! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold +#endif + opass = .FALSE. + end if + + ! Check that the fractional part of ODATE makes sense. + + + if (.not.opass) then +#ifdef HYDRO_D + write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen + call hydro_stop("In geth_newdate() - Crazy ODATE") +#endif + end if + + ! Date Checks are completed. Continue. + + + ! Compute the number of days, hours, minutes, and seconds in idt + + if (units.ge.5) then !idt should be in fractions of seconds + ifrc = oldlen-(frstart)+1 + ifrc = 10**ifrc + nday = abs(idt)/(86400*ifrc) + nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) + nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) + nsec = mod(abs(idt),60*ifrc)/(ifrc) + nfrac = mod(abs(idt), ifrc) + else if (units.eq.4) then !idt should be in seconds + ifrc = 1 + nday = abs(idt)/86400 ! integer number of days in delta-time + nhour = mod(abs(idt),86400)/3600 + nmin = mod(abs(idt),3600)/60 + nsec = mod(abs(idt),60) + nfrac = 0 + else if (units.eq.3) then !idt should be in minutes + ifrc = 1 + nday = abs(idt)/1440 ! integer number of days in delta-time + nhour = mod(abs(idt),1440)/60 + nmin = mod(abs(idt),60) + nsec = 0 + nfrac = 0 + else if (units.eq.2) then !idt should be in hours + ifrc = 1 + nday = abs(idt)/24 ! integer number of days in delta-time + nhour = mod(abs(idt),24) + nmin = 0 + nsec = 0 + nfrac = 0 + else if (units.eq.1) then !idt should be in days + ifrc = 1 + nday = abs(idt) ! integer number of days in delta-time + nhour = 0 + nmin = 0 + nsec = 0 + nfrac = 0 + else + write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & + oldlen + write(*,*) '#'//odate(1:oldlen)//'#' + call hydro_stop("In geth_newdate()") + end if + + if (idt.ge.0) then + + frnew = frold + nfrac + if (frnew.ge.ifrc) then + frnew = frnew - ifrc + nsec = nsec + 1 + end if + + scnew = scold + nsec + if (scnew .ge. 60) then + scnew = scnew - 60 + nmin = nmin + 1 + end if + + minew = miold + nmin + if (minew .ge. 60) then + minew = minew - 60 + nhour = nhour + 1 + end if + + hrnew = hrold + nhour + if (hrnew .ge. 24) then + hrnew = hrnew - 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew + 1 + if (dynew.gt.mday(monew)) then + dynew = dynew - mday(monew) + monew = monew + 1 + if (monew .gt. 12) then + monew = 1 + yrnew = yrnew + 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + end if + end if + end do + + else if (idt.lt.0) then + + frnew = frold - nfrac + if (frnew .lt. 0) then + frnew = frnew + ifrc + nsec = nsec + 1 + end if + + scnew = scold - nsec + if (scnew .lt. 00) then + scnew = scnew + 60 + nmin = nmin + 1 + end if + + minew = miold - nmin + if (minew .lt. 00) then + minew = minew + 60 + nhour = nhour + 1 + end if + + hrnew = hrold - nhour + if (hrnew .lt. 00) then + hrnew = hrnew + 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew - 1 + if (dynew.eq.0) then + monew = monew - 1 + if (monew.eq.0) then + monew = 12 + yrnew = yrnew - 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + end if + dynew = mday(monew) + end if + end do + end if + + ! Now construct the new mdate + + newlen = LEN(ndate) + + if (punct) then + + if (newlen.gt.frstart) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew +19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) + + else if (newlen.eq.miend) then + write(ndate,16) yrnew, monew, dynew, hrnew, minew +16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) + + else if (newlen.eq.hrend) then + write(ndate,13) yrnew, monew, dynew, hrnew +13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) + + else if (newlen.eq.dyend) then + write(ndate,10) yrnew, monew, dynew +10 format(i4,'-',i2.2,'-',i2.2) + + end if + + else + + if (newlen.gt.frstart) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew +119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.miend) then + write(ndate,116) yrnew, monew, dynew, hrnew, minew +116 format(i4,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.hrend) then + write(ndate,113) yrnew, monew, dynew, hrnew +113 format(i4,i2.2,i2.2,i2.2) + + else if (newlen.eq.dyend) then + write(ndate,110) yrnew, monew, dynew +110 format(i4,i2.2,i2.2) + + end if + + endif + + if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp + + end subroutine geth_newdate + + subroutine geth_idts (newdate, olddate, idt) + + implicit none + + ! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), + ! compute the time difference. + + ! on entry - newdate - the new hdate. + ! olddate - the old hdate. + + ! on exit - idt - the change in time. + ! Units depend on length of date strings. + + character (len=*) , intent(in) :: newdate, olddate + integer , intent(out) :: idt + + + ! Local Variables + + ! yrnew - indicates the year associated with "ndate" + ! yrold - indicates the year associated with "odate" + ! monew - indicates the month associated with "ndate" + ! moold - indicates the month associated with "odate" + ! dynew - indicates the day associated with "ndate" + ! dyold - indicates the day associated with "odate" + ! hrnew - indicates the hour associated with "ndate" + ! hrold - indicates the hour associated with "odate" + ! minew - indicates the minute associated with "ndate" + ! miold - indicates the minute associated with "odate" + ! scnew - indicates the second associated with "ndate" + ! scold - indicates the second associated with "odate" + ! i - loop counter + ! mday - a list assigning the number of days in each month + + ! ndate, odate: local values of newdate and olddate + character(len=24) :: ndate, odate + + integer :: oldlen, newlen + integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + integer :: yrold, moold, dyold, hrold, miold, scold, frold + integer :: i, newdys, olddys + logical :: npass, opass + integer :: timesign + integer :: ifrc + integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) + logical :: punct + integer :: yrstart, yrend, mostart, moend, dystart, dyend + integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart + integer :: units + + oldlen = len(olddate) + newlen = len(newdate) + if (newlen.ne.oldlen) then + write(*,'("GETH_IDTS: NEWLEN /= OLDLEN: ", A, 3x, A)') newdate(1:newlen), olddate(1:oldlen) + call hydro_stop("In geth_idts() - NEWLEN /= OLDLEN") + endif + + if (olddate.gt.newdate) then + timesign = -1 + + ifrc = oldlen + oldlen = newlen + newlen = ifrc + + ndate = olddate + odate = newdate + else + timesign = 1 + ndate = newdate + odate = olddate + end if + + ! Break down old hdate into parts + + ! Determine if olddate is punctuated or not + if (odate(5:5) == "-") then + punct = .TRUE. + if (ndate(5:5) /= "-") then + write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & + ndate(1:newlen), odate(1:oldlen) + call hydro_stop("In geth_idts() - Dates appear to be different formats") + endif + else + punct = .FALSE. + if (ndate(5:5) == "-") then + write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & + ndate(1:newlen), odate(1:oldlen) + call hydro_stop("In geth_idts() - Dates appear to be different formats") + endif + endif + + if (punct) then + yrstart = 1 + yrend = 4 + mostart = 6 + moend = 7 + dystart = 9 + dyend = 10 + hrstart = 12 + hrend = 13 + mistart = 15 + miend = 16 + scstart = 18 + scend = 19 + frstart = 21 + select case (oldlen) + case (10) + ! Days + units = 1 + case (13) + ! Hours + units = 2 + case (16) + ! Minutes + units = 3 + case (19) + ! Seconds + units = 4 + case (21) + ! Tenths + units = 5 + case (22) + ! Hundredths + units = 6 + case (23) + ! Thousandths + units = 7 + case (24) + ! Ten thousandths + units = 8 + case default + write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' + call hydro_stop("In geth_idts() - odd length") + end select + else + + yrstart = 1 + yrend = 4 + mostart = 5 + moend = 6 + dystart = 7 + dyend = 8 + hrstart = 9 + hrend = 10 + mistart = 11 + miend = 12 + scstart = 13 + scend = 14 + frstart = 15 + + select case (oldlen) + case (8) + ! Days + units = 1 + case (10) + ! Hours + units = 2 + case (12) + ! Minutes + units = 3 + case (14) + ! Seconds + units = 4 + case (15) + ! Tenths + units = 5 + case (16) + ! Hundredths + units = 6 + case (17) + ! Thousandths + units = 7 + case (18) + ! Ten thousandths + units = 8 + case default + write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' + call hydro_stop("In geth_idts() - odd length") + end select + endif + + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + + read(odate(yrstart:yrend), '(i4)') yrold + read(odate(mostart:moend), '(i2)') moold + read(odate(dystart:dyend), '(i2)') dyold + if (units.ge.2) then + read(odate(hrstart:hrend),'(i2)') hrold + if (units.ge.3) then + read(odate(mistart:miend),'(i2)') miold + if (units.ge.4) then + read(odate(scstart:scend),'(i2)') scold + if (units.ge.5) then + read(odate(frstart:oldlen),*) frold + end if + end if + end if + end if + + ! Break down new hdate into parts + + hrnew = 0 + minew = 0 + scnew = 0 + frnew = 0 + + read(ndate(yrstart:yrend), '(i4)') yrnew + read(ndate(mostart:moend), '(i2)') monew + read(ndate(dystart:dyend), '(i2)') dynew + if (units.ge.2) then + read(ndate(hrstart:hrend),'(i2)') hrnew + if (units.ge.3) then + read(ndate(mistart:miend),'(i2)') minew + if (units.ge.4) then + read(ndate(scstart:scend),'(i2)') scnew + if (units.ge.5) then + read(ndate(frstart:newlen),*) frnew + end if + end if + end if + end if + + ! Check that the dates make sense. + + npass = .true. + opass = .true. + + ! Check that the month of NDATE makes sense. + + if ((monew.gt.12).or.(monew.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_IDTS: Month of NDATE = ', monew +#endif + npass = .false. + end if + + ! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Month of ODATE = ', moold +#endif + opass = .false. + end if + + ! Check that the day of NDATE makes sense. + + if (monew.ne.2) then + ! ...... For all months but February + if ((dynew.gt.mday(monew)).or.(dynew.lt.1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of NDATE = ', dynew +#endif + npass = .false. + end if + else if (monew.eq.2) then + ! ...... For February + if ((dynew > nfeb(yrnew)).or.(dynew < 1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of NDATE = ', dynew +#endif + npass = .false. + end if + endif + + ! Check that the day of ODATE makes sense. + + if (moold.ne.2) then + ! ...... For all months but February + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of ODATE = ', dyold +#endif + opass = .false. + end if + else if (moold.eq.2) then + ! ....... For February + if ((dyold > nfeb(yrold)).or.(dyold < 1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of ODATE = ', dyold +#endif + opass = .false. + end if + end if + + ! Check that the hour of NDATE makes sense. + + if ((hrnew.gt.23).or.(hrnew.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Hour of NDATE = ', hrnew +#endif + npass = .false. + end if + + ! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Hour of ODATE = ', hrold +#endif + opass = .false. + end if + + ! Check that the minute of NDATE makes sense. + + if ((minew.gt.59).or.(minew.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Minute of NDATE = ', minew +#endif + npass = .false. + end if + + ! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Minute of ODATE = ', miold +#endif + opass = .false. + end if + + ! Check that the second of NDATE makes sense. + + if ((scnew.gt.59).or.(scnew.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: SECOND of NDATE = ', scnew +#endif + npass = .false. + end if + + ! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Second of ODATE = ', scold +#endif + opass = .false. + end if + + if (.not. npass) then + print*, 'Screwy NDATE: ', ndate(1:newlen) + call hydro_stop("In geth_idts() - Screwy NDATE ") + end if + + if (.not. opass) then + print*, 'Screwy ODATE: ', odate(1:oldlen) + call hydro_stop("In geth_idts() - Screwy ODATE ") + end if + + ! Date Checks are completed. Continue. + + ! Compute number of days from 1 January ODATE, 00:00:00 until ndate + ! Compute number of hours from 1 January ODATE, 00:00:00 until ndate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate + + newdys = 0 + do i = yrold, yrnew - 1 + newdys = newdys + 337 + nfeb(i) + end do + + if (monew .gt. 1) then + mday(2) = nfeb(yrnew) + do i = 1, monew - 1 + newdys = newdys + mday(i) + end do + mday(2) = 28 + end if + + newdys = newdys + dynew - 1 + + ! Compute number of hours from 1 January ODATE, 00:00:00 until odate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until odate + + olddys = 0 + + if (moold .gt. 1) then + mday(2) = nfeb(yrold) + do i = 1, moold - 1 + olddys = olddys + mday(i) + end do + mday(2) = 28 + end if + + olddys = olddys + dyold -1 + + ! Determine the time difference + + idt = (newdys - olddys) + if (units.ge.2) then + idt = idt*24 + (hrnew - hrold) + if (units.ge.3) then + idt = idt*60 + (minew - miold) + if (units.ge.4) then + idt = idt*60 + (scnew - scold) + if (units.ge.5) then + ifrc = oldlen-(frstart-1) + ifrc = 10**ifrc + idt = idt * ifrc + (frnew-frold) + endif + endif + endif + endif + + if (timesign .eq. -1) then + idt = idt * timesign + end if + + end subroutine geth_idts + + + integer function nfeb(year) + ! + ! Compute the number of days in February for the given year. + ! + implicit none + integer, intent(in) :: year ! Four-digit year + + nfeb = 28 ! By default, February has 28 days ... + if (mod(year,4).eq.0) then + nfeb = 29 ! But every four years, it has 29 days ... + if (mod(year,100).eq.0) then + nfeb = 28 ! Except every 100 years, when it has 28 days ... + if (mod(year,400).eq.0) then + nfeb = 29 ! Except every 400 years, when it has 29 days ... + if (mod(year,3600).eq.0) then + nfeb = 28 ! Except every 3600 years, when it has 28 days. + endif + endif + endif + endif + end function nfeb + + integer function nmdays(hdate) + ! + ! Compute the number of days in the month of given date hdate. + ! + implicit none + character(len=*), intent(in) :: hdate + + integer :: year, month + integer, dimension(12), parameter :: ndays = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) + + read(hdate(1:7), '(I4,1x,I2)') year, month + + if (month == 2) then + nmdays = nfeb(year) + else + nmdays = ndays(month) + endif + end function nmdays + + function monthabbr_to_mm(mon) result(mm) + implicit none + + character(len=3), intent(in) :: mon + + integer :: mm + + if (mon == "Jan") then + mm = 1 + elseif (mon == "Feb") then + mm = 2 + elseif (mon == "Mar") then + mm = 3 + elseif (mon == "Apr") then + mm = 4 + elseif (mon == "May") then + mm = 5 + elseif (mon == "Jun") then + mm = 6 + elseif (mon == "Jul") then + mm = 7 + elseif (mon == "Aug") then + mm = 8 + elseif (mon == "Sep") then + mm = 9 + elseif (mon == "Oct") then + mm = 10 + elseif (mon == "Nov") then + mm = 11 + elseif (mon == "Dec") then + mm = 12 + else + write(*, '("Function monthabbr_to_mm: mon = <",A,">")') mon + print*, "Function monthabbr_to_mm: Unrecognized mon" + call hydro_stop("In monthabbr_to_mm() - Unrecognized mon") + endif + end function monthabbr_to_mm + + subroutine swap_date_format(indate, outdate) + implicit none + character(len=*), intent(in) :: indate + character(len=*), intent(out) :: outdate + integer :: inlen + + inlen = len(indate) + if (indate(5:5) == "-") then + select case (inlen) + case (10) + ! YYYY-MM-DD + outdate = indate(1:4)//indate(6:7)//indate(9:10) + case (13) + ! YYYY-MM-DD_HH + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13) + case (16) + ! YYYY-MM-DD_HH:mm + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16) + case (19) + ! YYYY-MM-DD_HH:mm:ss + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& + indate(18:19) + case (21,22,23,24) + ! YYYY-MM-DD_HH:mm:ss.f[f[f[f]]] + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& + indate(18:19)//indate(21:inlen) + case default + write(*,'("Unrecognized length: <", A,">")') indate + call hydro_stop("In swap_date_format() - Unrecognized length") + end select + else + select case (inlen) + case (8) + ! YYYYMMDD + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8) + case (10) + ! YYYYMMDDHH + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10) + case (12) + ! YYYYMMDDHHmm + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10)//":"//indate(11:12) + case (14) + ! YYYYMMDDHHmmss + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10)//":"//indate(11:12)//":"//indate(13:14) + case (15,16,17,18) + ! YYYYMMDDHHmmssf[f[f[f]]] + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10)//":"//indate(11:12)//":"//indate(13:14)//"."//indate(15:inlen) + case default + write(*,'("Unrecognized length: <", A,">")') indate + call hydro_stop("In swap_date_format() - Unrecognized length") + end select + endif + + end subroutine swap_date_format + + character(len=3) function mm_to_monthabbr(ii) result(mon) + implicit none + integer, intent(in) :: ii + character(len=3), parameter, dimension(12) :: month = (/ & + "Jan", "Feb", "Mar", "Apr", "May", "Jun", & + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" /) + if (ii > 0 .and. ii < 13 ) then + mon = month(ii) + else +! print*, "mm_to_monthabbr" + call hydro_stop("In mm_to_monthabbr() - mm_to_monthabbr") + endif + end function mm_to_monthabbr + +end module Module_Date_utilities_rt diff --git a/wrfv2_fire/hydro/Routing/module_gw_gw2d.F b/wrfv2_fire/hydro/Routing/module_gw_gw2d.F new file mode 100644 index 00000000..0ea58070 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_gw_gw2d.F @@ -0,0 +1,2159 @@ +! Program Name: +! 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: + +!------------------------------------------------------------------------------ +! Benjamin Fersch 2d groundwater model +!------------------------------------------------------------------------------ + + +module module_gw_gw2d + + +#ifdef MPP_LAND + use module_mpp_land +#endif + use module_gw_gw2d_data, only: gw2d + use module_rt_data, only: rt_domain + use module_namelist + + implicit none + +#include "gw_field_include.inc" + + +#ifdef MPP_LAND + integer, private :: ierr + integer, parameter :: rowshift = 0 + integer, parameter :: colshift = 1 +#endif + + + contains + + + subroutine gw2d_ini(did,dt,dx) + + use module_HYDRO_io, only: output_gw_spinup + + implicit none + integer did + real dt,dx + integer :: jj, ii, iter, itermax + + + + + itermax = nlst_rt(did)%GwPreCycles + gw2d(did)%dx=dx + gw2d(did)%dt=dt + + gw2d(did)%qgw_chanrt = 0. + gw2d(did)%qsgwrt = 0. + gw2d(did)%qdarcyRT = 0. + gw2d(did)%excess = 0. + + gw2d(did)%compres=0. ! currently not implemented + gw2d(did)%istep=0 ! initialize time step + ! reset cells with undefined hydraulic conductivity + where(gw2d(did)%hycond .eq. 100) gw2d(did)%hycond = 5E-4 + + do iter=1,itermax +#ifdef HYDRO_D +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + write(6,*) " GW Pre-cycle", iter, "of", itermax +#endif + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, gw2d(did)%excess, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + iter) + + gw2d(did)%ho = gw2d(did)%h + + if((nlst_rt(did)%GwPreDiag .and. iter==1) .or. & + nlst_rt(did)%GwPreDiag .and. (mod(iter, nlst_rt(did)%GwPreDiagInterval) .eq. 0) ) then + call output_gw_spinup(nlst_rt(did)%igrid, 1000000, & + RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & + nlst_rt(did)%startdate, nlst_rt(did)%olddate, & + gw2d(did)%ho, gw2d(did)%convgw, gw2d(did)%excess, & + nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, & + RT_DOMAIN(did)%LATVAL, & + RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist, & + nlst_rt(did)%output_gw) + end if + + + end do + + return + end subroutine gw2d_ini + + subroutine gw2d_allocate(did, ix, jx, nsoil) + + implicit none + integer ix, jx, nsoil + integer istatus, did + + if(gw2d(did)%allo_status .eq. 1) return + gw2d(did)%allo_status = 1 + + gw2d(did)%ix = ix + gw2d(did)%jx = jx + +#ifdef MPP_LAND + if(down_id == -1) then ! if south border + gw2d(did)%jts = 1 + else + gw2d(did)%jts = 2 + endif + + if(up_id == -1) then !if north border + gw2d(did)%jte = jx + else + gw2d(did)%jte = jx-1 + endif + + if(left_id == -1) then !if west border + gw2d(did)%its = 1 + else + gw2d(did)%its = 2 + endif + + if(right_id == -1) then ! if east border + gw2d(did)%ite = ix + else + gw2d(did)%ite = ix-1 + endif + +#else + gw2d(did)%its = 1 + gw2d(did)%ite = ix + gw2d(did)%jts = 1 + gw2d(did)%jte = jx +#endif + + allocate(gw2d(did)%ltype (ix,jx)) + allocate(gw2d(did)%elev (ix,jx)) + allocate(gw2d(did)%bot (ix,jx)) + allocate(gw2d(did)%hycond (ix,jx)) + allocate(gw2d(did)%poros (ix,jx)) + allocate(gw2d(did)%compres(ix,jx)) + allocate(gw2d(did)%ho (ix,jx)) + allocate(gw2d(did)%h (ix,jx)) + allocate(gw2d(did)%convgw (ix,jx)) + allocate(gw2d(did)%excess (ix,jx)) + + allocate(gw2d(did)%qgw_chanrt (ix,jx)) + + + ! TODO allocate only if gwSoilCoupling is active + allocate(gw2d(did)%qsgwrt (ix,jx)) + allocate(gw2d(did)%qsgw (rt_domain(did)%ix,rt_domain(did)%jx)) + allocate(gw2d(did)%qdarcyRT (ix,jx)) + + end subroutine gw2d_allocate + + + subroutine gwstep(ix, jx, dx, & + ltype, elev, bot, & + hycond, poros, compres, & + ho, h, convgw, excess, & + ebot, eocn, & + dt, istep) + +! New (volug): calling routines use change in head, convgw = d(h-ho)/dt. + +! Steps ground-water hydrology (head) through one timestep. +! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer +! simulation program, with mods by Zhongbo Yu(1997). +! Solves S.dh/dt = d/dx(T.dh/dx) + d/dy(T.dh/dy) + "external sources" +! for a single layer, where h is head, S is storage coeff and T is +! transmissivity. 3-D arrays in main program (hycond,poros,h,bot) +! are 2-D here, since only a single (uppermost) layer is solved. +! Uses an iterative time-implicit ADI method. + +! use module_hms_constants + + + + integer, intent(in) :: ix, jx + + integer, intent(in), dimension(ix,jx) :: ltype ! land-sfc type (supp) + real, intent(in), dimension(ix,jx) :: & + elev, & ! elev/bathymetry of sfc rel to sl (m) (supp) + bot, & ! elev. aquifer bottom rel to sl (m) (supp) + hycond, & ! hydraulic conductivity (m/s per m/m) (supp) + poros, & ! porosity (m3/m3) (supp) + compres, & ! compressibility (1/Pa) (supp) + ho ! head at start of timestep (m) (supp) + + real, intent(inout), dimension(ix,jx) :: & + h, & ! head, after ghmcompute (m) (ret) + convgw, & ! convergence due to gw flow (m/s) (ret) + excess + + real, intent(inout) :: ebot, eocn + + + + integer :: istep !, dt + real, intent(in) :: dt, dx + +! #endif +! eocn = mean spurious sink for h_ocn = sealev fix (m/s)(ret) +! This equals the total ground-water flow across +! land->ocean boundaries. +! ebot = mean spurious source for "bot" fix (m/s) (returned) +! time = elapsed time from start of run (sec) +! dt = timestep length (sec) +! istep = timestep counter + +! Local arrays: + + real, dimension(ix,jx) :: sf2 ! storage coefficient (m3 of h2o / bulk m3) + real, dimension(ix,jx,2) :: t ! transmissivity (m2/s)..1 for N-S,..2 for E-W + +#ifdef MPP_LAND + real, dimension(:,:), allocatable :: aa, & ! tridiagonal matrix lower diagonal + bb, & ! tridiagonal matrix main diagonal + cc, & ! tridiagonal matrix upper diagonal + dd, & ! right hand side + b2, & + c2, & + rhs, & + wk, & + hh + real, dimension(:), allocatable :: xfac, & + zfac +#else + real, dimension(:), allocatable :: aa, & ! tridiagonal matrix lower diagonal + bb, & ! tridiagonal matrix main diagonal + cc, & ! tridiagonal matrix upper diagonal + dd, & ! right hand side + hh ! solution vector +#endif + real, parameter :: botinc = 0.01 ! re-wetting increment to fix h < bot +! parameter (botinc = 0. ) ! re-wetting increment to fix h < bot + ! (m); else no flow into dry cells + real, parameter :: delskip = 0.005 ! av.|dhead| value for iter.skip out(m) + integer, parameter :: itermax = 1 ! maximum number of iterations + integer, parameter :: itermin = 1 ! minimum number of iterations + real, parameter :: sealev = 1000. ! sea-level elevation (m) + + integer :: its, ite, jts, jte, ifs, ife, jfs, jfe, & + xdim, ydim, fxdim, fydim + +! die müssen noch sortiert, geprüft und aufgeräumt werden + integer :: & + iter, & + j, & + i, & + jp, & + ip, & + n, & + ierr, & + ier, & + ioffs, & + joffs + +! real :: su, sc, shp, bb, aa, cc, w, zz, tareal, dtoa, dtot + real :: & + dy, & + e, & + su, & + sc, & + shp, & + w, & + ha, & + delcur, & + dtot, & + dtoa, & + darea, & + tareal, & + zz + +#ifdef MPP_LAND + real :: mpiDelcur, & + gdtot, & + gdtoa, & + geocn, & + gebot + integer mpiSize +#endif + + + +dy = dx +darea = dx*dy + +! define indexes for parallel execution + +#ifdef MPP_LAND +if(down_id == -1) then ! if south border + jts = 1 +else + jts = 2 +endif + +if(up_id == -1) then !if north border + jte = jx +else + jte = jx-1 +endif + +if(left_id == -1) then !if west border + its = 1 +else + its = 2 +endif + +if(right_id == -1) then ! if east border + ite = ix +else + ite = ix-1 +endif + +#else +its = 1 +ite = ix +jts = 1 +jte = jx +#endif + +ifs = 1 +ife = ix +jfs = 1 +jfe = jx + + +fxdim = ife-ifs+1 +fydim = jfe-jfs+1 + xdim = ite-its+1 + ydim = jte-jts+1 + + + call scopy (fxdim*fydim, ho(ifs:ife,jfs:jfe), 1, & + h(ifs:ife,jfs:jfe), 1) + + +! Top of iterative loop for (not anymore ADI) solution + + iter = 0 +!~~~~~~~~~~~~~ + 80 continue +!~~~~~~~~~~~~~ + iter = iter+1 + + +#ifdef MPP_LAND + + call MPP_LAND_COM_REAL(h, fxdim, fydim, 99) + +#endif + e = 0. ! absolute changes in head (for iteration control) +! eocn = 0. ! accumulated fixes for h = 0 over ocean (diag) +! ebot = 0. ! accumulated fixes for h < bot (diagnostic) + +! Set storage coefficient (sf2) + + + + tareal = 0. + do j=jts,jte + do i=its,ite + + + if(ltype(i,j) .ge. 1) tareal = tareal + darea + +! unconfined water table (h < e): V = poros*(h-b) +! dV/dh = poros +! saturated to surface (h >= e) : V = poros*(e-b) + (h-e) +! dV/dh = 1 +! (compressibility is ignored) +! +! su = poros(i,j)*(1.-theta(i,j)) ! old (pre-volug) + su = poros(i,j) ! new (volug) + sc = 1. + +! if (ho(i,j).le.elev(i,j) .and. h(i,j).le.elev(i,j)) then + sf2(i,j) = su +! else if (ho(i,j).ge.elev(i,j) .and. h(i,j).ge.elev(i,j)) then +! sf2(i,j) = sc +! else if (ho(i,j).le.elev(i,j) .and. h(i,j).ge.elev(i,j)) then +! shp = sf2(i,j) * (h(i,j) - ho(i,j)) +! sf2(i,j) = shp * sc / (shp - (su-sc)*(elev(i,j)-ho(i,j))) +! else if (ho(i,j).ge.elev(i,j) .and. h(i,j).le.elev(i,j)) then +! shp = sf2(i,j) * (ho(i,j) - h(i,j)) +! sf2(i,j) = shp * su / (shp + (su-sc)*(ho(i,j)-elev(i,j))) +! endif + + enddo + enddo + +#ifdef MPP_LAND + ! communicate storage coefficient + call MPP_LAND_COM_REAL(sf2, fxdim, fydim, 99) + +#endif + +!========================== +! Column calculations +!========================== + +! Set transmissivities. Use min(h,elev)-bot instead of h-bot, +! since if h > elev, thickness of groundwater flow is just +! elev-bot. (uses geometric mean) + + + do j=jts,jte + jp = min (j+1,jfe) + do i=its,ite + ip = min (i+1,ife) + + t(i,j,2) = sqrt( abs( & + hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & + *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & + ) ) & + * (0.5*(dy+dy)) & ! in WRF the dx and dy are usually equal + / (0.5*(dx+dx)) + + t(i,j,1) = sqrt( abs( & + hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & + *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & + ) ) & + * (0.5*(dx+dx)) & + / (0.5*(dy+dy)) + + + enddo + enddo + + + + + +#ifdef MPP_LAND + ! communicate transmissivities in x and y direction + call MPP_LAND_COM_REAL(t(:,:,1), fxdim, fydim, 99) + call MPP_LAND_COM_REAL(t(:,:,2), fxdim, fydim, 99) + + + allocate(aa(jts:jte,its:ite)) + allocate(bb(jts:jte,its:ite)) + allocate(cc(jts:jte,its:ite)) + allocate(dd(jts:jte,its:ite)) + allocate(c2(1:ydim,1:xdim)) + allocate(b2(1:ydim,1:xdim)) + allocate(wk(1:ydim,1:xdim)) + allocate(hh(0:ydim+1,0:xdim+1)) + allocate(xfac(1:ydim)) + allocate(zfac(1:ydim)) +#else + allocate(aa(jfs:jfe)) + allocate(bb(jfs:jfe)) + allocate(cc(jfs:jfe)) + allocate(dd(jfs:jfe)) + allocate(hh(jfs:jfe)) + +!------------------- + do i=ifs,ife +!------------------- + +!>>>>>>>>>>>>>>>>>>>> + do j=jfs,jfe +!>>>>>>>>>>>>>>>>>>>> +#endif +#ifndef MPP_LAND + bb(j) = (sf2(i,j)/dt) * darea + dd(j) = ( ho(i,j)*sf2(i,j)/dt ) * darea + aa(j) = 0.0 + cc(j) = 0.0 + + if ((j-jfs) /= 0) then + aa(j) = -t(i,j-1,1) + bb(j) = bb(j) + t(i,j-1,1) + endif + + if ((j-jfe) /= 0) then + cc(j) = -t(i,j,1) + bb(j) = bb(j) + t(i,j,1) + endif + + if ((i-ifs) /= 0) then + bb(j) = bb(j) + t(i-1,j,2) + dd(j) = dd(j) + h(i-1,j)*t(i-1,j,2) + endif + + if ((i-ife) /= 0) then + bb(j) = bb(j) + t(i,j,2) + dd(j) = dd(j) + h(i+1,j)*t(i,j,2) + endif + +!>>>>>>>>>>>>>>> + end do +!>>>>>>>>>>>>>>> + + call trdiagSolve(aa, bb, cc, dd, hh, fydim) + + h(i,:) = hh + end do + +deallocate(aa) +deallocate(bb) +deallocate(cc) +deallocate(dd) +deallocate(hh) + +#else +!------------------- + do i=its,ite +!------------------- + +!>>>>>>>>>>>>>>>>>>>> + do j=jts,jte +!>>>>>>>>>>>>>>>>>>>> + bb(j,i) = (sf2(i,j)/dt) * darea + dd(j,i) = ( ho(i,j)*sf2(i,j)/dt ) * darea + aa(j,i) = 0.0 + cc(j,i) = 0.0 + + if (((j-jfs) /= 0)) then + aa(j,i) = -t(i,j-1,1) + bb(j,i) = bb(j,i) + t(i,j-1,1) + endif + + if (((j-jfe) /= 0)) then + cc(j,i) = -t(i,j,1) + bb(j,i) = bb(j,i) + t(i,j,1) + endif + + if (((i-ifs) /= 0)) then + bb(j,i) = bb(j,i) + t(i-1,j,2) + dd(j,i) = dd(j,i) + h(i-1,j)*t(i-1,j,2) + endif + + if (((i-ife) /= 0)) then + bb(j,i) = bb(j,i) + t(i,j,2) + dd(j,i) = dd(j,i) + h(i+1,j)*t(i,j,2) + endif + +!>>>>>>>>>>>>>>> + end do +!>>>>>>>>>>>>>>> + +!------------- + end do +!------------- + + if(np_up_down .gt. 1) then + call sub_n_form(xdim, ydim, aa, & + bb, cc, & + dd, & + c2, b2, hh, wk, xfac, zfac, & + p_up_down+1, np_up_down, 2) + + + call parysolv1(c2, b2, hh, 1., my_id+1, p_up_down+1, & + xdim, ydim, np_left_right, np_up_down) + + else + call sub_tri_solv(xdim,ydim,aa(jts:jte,its:ite), & + bb(jts:jte,its:ite), cc(jts:jte,its:ite), & + dd(jts:jte,its:ite), & + hh, wk,xfac,zfac,2) + endif + +ioffs = its-1 +joffs = jts-1 +!------------------- + do i=its,ite +!------------------- + +!>>>>>>>>>>>>>>>>>>>> + do j=jts,jte +!>>>>>>>>>>>>>>>>>>>> + + h(i,j) = hh(j-joffs,i-ioffs) + + end do + end do + +#endif + +#ifdef MPP_LAND + + call MPP_LAND_COM_REAL(h, fxdim, fydim, 99) + +#endif + + +!======================= +! Row calculations +!======================= + +! set transmissivities (same as above) + + + do j=jts,jte + jp = min (j+1,jfe) + do i=its,ite + ip = min (i+1,ife) + t(i,j,2) = sqrt( abs( & + hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & + *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & + ) ) & + * (0.5*(dy+dy)) & + / (0.5*(dx+dx)) + + t(i,j,1) = sqrt( abs( & + hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & + *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & + ) ) & + * (0.5*(dx+dx)) & + / (0.5*(dy+dy)) + + + enddo + enddo + +#ifdef MPP_LAND + ! communicate transmissivities in x and y direction + call MPP_LAND_COM_REAL(t(:,:,1), fxdim, fydim, 99) + call MPP_LAND_COM_REAL(t(:,:,2), fxdim, fydim, 99) +#endif + +#ifndef MPP_LAND +allocate(aa(ifs:ife)) +allocate(bb(ifs:ife)) +allocate(cc(ifs:ife)) +allocate(dd(ifs:ife)) +allocate(hh(ifs:ife)) + + +!------------------- + do j=jfs,jfe +!------------------- + + +!>>>>>>>>>>>>>>>>>>>> + do i=ifs,ife +!>>>>>>>>>>>>>>>>>>>> + bb(i) = (sf2(i,j)/dt) * darea + dd(i) = ( ho(i,j)*sf2(i,j)/dt ) * darea + aa(i) = 0.0 + cc(i) = 0.0 + + if ((j-jfs) /= 0) then + bb(i) = bb(i) + t(i,j-1,1) + dd(i) = dd(i) + h(i,j-1)*t(i,j-1,1) + endif + + if ((j-jfe) /= 0) then + dd(i) = dd(i) + h(i,j+1)*t(i,j,1) + bb(i) = bb(i) + t(i,j,1) + endif + + if ((i-ifs) /= 0) then + bb(i) = bb(i) + t(i-1,j,2) + aa(i) = -t(i-1,j,2) + endif + + if ((i-ife) /= 0) then + bb(i) = bb(i) + t(i,j,2) + cc(i) = -t(i,j,2) + endif + +!>>>>>>>>>>>>>>> + end do +!>>>>>>>>>>>>>>> + + call trdiagSolve(aa, bb, cc, dd, hh, fxdim) + + h(:,j) = hh + end do + +#else +!------------------- + do i=its,ite +!------------------- + +!>>>>>>>>>>>>>>>>>>>> + do j=jts,jte +!>>>>>>>>>>>>>>>>>>>> + bb(j,i) = (sf2(i,j)/dt) * darea + dd(j,i) = ( ho(i,j)*sf2(i,j)/dt ) * darea + aa(j,i) = 0.0 + cc(j,i) = 0.0 + + if (((j-jfs) /= 0)) then + bb(j,i) = bb(j,i) + t(i,j-1,1) + dd(j,i) = dd(j,i) + h(i,j-1)*t(i,j-1,1) + endif + + if (((j-jfe) /= 0)) then + dd(j,i) = dd(j,i) + h(i,j+1)*t(i,j,1) + bb(j,i) = bb(j,i) + t(i,j,1) + endif + + if (((i-ifs) /= 0)) then + bb(j,i) = bb(j,i) + t(i-1,j,2) + aa(j,i) = -t(i-1,j,2) + endif + + if (((i-ife) /= 0)) then + bb(j,i) = bb(j,i) + t(i,j,2) + cc(j,i) = -t(i,j,2) + endif + +!>>>>>>>>>>>>>>> + end do +!>>>>>>>>>>>>>>> + +!------------- +end do +!------------- + + if(np_left_right .gt. 1) then + +! 3 c(,) -- subdiagonal elements of tridiagonal systems +! 4 a(,) -- diagonal elements of tridiagonal systems +! 5 b(,) -- superdiagonal elements of tridiagonal systems +! 6 r(,) -- right-hand side elements of tridiagonal systems +! 7 c2(,) -- front-leg elements of N-systems +! 8 b2(,) -- back-leg elements of N-systems +! 9 r2(,) -- right-hand side elements of N-systems (0:ydim+1,0:xdim+1) +! 10 wk(,) -- work array with same dimensions as a, b, c, etc. + + call sub_n_form(xdim, ydim, aa, & + bb, cc, & + dd, & + c2, b2, hh, wk, xfac, zfac, & + p_left_right+1, np_left_right, 1) + + call parxsolv1(c2, b2, hh, 1., my_id+1, p_left_right+1, & + xdim, ydim, np_left_right, np_up_down) + + else + call sub_tri_solv(xdim,ydim,aa, & + bb, cc, & + dd, & + hh, wk,xfac,zfac,1) + endif +ioffs = its-1 +joffs = jts-1 +!------------------- + do i=its,ite +!------------------- + +!>>>>>>>>>>>>>>>>>>>> + do j=jts,jte +!>>>>>>>>>>>>>>>>>>>> + + h(i,j) = hh(j-joffs,i-ioffs) + + end do + end do + +deallocate(b2) +deallocate(c2) +deallocate(wk) +deallocate(xfac) +deallocate(zfac) +#endif +deallocate(aa) +deallocate(bb) +deallocate(cc) +deallocate(dd) +deallocate(hh) + +! fix head < bottom of aquifer + + do j=jts,jte + do i=its,ite + if (ltype(i,j).eq.1 .and. h(i,j).le.bot(i,j)+botinc) then + + e = e + bot(i,j) + botinc - h(i,j) +! ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea(i,j) + ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea + + h(i,j) = bot(i,j) + botinc + endif + enddo + enddo +! maintain head = sea level for ocean (only for adjacent ocean, +! rest has hycond=0) + + do j=jts,jte + do i=its,ite + if (ltype(i,j).eq.2) then + + eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea +! eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea(i,j) + +! h(i,j) = sealev (no update of outer boundary cells) + endif + enddo + enddo + +! Loop back for next ADI iteration + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + delcur = e/(xdim*ydim) + +! print*, 'delcur before mpi:', delcur + +#ifdef MPP_LAND + +call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, HYDRO_COMM_WORLD, ierr) +call MPI_COMM_SIZE( HYDRO_COMM_WORLD, mpiSize, ierr ) + +if(my_id .eq. IO_id) delcur = mpiDelcur/mpiSize + +call mpi_bcast(delcur, 1, mpi_real, 0, HYDRO_COMM_WORLD, ierr) + +#endif + +! if ( (delcur.gt.delskip*dt/86400. .and. iter.lt.itermax) & + if ( (delcur.gt.delskip .and. iter.lt.itermax) & + .or. iter.lt.itermin ) then + +#ifdef HYDRO_D + +#ifdef MPP_LAND +if(my_id .eq. IO_id) write(6,*) "Iteration", iter, "of", itermax, "error:", delcur +#else + write(6,*) "Iteration", iter, "of", itermax, "error:", delcur +#endif + +#endif + + goto 80 + endif + +#ifdef MPP_LAND + + call MPP_LAND_COM_REAL(h, fxdim, fydim, 99) + +#endif + + + +! Compute exfiltration amount and +! convergence rate due to ground water +! flow + + do j=jts,jte + do i=its,ite + + if((elev(i,j) - h(i,j)) .lt. 0.) then + excess(i,j) = sf2(i,j)*(h(i,j) - elev(i,j)) + h(i,j) = elev(i,j) + else + excess(i,j) = 0. + end if + + if(ltype(i,j).eq.1) then + convgw(i,j) = sf2(i,j) * (h(i,j)-ho(i,j)) / dt + else + convgw(i,j) = 0. + endif + enddo + enddo + +! call MPP_LAND_COM_REAL(convgw, fxdim, fydim, 99) + +! Diagnostic water conservation check for this timestep + + dtot = 0. ! total change in water storage (m3) + dtoa = 0. + + do j=jts,jte + do i=its,ite + if (ltype(i,j).eq.1) then + + dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea + dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea + +! dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea(i,j) +! dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea(i,j) + endif + enddo + enddo + + dtot = (dtot/tareal)/dt ! convert to m/s, rel to land area + dtoa = (dtoa/tareal)/dt + eocn = (eocn/tareal)/dt + ebot = (ebot/tareal)/dt + + zz = 1.e3 * 86400. ! convert printout to mm/day +#ifdef HYDRO_D +#ifdef MPP_LAND + + call MPI_REDUCE(dtot,gdtot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_REDUCE(dtoa,gdtoa,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_REDUCE(eocn,geocn,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_REDUCE(ebot,gebot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + + if(my_id .eq. IO_id) then + write (*,900) & + gdtot*zz, gdtoa*zz, -geocn*zz, gebot*zz, & + (gdtot-(-geocn+gebot))*zz + endif + +#else + + write (*,900) & + dtot*zz, dtoa*zz, -eocn*zz, ebot*zz, & + (dtot-(-eocn+ebot))*zz +#endif +#endif + 900 format & + (3x,' dh/dt |dh/dt| ocnflx botfix',& + ' ghmerror' & +! /3x,4f9.4,2(9x),e14.4) + /3x,5(e14.4)) + + return + end subroutine gwstep + + + SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) +! +! Copies array ARR to BRR, incrementing by INCA and INCB +! respectively, up to a total length of NT words of ARR. +! (Same as Cray SCOPY.) +! + real, DIMENSION(*) :: ARR, BRR + integer :: ia, nt, inca, incb, ib +! + IB = 1 + DO 10 IA=1,NT,INCA + BRR(IB) = ARR(IA) + IB = IB + INCB + 10 CONTINUE +! + RETURN + END SUBROUTINE SCOPY + + +subroutine trdiagSolve(a,b,c,rhs,x,n) + + implicit none + + integer,intent(in) :: n + real,dimension(n),intent(in) :: a, b, c, rhs + real,dimension(n),intent(out) :: x + real,dimension(n) :: cp, dp + real :: m + integer i + +! initialize c-prime and d-prime + cp(1) = c(1)/b(1) + dp(1) = rhs(1)/b(1) +! solve for vectors c-prime and d-prime + do i = 2,n + m = b(i)-cp(i-1)*a(i) + cp(i) = c(i)/m + dp(i) = (rhs(i)-dp(i-1)*a(i))/m + enddo +! initialize x + x(n) = dp(n) +! solve for x from the vectors c-prime and d-prime + do i = n-1, 1, -1 + x(i) = dp(i)-cp(i)*x(i+1) + end do + + +end subroutine trdiagSolve + + +subroutine gwSoilFlux(did) + + + implicit none + + integer, intent(in) :: did + + + real, dimension(rt_domain(did)%ixrt,rt_domain(did)%jxrt) :: smcrel, ztrans, headChange + real :: frac, zres + integer :: nsoil, i, j, k + + gw2d(did)%qsgwrt = 0. + gw2d(did)%qdarcyRT = 0. + +! Step 1, collect data + +! relative soil moisture content of lowest soil layer (1 = saturated) + nsoil = nlst_rt(did)%nsoil + smcrel = RT_DOMAIN(did)%SMCRT(:,:,nsoil) / RT_DOMAIN(did)%SMCMAXRT(:,:,nsoil) + +! depth of transition zone from lowest soil layer to groundwater head (in cm) +! postivie ztrans -> head below LSM soil layer +! negative ztrans -> head within LSM soil layers + ztrans = (rt_domain(did)%elrt + nlst_rt(did)%zsoil8(nsoil)) - gw2d(did)%ho + ztrans = ztrans * 100 + + ! darcyGwSoil not defined for ztran = 0 + where(ztrans == 0) ztrans = -5 + +! Step 2, compute flux either up or down + + do j=gw2d(did)%jts, gw2d(did)%jte + do i=gw2d(did)%its, gw2d(did)%ite + + if((ztrans(i,j) > 0) .and. (rt_domain(did)%soiltypRT(i,j) < 13)) then + ! if groundwater head < soil layers + call darcyGwSoil(ztrans(i,j), smcrel(i,j), rt_domain(did)%soiltypRT(i,j), gw2d(did)%qdarcyRT(i,j)) + + gw2d(did)%qsgwrt(i,j) = gw2d(did)%qdarcyRT(i,j) + + ! check and correct for mass balance + if(((gw2d(did)%ho(i,j)-gw2d(did)%bot(i,j)) & + *gw2d(did)%poros(i,j)) < (gw2d(did)%qsgwrt(i,j)*gw2d(did)%dt)) then + + gw2d(did)%qdarcyRT(i,j) = 0. + gw2d(did)%qsgwrt(i,j) = 0. + + end if + + else if(ztrans(i,j) < 0 .and. (rt_domain(did)%soiltypRT(i,j) < 13)) then + ! if groundwater head > soil layers + zres = -ztrans(i,j) + do k=nsoil,1,-1 + + if(zres >= rt_domain(did)%sldpth(k)*100.) then + ! complete filling of a LSM soil layer if groundwater head > layer top + +! gw2d(did)%qsgwrt(i,j) = (rt_domain(did)%sldpth(k) & +! * (RT_DOMAIN(did)%SMCMAXRT(i,j,k) - RT_DOMAIN(did)%SMCRT(i,j,k)) & +! + gw2d(did)%qsgwrt(i,j)) / gw2d(did)%dt + + RT_DOMAIN(did)%SMCRT(i,j,k) = RT_DOMAIN(did)%SMCMAXRT(i,j,k) + + zres = zres - rt_domain(did)%sldpth(k)*100. + + else + ! partial filling of a soil layer if not completely below groundwater head + + if(zres > (0.5 * rt_domain(did)%sldpth(k)*100.)) then + + frac = zres / (rt_domain(did)%sldpth(k) * 100.) + + +! gw2d(did)%qsgwrt(i,j) = (rt_domain(did)%sldpth(k) & +! * (RT_DOMAIN(did)%SMCMAXRT(i,j,k) - RT_DOMAIN(did)%SMCRT(i,j,k)) & +! * frac + gw2d(did)%qsgwrt(i,j)) / gw2d(did)%dt + + RT_DOMAIN(did)%SMCRT(i,j,k) = RT_DOMAIN(did)%SMCMAXRT(i,j,k) * frac + + end if + + end if + end do + end if + end do + end do + + ! sign convention + ! qsgwrt < 0 -> downward flux + ! qsgwrt > 0 -> upward flux + +! TOcheck Step 3, adapt groundwater head (assuming not time lag for percolation / capillary rise flow) + +! modify gw-head before gwstep call with respect to specific yield of the +! aquifer and the computed flux (qsgwrt) + + + headChange = (-gw2d(did)%qdarcyRT) * gw2d(did)%dt / gw2d(did)%poros + gw2d(did)%ho = gw2d(did)%ho + headChange + +end subroutine gwSoilFlux + +subroutine darcyGwSoil(Z, s, soil, q_darcy) + +implicit none + +INTEGER, INTENT (IN) :: soil ! soiltype + +REAL :: sig_a, sig_b, sig_c + +REAL, DIMENSION(9) :: k_para +REAL, INTENT (IN) :: Z, s +REAL, INTENT (OUT) :: q_darcy +real :: beta,alpha,q_cap,b,ks,aep,c,q_grav,y,fac + +real, dimension(9,12) :: & + k_soil = reshape((/& +0.0778, 3.9939, 0.2913, 4.0801, 0.1386, 4.0500, -12.10, 0.3950, 1.0560,& +0.0924, 4.8822, 0.2674, 3.8915, 0.1365, 4.3800, -09.00, 0.4100, 0.9380,& +0.0367, 4.5259, 0.2446, 4.2849, 0.1208, 4.9000, -21.80, 0.4350, 0.2080,& +0.0101, 3.6896, 0.2153, 4.2765, 0.0887, 5.3000, -78.60, 0.4850, 0.0432,& +0.0101, 3.6896, 0.2153, 4.2765, 0.0887, 5.3000, -78.60, 0.4850, 0.0432,& +0.0169, 2.9936, 0.2858, 4.3738, 0.1026, 5.3900, -47.80, 0.4510, 0.0417,& +0.0271, 4.4743, 0.2587, 3.9055, 0.0920, 7.1200, -29.90, 0.4200, 0.0378,& +0.0227, 4.3768, 0.2658, 3.8234, 0.0843, 7.7500, -35.60, 0.4770, 0.0102,& +0.0127, 6.6836, 0.1725, 3.7512, 0.0703, 8.5200, -63.00, 0.4760, 0.0147,& +0.0530, 9.2423, 0.1859, 3.3688, 0.0728, 10.400, -15.30, 0.4260, 0.0130,& +0.0165, 5.3972, 0.2479, 3.5549, 0.0641, 10.400, -49.00, 0.4920, 0.0062,& +0.0200, 6.0106, 0.2474, 3.4788, 0.0622, 11.400, -40.50, 0.4820, 0.0077/),(/9,12/)) + + + + k_para = k_soil(:,soil) + sig_a = 1 - exp( -1 * k_para(1) * Z) + sig_b = k_para(2) * Z**k_para(3) + sig_c = k_para(4) * exp( -1 * Z**k_para(5)) + y = sig_a/(1 + exp(sig_b * (s - sig_c))) !solving equation (20) in Boogart et al. + + b = k_para(6) + ks = k_para(9) + aep = -k_para(7) + + c = 2 * b + 3 + q_grav = -1 * ks * s**c + +! alp is constant from equation (13) of paper +beta = 2 + 3 / b +alpha = 1 + 1.5 / (beta - 1) +q_cap = ks * alpha * (aep / Z)**beta + + +q_darcy = y * q_cap + q_grav ![cm/min] + +! limit for exteme gradients with q >> saturated hydraulic conductivity +! if(q_cap > ks) q_cap = ks +! if(q_grav < -ks) q_grav = -ks + +! if(q_darcy > ks) q_darcy = ks +! if(q_darcy < ks) q_darcy = -ks + + +fac = 1./6000. +q_darcy = q_darcy * fac +q_cap = q_cap * fac +q_grav = q_grav * fac + +!returns q_darcy in [m/s] + +end subroutine darcyGwSoil + + + +subroutine aggregateQsgw(did) + + + + implicit none + + integer, intent(in) :: did + integer :: j,i, ixxRT, jyyRT, m,n + real :: agg + + + do j=1,rt_domain(did)%jx + do i=1,rt_domain(did)%ix + + agg= 0. + + do m=nlst_rt(did)%aggfactRT-1,0,-1 + do n=nlst_rt(did)%aggfactRT-1,0,-1 + + + ixxRT = i * nlst_rt(did)%aggfactRT-n + jyyRT = j * nlst_rt(did)%aggfactRT-m + + +#ifdef MPP_LAND + if(left_id.ge.0) ixxRT=ixxRT+1 + if(down_id.ge.0) jyyRT=jyyRT+1 +#endif + agg = agg + gw2d(did)%qdarcyRT(ixxRT, jyyRT) + end do + end do + + gw2d(did)%qsgw(i,j) = agg/(nlst_rt(did)%aggfactRT**2) + end do + end do + + + +end subroutine aggregateQsgw + +! Parallel tridiagonal solver useful for domain decomposed ADI +! Author(s): Mike Lambert +! Year: 1996 +! Institution: Lawrence Livermore National Laboratory +! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method +! for solution of the steady state diffusion equation", +! Parallel Computing 23 (1997) 2041-2065 +! Ported to MPI by Benjamin Fersch, Karlsruhe Institute of Technology (2013) + +#ifdef MPP_LAND + subroutine parysolv1(c,b,r,ct,pid,z_pid, & + xsps, zsps, xdns, zdns) + + implicit none + + integer, intent(in) :: XSPS, & + ZSPS, & + XDNS, & + ZDNS + + real, dimension(ZSPS, XSPS), intent(inout) :: c, & + b + real CLK_PER + parameter (CLK_PER = 6.66666667e-9) + + real, dimension(0:ZSPS+1, 0:XSPS+1), intent(inout) :: r + + real, dimension(XSPS,2) :: zn, zntmp + + real, dimension(XSPS) :: t1, t2, fac + + real :: clockdt, click + real :: ct, ti, tf, dt + + integer :: pid, z_pid + integer :: i, j, sndr_pid, msg_type, cnt, ackn + integer :: sendReq, recvReq + + integer ZN_REC + parameter (ZN_REC = 46) + + integer :: source, dest +#ifdef TIMING + dt = clockdt() +#endif + + cnt = 2*XSPS + + if (z_pid .eq. 1) then + +! Load (ZSPS,j)th equations into passing arrays. + do 10 j = 1, XSPS + zntmp(j,1) = b(ZSPS,j) + zntmp(j,2) = r(ZSPS,j) + 10 continue + + +#ifdef TIMING + ti = click() +#endif + +! ! Send (ZSPS,j)th equations. +! ! Receive (ZSPS+1,j)th equations. + + call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 20 j = 1, XSPS +! Backward elimination in (ZSPS,j)th equations to get +! r(ZSPS,j). + fac(j) = 1./(1. - b(ZSPS,j)*zn(j,1)) + r(ZSPS,j) = (r(ZSPS,j)-b(ZSPS,j)*zn(j,2))*fac(j) +! Forward elimination in (ZSPS+1,j)th equations to get +! r(ZSPS+1,j). + r(ZSPS+1,j) = zn(j,2) - zn(j,1)*r(ZSPS,j) +! Completion of backward elimination to get remaining unknowns. + do 30 i = 1, ZSPS-1 + r(i,j) = r(i,j) - b(i,j)*r(ZSPS,j) + 30 continue + 20 continue + + else if (z_pid .le. ZDNS/2) then + +#ifdef TIMING + ti = click() +#endif +! ! Receive (0,j)th equations. + + call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + +! Forward elimination in (j,1)th equations. + do 40 j = 1, XSPS + fac(j) = 1./(1. - c(1,j)*zn(j,1)) +! Check for singular matrix (debugging only) + b(1,j) = b(1,j)*fac(j) + r(1,j) = (r(1,j) - c(1,j)*zn(j,2))*fac(j) +! Forward elimination in (ZSPS,j)th equations. + fac(j) = 1./(1. - c(ZSPS,j)*b(1,j)) +! Check for singular matrix (debugging only) + b(ZSPS,j) = b(ZSPS,j)*fac(j) + r(ZSPS,j) = (r(ZSPS,j)-c(ZSPS,j)*r(1,j))*fac(j) +! Store (0,j)th equations for later recovery of r(0,j). + t1(j) = zn(j,1) + t2(j) = zn(j,2) +! Load (ZSPS,j)th equations into passing arrays. + zntmp(j,1) = b(ZSPS,j) + zntmp(j,2) = r(ZSPS,j) + 40 continue + +#ifdef TIMING + ti = click() +#endif +! ! Send (ZSPS,j)th equations. +! ! Receive (ZSPS+1,j)th equations. + + call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 50 j = 1, XSPS +! Backward elimination in (ZSPS,j)th equations. + fac(j) = 1./(1. - b(ZSPS,j)*zn(j,1)) +! Check for singular matrix (debugging only) + r(ZSPS,j) = (r(ZSPS,j) - b(ZSPS,j)*zn(j,2))*fac(j) +! Backward elimination in (ZSPS+1,j)th equations. + r(ZSPS+1,j) = zn(j,2) - zn(j,1)*r(ZSPS,j) +! Backward elimination in (ZSPS,j)th equations. + r(1,j) = r(1,j) - b(1,j)*r(ZSPS,j) +! Load (1,j)th equations into passing arrays. + zntmp(j,1) = 0. + zntmp(j,2) = r(1,j) + 50 continue + +#ifdef TIMING + ti = click() +#endif +! ! Send (1,j)th equations. + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + + do 60 j = 1, XSPS +! Backward elimination in (0,j)th equations. + r(0,j) = t2(j) - t1(j)*r(1,j) + do 70 i = 2, ZSPS-1 +! Completion of forward and backward elimination to get remaining +! unknowns. + r(i,j) = r(i,j) - b(i,j)*r(ZSPS,j) - c(i,j)*r(1,j) + 70 continue + 60 continue + + call mpi_wait(sendReq, mpp_status, ierr) + + + else if (z_pid .lt. ZDNS) then + +#ifdef TIMING + ti = click() +#endif +! ! Receive (ZSPS+1,j)th equations. + + call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 80 j = 1, XSPS +! Backward elimination in (ZSPS,j)th equations. + fac(j) = 1./(1. - b(ZSPS,j)*zn(j,1)) +! Check for singular matrix (debugging only) + c(ZSPS,j) = c(ZSPS,j)*fac(j) + r(ZSPS,j) = (r(ZSPS,j)-b(ZSPS,j)*zn(j,2))*fac(j) +! Backward elimination in (1,j)th equations. + fac(j) = 1./(1. - b(1,j)*c(ZSPS,j)) +! Check for singular matrix (debugging only) + c(1,j) = c(1,j)*fac(j) + r(1,j) = (r(1,j) - b(1,j)*r(ZSPS,j))*fac(j) +! Store (ZSPS+1,j)th equations for later recovery of +! r(ZSPS+1,j). + t1(j) = zn(j,1) + t2(j) = zn(j,2) +! Load passing arrays with (1,j)th equations. + zntmp(j,1) = c(1,j) + zntmp(j,2) = r(1,j) + 80 continue + +#ifdef TIMING + ti = click() +#endif +! ! Send (1,j)th equations. +! ! Receive (0,j)th equations. + + call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 90 j = 1, XSPS +! Forward elimination in (1,j)th equations + fac(j) = 1./(1. - c(1,j)*zn(j,1)) +! Check for singular matrix (debugging only) + r(1,j) = (r(1,j) - c(1,j)*zn(j,2))*fac(j) +! Backward elimination in (0,j)th equations. + r(0,j) = zn(j,2) - zn(j,1)*r(1,j) +! Forward elimination in (ZSPS,j)th equations. + r(ZSPS,j) = r(ZSPS,j) - c(ZSPS,j)*r(1,j) +! Load (ZSPS,j)th equations into passing arrays. + zntmp(j,1) = 0. + zntmp(j,2) = r(ZSPS,j) + 90 continue + +#ifdef TIMING + ti = click() +#endif +! ! Send (ZSPS,j)th equations. + + call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 100 j = 1, XSPS +! Forward elimination in (ZSPS+1,j)th equations to get +! r(ZSPS+1,j). + r(ZSPS+1,j) = t2(j) - t1(j)*r(ZSPS,j) + do 110 i = 2, ZSPS-1 +! Completion of forward and backward elimination to get remaining unknowns. + r(i,j) = r(i,j) - c(i,j)*r(1,j) - b(i,j)*r(ZSPS,j) + 110 continue + 100 continue + + call mpi_wait(sendReq, mpp_status, ierr) + + else + +! Load (1,j)th equations into passing arrays. + do 120 j = 1, XSPS + zntmp(j,1) = c(1,j) + zntmp(j,2) = r(1,j) + 120 continue + +#ifdef TIMING + ti = click() +#endif +! ! Send (1,j)th equations. +! ! Receive (0,j)th equations. + + call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 130 j = 1, XSPS +! Forward elimination in (1,j)th equations to get r(1,j). + fac(j) = 1./(1. - c(1,j)*zn(j,1)) +! Check for singular matrix (debugging only) + r(1,j) = (r(1,j) - c(1,j)*zn(j,2))*fac(j) +! Backward elimination in (0,j)th equations to get remaining unknowns. + r(0,j) = zn(j,2) - zn(j,1)*r(1,j) + do 140 i = 2, ZSPS +! Completion of forward elimination to get remaining unknowns. + r(i,j) = r(i,j) - c(i,j)*r(1,j) + 140 continue + 130 continue + + endif + + return + end subroutine + + +! Parallel tridiagonal solver useful for domain decomposed ADI +! Author(s): Mike Lambert +! Year: 1996 +! Institution: Lawrence Livermore National Laboratory +! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method +! for solution of the steady state diffusion equation", +! Parallel Computing 23 (1997) 2041-2065 +! Ported to MPI by Benjamin Fersch, Karlsruhe Institute of Technology (2013) + + subroutine parxsolv1(c,b,r,ct,pid,x_pid, & + xsps, zsps, xdns, zdns) + + implicit none + + integer, intent(in) :: XSPS, & + ZSPS, & + XDNS, & + ZDNS + + real, dimension(ZSPS, XSPS), intent(inout) :: c, & + b + + + real, dimension(0:ZSPS+1, 0:XSPS+1), intent(inout) :: r + + real, dimension(ZSPS,2) :: xn, xntmp + + integer XN_REC + parameter (XN_REC = 45) + + real, dimension(ZSPS) :: t1, t2, fac + real :: clockdt, click + real :: ct, ti, tf, dt + + integer :: pid, x_pid + integer :: i, j, sndr_pid, msg_type, cnt, ackn + integer :: sendReq, recvReq + + integer :: source, dest + + +#ifdef TIMING + dt = clockdt() +#endif + + if (x_pid .eq. 1) then + +! Load passing (i,XSPS)th equations into passing arrays. + do 10 i = 1, ZSPS + xntmp(i,1) = b(i,XSPS) + xntmp(i,2) = r(i,XSPS) + 10 continue + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Send (i,XSPS)th equations. +! ! Receive (i,(XSPS + 1))th equations. + + call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 20 i = 1, ZSPS +! Backward elimination in (i,XSPS)th equations to get +! r(i,XSPS) + fac(i) = 1./(1. - b(i,XSPS)*xn(i,1)) + r(i,XSPS) = (r(i,XSPS)-b(i,XSPS)*xn(i,2))*fac(i) +! Forward elimination in (i,XSPS+1)th equations to get +! r(i,XSPS+1) + r(i,XSPS+1) = xn(i,2) - xn(i,1)*r(i,XSPS) + 20 continue + +! Completion of backward elimination to get remaining unknowns. + do 30 j = 1, XSPS-1 + do 30 i = 1, ZSPS + r(i,j) = r(i,j) - b(i,j)*r(i,XSPS) + 30 continue + + else if (x_pid .le. XDNS/2) then + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Receive (i,0)th equations. + + call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + +! Forward elimination in (i,1)th equations of subdomain. + do 40 i = 1, ZSPS + fac(i) = 1./(1. - c(i,1)*xn(i,1)) + b(i,1) = b(i,1)*fac(i) + r(i,1) = (r(i,1) - c(i,1)*xn(i,2))*fac(i) +! Forward elimination in (i,XSPS)th equations of subdomain. + fac(i) = 1./(1. - c(i,XSPS)*b(i,1)) + b(i,XSPS) = b(i,XSPS)*fac(i) + r(i,XSPS)=(r(i,XSPS)-c(i,XSPS)*r(i,1))*fac(i) +! Store (i,0)th equations for later recovery of r(i,0). + t1(i) = xn(i,1) + t2(i) = xn(i,2) +! Load (i,XSPS)th equations into passing arrays. + xntmp(i,1) = b(i,XSPS) + xntmp(i,2) = r(i,XSPS) + 40 continue + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Send (i,XSPS)th equations. +! ! Receive (i,(XSPS + 1))th equations. + + call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 50 i = 1, ZSPS +! Backward elimination in (i,XSPS)th equations. + fac(i) = 1./(1. - b(i,XSPS)*xn(i,1)) + r(i,XSPS) = (r(i,XSPS) - b(i,XSPS)*xn(i,2))*fac(i) +! Backward elimination in (i,XSPS+1)th equations. + r(i,XSPS+1) = xn(i,2) - xn(i,1)*r(i,XSPS) +! Backward elimination in (i,1)th equations to get r(i,1). + r(i,1) = r(i,1) - b(i,1)*r(i,XSPS) +! Load (i,1)th equations into passing array. + xntmp(i,1) = 0. + xntmp(i,2) = r(i,1) + 50 continue + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Send (i,1)th equations. + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + + do 60 i = 1, ZSPS +! Backward elimination in (i,0)th equations. + r(i,0) = t2(i) - t1(i)*r(i,1) + 60 continue + +! Completion of forward and backward elimination for solution of +! unknowns. + do 70 j = 2, XSPS-1 + do 70 i = 1, ZSPS + r(i,j) = r(i,j) - b(i,j)*r(i,XSPS) - c(i,j)*r(i,1) + 70 continue + + call mpi_wait(sendReq, mpp_status, ierr) + + else if (x_pid .lt. XDNS) then + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Receive (i,XSPS+1)th equations. + + call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 80 i = 1, ZSPS +! Backward elimination in (i,XSPS)th equations. + fac(i) = 1./(1. - b(i,XSPS)*xn(i,1)) + c(i,XSPS) = c(i,XSPS)*fac(i) + r(i,XSPS) = (r(i,XSPS) - b(i,XSPS)*xn(i,2))*fac(i) +! Backward elimination in (i,1)th equations. + fac(i) = 1./(1. - b(i,1)*c(i,XSPS)) + c(i,1) = c(i,1)*fac(i) + r(i,1) = (r(i,1) - b(i,1)*r(i,XSPS))*fac(i) +! Store (i,XSPS+1)th equations for later recovery of r(i,XSPS+1). + t1(i) = xn(i,1) + t2(i) = xn(i,2) +! Load passing arrays with (i,1)th equations. + xntmp(i,1) = c(i,1) + xntmp(i,2) = r(i,1) + 80 continue + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Send (i,1)th equations. +! ! Receive (i,0)th equations. + call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 90 i = 1, ZSPS +! Forward elimination in (i,1)th equations + fac(i) = 1./(1. - c(i,1)*xn(i,1)) + r(i,1) = (r(i,1) - c(i,1)*xn(i,2))*fac(i) +! Backward elimination in (i,0)th equations. + r(i,0) = xn(i,2) - xn(i,1)*r(i,1) +! Forward elimination in (i,XSPS)th equations. + r(i,XSPS) = r(i,XSPS) - c(i,XSPS)*r(i,1) +! Load (i,XSPS)th equations into passing arrays. + xntmp(i,1) = 0. + xntmp(i,2) = r(i,XSPS) + 90 continue + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Send (i,XSPS)th equations. + + call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + +! Forward elimination in (i,XSPS)th equations to get +! r(i,XSPS+1). + do 100 i = 1, ZSPS + r(i,XSPS+1) = t2(i) - t1(i)*r(i,XSPS) + 100 continue + +! Completion of forward and backward elimination to get remaining unknowns. + do 110 j = 2, XSPS-1 + do 110 i = 1, ZSPS + r(i,j) = r(i,j) - c(i,j)*r(i,1) - b(i,j)*r(i,XSPS) + 110 continue + + call mpi_wait(sendReq, mpp_status, ierr) + + else + +! Load (i,1)th equations into passing arrays. + do 120 i = 1, ZSPS + xntmp(i,1) = c(i,1) + xntmp(i,2) = r(i,1) + 120 continue + + cnt = 2*ZSPS +#ifdef TIMING + ti = click() +#endif +! ! Send (i,1)th equations. +! ! Receive (i,0)th equations. + + call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call mpi_wait(sendReq, mpp_status, ierr) + call mpi_wait(recvReq, mpp_status, ierr) + +#ifdef TIMING + tf = click() + call add_dt(ct,tf,ti,dt) +#endif + + do 130 i = 1, ZSPS +! Forward elimination in (i,1)th equations to get r(i,1). + fac(i) = 1./(1. - c(i,1)*xn(i,1)) + r(i,1) = (r(i,1) - c(i,1)*xn(i,2))*fac(i) +! Backward elimination in (i,0)th equations to get r(i,0). + r(i,0) = xn(i,2) - xn(i,1)*r(i,1) + 130 continue + +! Completion of forward elimination to get remaining unknowns. + do 140 j = 2, XSPS + do 140 i = 1, ZSPS + r(i,j) = r(i,j) - c(i,j)*r(i,1) + 140 continue + + endif + + return + end subroutine + + +! Parallel tridiagonal solver useful for domain decomposed ADI +! Author(s): Mike Lambert +! Year: 1996 +! Institution: Lawrence Livermore National Laboratory +! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method +! for solution of the steady state diffusion equation", +! Parallel Computing 23 (1997) 2041-2065 + + subroutine sub_n_form(n_xs,n_zs,c,a,b,r,c2,b2,r2,wk,xfac,zfac, & + dpid,dn_subs,dir) + + implicit none + + integer n_xs,n_zs + +! c(,) -- subdiagonal elements of tridiagonal systems +! a(,) -- diagonal elements of tridiagonal systems +! b(,) -- superdiagonal elements of tridiagonal systems +! r(,) -- right-hand side elements of tridiagonal systems +! c2(,) -- front-leg elements of N-systems +! b2(,) -- back-leg elements of N-systems +! r2(,) -- right-hand side elements of N-systems +! wk(,) -- work array with same dimensions as a, b, c, etc. + real c(n_zs,n_xs) + real a(n_zs,n_xs) + real b(n_zs,n_xs) + real r(n_zs,n_xs) + real c2(n_zs,n_xs) + real b2(n_zs,n_xs) + real r2(0:n_zs+1,0:n_xs+1) + real wk(n_zs,n_xs) + real fac + real xfac(n_zs) + real zfac(n_xs) + + integer dpid,dn_subs,dir + integer i, j, XDIR, ZDIR + parameter (XDIR = 1, ZDIR = 2) + + if (dir .eq. XDIR) then + +! Forward elimination of subdiagonal elements + if (dpid .eq. 1) then + + do 10 i = 1, n_zs + xfac(i) = 1./a(i,1) + c2(i,1) = 0. + r2(i,1) = r(i,1)*xfac(i) + 10 continue + + do 20 j = 2, n_xs + do 20 i = 1, n_zs + wk(i,j-1) = b(i,j-1)*xfac(i) + xfac(i) = 1./(a(i,j) - c(i,j)*wk(i,j-1)) + c2(i,j) = 0. + r2(i,j) = (r(i,j) - c(i,j)*r2(i,j-1))*xfac(i) + 20 continue + + do 40 i = 1, n_zs + b2(i,n_xs) = b(i,n_xs)*xfac(i) + 40 continue + + else + + do 50 i = 1, n_zs + xfac(i) = 1./a(i,1) + c2(i,1) = c(i,1)*xfac(i) + wk(i,1) = b(i,1)*xfac(i) + r2(i,1) = r(i,1)*xfac(i) + xfac(i) = 1./a(i,2) + c2(i,2) = c(i,2)*xfac(i) + r2(i,2) = r(i,2)*xfac(i) + 50 continue + + do 60 j = 3, n_xs + do 60 i = 1, n_zs + wk(i,j-1) = b(i,j-1)*xfac(i) + xfac(i) = 1./(a(i,j) - c(i,j)*wk(i,j-1)) + c2(i,j) = -c(i,j)*c2(i,j-1)*xfac(i) + r2(i,j) = (r(i,j) - c(i,j)*r2(i,j-1))*xfac(i) + 60 continue + + do 80 i = 1, n_zs + b2(i,n_xs) = b(i,n_xs)*xfac(i) + 80 continue + + endif + +! Backward elimination of superdiagonal elements + if (dpid .eq. dn_subs) then + + do 90 j = n_xs-1, 2, -1 + do 90 i = 1, n_zs + c2(i,j) = c2(i,j) - wk(i,j)*c2(i,j+1) + b2(i,j) = 0. + r2(i,j) = r2(i,j) - wk(i,j)*r2(i,j+1) + 90 continue + + do 100 i = 1, n_zs + fac = 1./(1. - wk(i,1)*c2(i,2)) + c2(i,1) = c2(i,1)*fac + b2(i,1) = 0. + r2(i,1) = (r2(i,1) - wk(i,1)*r2(i,2))*fac + 100 continue + + else + + do 110 i = 1, n_zs + b2(i,n_xs-1) = wk(i,n_xs-1) + 110 continue + + do 120 j = n_xs-2, 2, -1 + do 120 i = 1, n_zs + c2(i,j) = c2(i,j) - wk(i,j)*c2(i,j+1) + b2(i,j) = -wk(i,j)*b2(i,j+1) + r2(i,j) = r2(i,j) - wk(i,j)*r2(i,j+1) + 120 continue + +! If only 2 points in X-direction, do not execute these statements. + if (n_xs .gt. 2) then + do 130 i = 1, n_zs + fac = 1./(1. - wk(i,1)*c2(i,2)) + c2(i,1) = c2(i,1)*fac + r2(i,1) = (r2(i,1) - wk(i,1)*r2(i,2))*fac + b2(i,1) = -wk(i,1)*b2(i,2)*fac + 130 continue + endif + + endif + + else if (dir .eq. ZDIR) then + +! Forward elimination of subdiagonal elements + if (dpid .eq. 1) then + + do 140 j = 1, n_xs + zfac(j) = 1./a(1,j) + c2(1,j) = 0. + r2(1,j) = r(1,j)*zfac(j) + 140 continue + + do 150 i = 2, n_zs + do 150 j = 1, n_xs + wk(i-1,j) = b(i-1,j)*zfac(j) + zfac(j) = 1./(a(i,j) - c(i,j)*wk(i-1,j)) + c2(i,j) = 0. + r2(i,j) = (r(i,j) - c(i,j)*r2(i-1,j))*zfac(j) + 150 continue + + do 170 j = 1, n_xs + b2(n_zs,j) = b(n_zs,j)*zfac(j) + 170 continue + + else + + do 180 j = 1, n_xs + zfac(j) = 1./a(1,j) + c2(1,j) = c(1,j)*zfac(j) + wk(1,j) = b(1,j)*zfac(j) + r2(1,j) = r(1,j)*zfac(j) + zfac(j) = 1./a(2,j) + c2(2,j) = c(2,j)*zfac(j) + r2(2,j) = r(2,j)*zfac(j) + 180 continue + + do 190 i = 3, n_zs + do 190 j = 1, n_xs + wk(i-1,j) = b(i-1,j)*zfac(j) + zfac(j) = 1./(a(i,j) - c(i,j)*wk(i-1,j)) + c2(i,j) = -c(i,j)*c2(i-1,j)*zfac(j) + r2(i,j) = (r(i,j) - c(i,j)*r2(i-1,j))*zfac(j) + 190 continue + + do 210 j = 1, n_xs + b2(n_zs,j) = b(n_zs,j)*zfac(j) + 210 continue + + endif + +! Backward elimination of superdiagonal elements + if (dpid .eq. dn_subs) then + + do 220 j = 1, n_xs + do 220 i = n_zs - 1, 2, -1 + c2(i,j) = c2(i,j) - wk(i,j)*c2(i+1,j) + b2(i,j) = 0. + r2(i,j) = r2(i,j) - wk(i,j)*r2(i+1,j) + 220 continue + + do 230 j = 1, n_xs + fac = 1./(1. - wk(1,j)*c2(2,j)) + c2(1,j) = c2(1,j)*fac + b2(1,j) = 0. + r2(1,j) = (r2(1,j) - wk(1,j)*r2(2,j))*fac + 230 continue + + else + + do 240 j = 1, n_xs + b2(n_zs-1,j) = wk(n_zs-1,j) + 240 continue + + do 250 j = 1, n_xs + do 250 i = n_zs - 2, 2, -1 + c2(i,j) = c2(i,j) - wk(i,j)*c2(i+1,j) + b2(i,j) = -wk(i,j)*b2(i+1,j) + r2(i,j) = r2(i,j) - wk(i,j)*r2(i+1,j) + 250 continue + +! If only 2 points in Z-direction, do not execute these statements. + if (n_zs .gt. 2) then + do 260 j = 1, n_xs + fac = 1./(1. - wk(1,j)*c2(2,j)) + c2(1,j) = c2(1,j)*fac + r2(1,j) = (r2(1,j) - wk(1,j)*r2(2,j))*fac + b2(1,j) = -wk(1,j)*b2(2,j)*fac + 260 continue + endif + + endif + +! Announce bad direction specifier (debugging only) +! else +! write(*,*) 'sub_n_form: What direction?' +! stop + endif + + return + end subroutine +#endif + +! Tridiagonal solver useful for domain decomposed ADI +! Author(s): Mike Lambert +! Year: 1996 +! Institution: Lawrence Livermore National Laboratory +! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method +! for solution of the steady state diffusion equation", +! Parallel Computing 23 (1997) 2041-2065 + + subroutine sub_tri_solv(n_xs,n_zs,c,a,b,r,x,wk,xfac,zfac,dir) + + implicit none + + integer n_xs,n_zs + +! c(,) -- subdiagonal elements of tridiagonal systems +! a(,) -- diagonal elements of tridiagonal systems +! b(,) -- superdiagonal elements of tridiagonal systems +! r(,) -- right-hand side elements of tridiagonal systems +! x(,) -- solutions +! wk(,) -- work array w/ same dimensions as c, a, b, etc. + + real c(n_zs,n_xs) + real a(n_zs,n_xs) + real b(n_zs,n_xs) + real r(n_zs,n_xs) + real x(0:n_zs+1,0:n_xs+1) + real wk(n_zs,n_xs) + real xfac(n_zs) + real zfac(n_xs) + + integer dir + integer i,j,XDIR,ZDIR + + parameter (XDIR = 1, ZDIR = 2) + + if (dir .eq. XDIR) then + + do 10 i = 1, n_zs +! Check for need to pivot (debugging only) + xfac(i) = 1./a(i,1) + x(i,1) = r(i,1)*xfac(i) + 10 continue + +! Forward subdiagonal elimination + do 20 j = 2, n_xs + do 20 i = 1, n_zs + wk(i,j-1) = b(i,j-1)*xfac(i) + xfac(i) = 1./(a(i,j) - c(i,j)*wk(i,j-1)) +! Check for need to pivot (debugging only) + x(i,j) = (r(i,j) - c(i,j)*x(i,j-1))*xfac(i) + 20 continue + +! Backsubstitution + do 30 j = n_xs - 1, 1, -1 + do 30 i = 1, n_zs + x(i,j) = x(i,j) - wk(i,j)*x(i,j+1) + 30 continue + + + else if (dir .eq. ZDIR) then + + do j = 1, n_xs +! Check for need to pivot (debugging only) + zfac(j) = 1./a(1,j) + x(1,j) = r(1,j)*zfac(j) + end do + +! Forward subdiagonal elimination + do j = 1, n_xs + do i = 2, n_zs + wk(i-1,j) = b(i-1,j)*zfac(j) + zfac(j) = 1./(a(i,j) - c(i,j)*wk(i-1,j)) +! Check for need to pivot (debugging only) + x(i,j) = (r(i,j) - c(i,j)*x(i-1,j))*zfac(j) + end do + end do + +! Backsubstitution + do j = 1, n_xs + do i = n_zs - 1, 1, -1 + x(i,j) = x(i,j) - wk(i,j)*x(i+1,j) + end do + end do + +! Announce bad direction specifier (debugging only) +! else +! write(*,*) 'sub_tri_solv: What direction?' +! stop + endif + + return + end subroutine + + +end module module_gw_gw2d diff --git a/wrfv2_fire/hydro/Routing/module_lsm_forcing.F b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F new file mode 100644 index 00000000..0e23d539 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F @@ -0,0 +1,3291 @@ +! Program Name: +! 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_lsm_forcing + +#ifdef MPP_LAND + use module_mpp_land +#endif + use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int + +implicit none +#include + integer :: i_forcing +character(len=19) out_date + +interface read_hydro_forcing +#ifdef MPP_LAND + !yw module procedure read_hydro_forcing_mpp + module procedure read_hydro_forcing_mpp1 +#else + module procedure read_hydro_forcing_seq +#endif +end interface + +Contains + + subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) + + implicit none + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar + integer tlevel + + character(len=256) :: units + integer :: ierr + integer :: ncid + + tlevel = 1 + + pcp = 0 + pcpc = 0 + + ! Open the NetCDF file. + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READFORC_WRF() - Problem opening netcdf file") + endif + + call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) + 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. + endif + call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) + + ierr = nf_close(ncid) + +!DJG Add the convective and non-convective rain components (note: conv. comp=0 +!for cloud resolving runs...) +!DJG Note that for WRF these are accumulated values to be adjusted to rates in +!driver... + + pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... + + end subroutine READFORC_WRF + + subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) + ! Simply return the dimensions of the grid. + implicit none + character(len=*), intent(in) :: geo_static_flnm + integer, intent(out) :: ix, jx, land_cat, soil_cat ! dimensions + + integer :: iret, ncid, dimid + + ! Open the NetCDF file. + iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + if (iret /= 0) then + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(geo_static_flnm) + call hydro_stop("In read_hrldas_hdrinfo() - Problem opening geo_static file") + endif + + iret = nf_inq_dimid(ncid, "west_east", dimid) + + if (iret /= 0) then +! print*, "nf_inq_dimid: west_east" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: west_east problem") + endif + + iret = nf_inq_dimlen(ncid, dimid, ix) + if (iret /= 0) then +! print*, "nf_inq_dimlen: west_east" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: west_east problem") + endif + + iret = nf_inq_dimid(ncid, "south_north", dimid) + if (iret /= 0) then +! print*, "nf_inq_dimid: south_north" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: south_north problem") + endif + + iret = nf_inq_dimlen(ncid, dimid, jx) + if (iret /= 0) then + ! print*, "nf_inq_dimlen: south_north" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: south_north problem") + endif + + iret = nf_inq_dimid(ncid, "land_cat", dimid) + if (iret /= 0) then + ! print*, "nf_inq_dimid: land_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: land_cat problem") + endif + + iret = nf_inq_dimlen(ncid, dimid, land_cat) + if (iret /= 0) then + print*, "nf_inq_dimlen: land_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: land_cat problem") + endif + + iret = nf_inq_dimid(ncid, "soil_cat", dimid) + if (iret /= 0) then + ! print*, "nf_inq_dimid: soil_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: soil_cat problem") + endif + + iret = nf_inq_dimlen(ncid, dimid, soil_cat) + if (iret /= 0) then + ! print*, "nf_inq_dimlen: soil_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: soil_cat problem") + endif + + iret = nf_close(ncid) + + end subroutine read_hrldas_hdrinfo + + + + subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp, & + terrain,latitude,longitude,SOLVEG_INITSWC) + implicit none + character(len=*), intent(in) :: geo_static_flnm + integer, intent(in) :: ix, jx, land_cat, soil_cat,SOLVEG_INITSWC + integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp + real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude + + character(len=256) :: units + integer :: ierr,i,j,jj + integer :: ncid,varid + real, dimension(ix,jx) :: xdum + integer, dimension(ix,jx) :: vegtyp_inv, soiltyp_inv,xdum_int + integer flag ! flag = 1 from wrfsi, flag =2 from WPS. + CHARACTER(len=256) :: var_name + + + ! Open the NetCDF file. + ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + + if (ierr /= 0) then + write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm) + call hydro_stop("In readland_hrldas() - Problem opening geo_static file") + endif + + flag = -99 + ierr = nf_inq_varid(ncid,"XLAT", varid) + flag = 1 + if(ierr .ne. 0) then + ierr = nf_inq_varid(ncid,"XLAT_M", varid) + if(ierr .ne. 0) then +! write(6,*) "XLAT not found from wrfstatic file. " + call hydro_stop("In readland_hrldas() - XLAT not found from wrfstatic file") + endif + flag = 2 + endif + + ! Get Latitude (lat) + if(flag .eq. 1) then + call get_2d_netcdf("XLAT", ncid, latitude, units, ix, jx, .TRUE., ierr) + else + call get_2d_netcdf("XLAT_M", ncid, latitude, units, ix, jx, .TRUE., ierr) + endif + + ! Get Longitude (lon) + if(flag .eq. 1) then + call get_2d_netcdf("XLONG", ncid, longitude, units, ix, jx, .TRUE., ierr) + else + call get_2d_netcdf("XLONG_M", ncid, longitude, units, ix, jx, .TRUE., ierr) + endif + + ! Get Terrain (avg) + if(flag .eq. 1) then + call get_2d_netcdf("HGT", ncid, terrain, units, ix, jx, .TRUE., ierr) + else + call get_2d_netcdf("HGT_M", ncid, terrain, units, ix, jx, .TRUE., ierr) + endif + + + if (SOLVEG_INITSWC.eq.0) then +! ! Get Dominant Land Use categories (use) +! call get_landuse_netcdf(ncid, xdum , units, ix, jx, land_cat) +! vegtyp = nint(xdum) + + var_name = "LU_INDEX" + call get2d_int(var_name,xdum_int,ix,jx,& + trim(geo_static_flnm)) + vegtyp = xdum_int + + ! Get Dominant Soil Type categories in the top layer (stl) + call get_soilcat_netcdf(ncid, xdum , units, ix, jx, soil_cat) + soltyp = nint(xdum) + + else if (SOLVEG_INITSWC.eq.1) then + var_name = "VEGTYP" + call get2d_int(var_name,VEGTYP_inv,ix,jx,& + trim(geo_static_flnm)) + + var_name = "SOILTYP" + call get2d_int(var_name,SOILTYP_inv,ix,jx,& + trim(geo_static_flnm)) + do i=1,ix + jj=jx + do j=1,jx + VEGTYP(i,j)=VEGTYP_inv(i,jj) + SOLTYP(i,j)=SOILTYP_inv(i,jj) + jj=jx-j + end do + end do + + endif + + + + ! Close the NetCDF file + ierr = nf_close(ncid) + if (ierr /= 0) then + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF_CLOSE" + call hydro_stop("In readland_hrldas() - NF_CLOSE problem") + endif + + ! Make sure vegtyp and soltyp are consistent when it comes to water points, + ! by setting soil category to water when vegetation category is water, and + ! vice-versa. + where (vegtyp == 28) vegtyp = 16 + where (vegtyp == 16) soltyp = 14 + where (soltyp == 14) vegtyp = 16 + +!DJG test for deep gw function... +! where (soltyp <> 14) soltyp = 1 + + end subroutine readland_hrldas + + + subroutine get_2d_netcdf_ruc(var_name,ncid,var, & + ix,jx,tlevel,fatal_if_error,ierr) + character(len=*), intent(in) :: var_name + integer,intent(in) :: ncid,ix,jx,tlevel + real, intent(out):: var(ix,jx) + logical, intent(in) :: fatal_if_error + integer dims(4), dim_len(4) + integer ierr,iret + integer varid + integer start(4),count(4) + data count /1,1,1,1/ + data start /1,1,1,1/ + count(1) = ix + count(2) = jx + start(4) = tlevel + ierr = nf_inq_varid(ncid, var_name, varid) + + if (ierr /= 0) then + if (fatal_IF_ERROR) then + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name) + call hydro_stop("In get_2d_netcdf_ruc() - nf_inq_varid problem") + else + return + endif + endif + + ierr = nf_get_vara_real(ncid, varid, start,count,var) + + + return + end subroutine get_2d_netcdf_ruc + + + subroutine get_2d_netcdf_cows(var_name,ncid,var, & + ix,jx,tlevel,fatal_if_error,ierr) + character(len=*), intent(in) :: var_name + integer,intent(in) :: ncid,ix,jx,tlevel + real, intent(out):: var(ix,jx) + logical, intent(in) :: fatal_if_error + integer ierr, iret + integer varid + integer start(4),count(4) + data count /1,1,1,1/ + data start /1,1,1,1/ + count(1) = ix + count(2) = jx + start(4) = tlevel + iret = nf_inq_varid(ncid, var_name, varid) + + if (iret /= 0) then + if (fatal_IF_ERROR) then + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" + call hydro_stop("In get_2d_netcdf_cows() - nf_inq_varid problem") + else + ierr = iret + return + endif + endif + iret = nf_get_vara_real(ncid, varid, start,count,var) + + return + end subroutine get_2d_netcdf_cows + + + + + + subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & + smc, stc, sh2o, cmc, t1, weasd, snodep) + implicit none + character(len=*), intent(in) :: netcdf_flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + integer, intent(in) :: nsoil + character(len=*), intent(in) :: target_date + real, dimension(ix,jx,nsoil), intent(out) :: smc + real, dimension(ix,jx,nsoil), intent(out) :: stc + real, dimension(ix,jx,nsoil), intent(out) :: sh2o + real, dimension(ix,jx), intent(out) :: cmc + real, dimension(ix,jx), intent(out) :: t1 + real, dimension(ix,jx), intent(out) :: weasd + real, dimension(ix,jx), intent(out) :: snodep + + character(len=256) :: units + character(len=8) :: name + integer :: ix_read, jx_read,i,j + + integer :: ierr, ncid, ierr_snodep + integer :: idx + + logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois + + ! Open the NetCDF file. + ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') & + trim(netcdf_flnm) + call hydro_stop("In readinit_hrldas()- Problem opening netcdf file") + endif + + call get_2d_netcdf("CANWAT", ncid, cmc, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SKINTEMP", ncid, t1, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("WEASD", ncid, weasd, units, ix, jx, .TRUE., ierr) + + if (trim(units) == "m") then + ! No conversion necessary + else if (trim(units) == "mm") then + ! convert WEASD from mm to m + weasd = weasd * 1.E-3 + else + print*, 'units = "'//trim(units)//'"' +! print*, "Unrecognized units on WEASD" + call hydro_stop("In readinit_hrldas() - Unrecognized units on WEASD") + endif + + call get_2d_netcdf("SNODEP", ncid, snodep, units, ix, jx, .FALSE., ierr_snodep) + call get_2d_netcdf("STEMP_1", ncid, stc(:,:,1), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("STEMP_2", ncid, stc(:,:,2), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("STEMP_3", ncid, stc(:,:,3), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("STEMP_4", ncid, stc(:,:,4), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_1", ncid, smc(:,:,1), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_2", ncid, smc(:,:,2), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_3", ncid, smc(:,:,3), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_4", ncid, smc(:,:,4), units, ix, jx, .TRUE., ierr) + + + if (ierr_snodep /= 0) then + ! Quick assumption regarding snow depth. + snodep = weasd * 10. + endif + + +!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... + do i=1,ix + do j=1,jx + if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0 !set lower bound to correct bi-lin interp err... + if (snodep(i,j).lt.0.) snodep(i,j)=0.0 !set lower bound to correct bi-lin interp err... + end do + end do + + + sh2o = smc + + ierr = nf_close(ncid) + end subroutine readinit_hrldas + + + + + subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx), intent(out) :: t + real, dimension(ix,jx), intent(out) :: q + real, dimension(ix,jx), intent(out) :: u + real, dimension(ix,jx), intent(out) :: v + real, dimension(ix,jx), intent(out) :: p + real, dimension(ix,jx), intent(out) :: lw + real, dimension(ix,jx), intent(out) :: sw + real, dimension(ix,jx), intent(out) :: pcp + real, dimension(ix,jx), intent(inout) :: lai + real, dimension(ix,jx), intent(inout) :: fpar + + character(len=256) :: units + integer :: ierr + integer :: ncid + + ! Open the NetCDF file. + ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READFORC_HRLDAS() - Problem opening netcdf file") + endif + + call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 + endif + call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) + + ierr = nf_close(ncid) + + end subroutine READFORC_HRLDAS + + + + subroutine READFORC_DMIP(flnm,ix,jx,var) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + real, dimension(ix,jx), intent(out) :: var + character(len=13) :: head + integer :: ncols, nrows, cellsize + real :: xllc, yllc, no_data + integer :: i,j + character(len=256) ::junk + + open (77,file=trim(flnm),form="formatted",status="old") + +! read(77,732) head,ncols +! read(77,732) head,nrows +!732 FORMAT(A13,I4) +! read(77,733) head,xllc +! read(77,733) head,yllc +!733 FORMAT(A13,F16.9) +! read(77,732) head,cellsize +! read(77,732) head,no_data + + read(77,*) junk + read(77,*) junk + read(77,*) junk + read(77,*) junk + read(77,*) junk + read(77,*) junk + + do j=jx,1,-1 + read(77,*) (var(I,J),I=1,ix) + end do + close(77) + + end subroutine READFORC_DMIP + + + + subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + integer, intent(out) :: ierr_flg + integer :: it,jew,zsn + real, dimension(ix,jx), intent(out) :: pcp + + character(len=256) :: units + integer :: ierr,i,j,i2,j2,varid + integer :: ncid,mmflag + real, dimension(ix,jx) :: temp + + mmflag = 0 ! flag for units spec. (0=mm, 1=mm/s) + + +!open NetCDF file... + ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr_flg /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') & + trim(flnm) +#endif + return + end if + + ierr = nf_inq_varid(ncid, "precip", varid) + if(ierr /= 0) ierr_flg = ierr + if (ierr /= 0) then + ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & + trim(flnm) +#endif + end if + ierr_flg = ierr + mmflag = 1 + end if + ierr = nf_get_var_real(ncid, varid, pcp) + ierr = nf_close(ncid) + + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) +#endif + end if + + end subroutine READFORC_MDV + + + + subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + integer, intent(in) :: k + character(len=*), intent(in) :: product + integer :: it,jew,zsn + parameter(it = 496,jew = 449, zsn = 499) ! domain 1 +! parameter(it = 496,jew = 74, zsn = 109) ! domain 2 + real, dimension(it,jew,zsn) :: buf + real, dimension(ix,jx), intent(out) :: pcp + + character(len=256) :: units + integer :: ierr,i,j,i2,j2,varid + integer :: ncid + real, dimension(ix,jx) :: temp + +! varname = trim(product) + +!open NetCDF file... + if (k.eq.1.) then + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') & + trim(flnm) + call hydro_stop("In READFORC_NAMPCP() - Problem opening netcdf file") + end if + + ierr = nf_inq_varid(ncid, trim(product), varid) + ierr = nf_get_var_real(ncid, varid, buf) + ierr = nf_close(ncid) + + if (ierr /= 0) then + write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') & + trim(flnm) + call hydro_stop("In READFORC_NAMPCP() - Problem reading netcdf file") + end if + endif +#ifdef HYDRO_D + print *, "Data read in...",it,ix,jx,k +#endif + +! Extract single time slice from dataset... + + do i=1,ix + do j=1,jx + pcp(i,j) = buf(k,i,j) + end do + end do + +! call get_2d_netcdf_ruc("trmm",ncid, pcp, jx, ix,k, .true., ierr) + + end subroutine READFORC_NAMPCP + + + + + subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx), intent(out) :: t + real, dimension(ix,jx), intent(out) :: q + real, dimension(ix,jx), intent(out) :: u + real, dimension(ix,jx) :: v + real, dimension(ix,jx), intent(out) :: p + real, dimension(ix,jx), intent(out) :: lw + real, dimension(ix,jx), intent(out) :: sw + real, dimension(ix,jx), intent(out) :: pcp + integer tlevel + + character(len=256) :: units + integer :: ierr + integer :: ncid + + ! Open the NetCDF file. + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READFORC_COWS() - Problem opening netcdf file") + endif + + call get_2d_netcdf_cows("TA2", ncid, t, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("QV2", ncid, q, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("WSPD10", ncid, u, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("PRES", ncid, p, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("GLW", ncid, lw, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("RSD", ncid, sw, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("RAIN", ncid, pcp, ix, jx,tlevel, .TRUE., ierr) +!yw call get_2d_netcdf_cows("V2D", ncid, v, ix, jx,tlevel, .TRUE., ierr) + + ierr = nf_close(ncid) + + end subroutine READFORC_COWS + + + + + subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) + + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc + integer tlevel + + character(len=256) :: units + integer :: ierr + integer :: ncid + + tlevel = 1 + + ! Open the NetCDF file. + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READFORC_RUC() - Problem opening netcdf file") + endif + + call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) + + ierr = nf_close(ncid) + + +!DJG Add the convective and non-convective rain components (note: conv. comp=0 +!for cloud resolving runs...) +!DJG Note that for RUC these are accumulated values to be adjusted to rates in +!driver... + + pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... + + end subroutine READFORC_RUC + + + + + subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + real, dimension(ix,jx), intent(out) :: weasd + real, dimension(ix,jx), intent(out) :: snodep + real, dimension(ix,jx) :: tmp + + character(len=256) :: units + integer :: ierr + integer :: ncid,i,j + + ! Open the NetCDF file. + + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READSNOW_FORC() - Problem opening netcdf file") + endif + + call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) + if (ierr /= 0) then + call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + units = "mm" + print *, "read WEASD from wrfoutput ...... " + weasd = tmp * 1.E-3 + endif + else + weasd = tmp + if (trim(units) == "m") then + ! No conversion necessary + else if (trim(units) == "mm") then + ! convert WEASD from mm to m + weasd = weasd * 1.E-3 + endif + endif + + if (ierr /= 0) then + print *, "!!!!! NO WEASD present in input file...initialize to 0." + endif + + call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) + if (ierr /= 0) then + ! Quick assumption regarding snow depth. + call get_2d_netcdf("SNOWH", ncid, tmp, units, ix, jx, .FALSE., ierr) + if(ierr .eq. 0) then + print *, "read snow depth from wrfoutput ... " + snodep = tmp + endif + else + snodep = tmp + endif + + if (ierr /= 0) then + ! Quick assumption regarding snow depth. +!yw snodep = weasd * 10. + where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... + endif + +!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... + where(snodep .lt. 0) snodep = 0 + where(weasd .lt. 0) weasd = 0 + ierr = nf_close(ncid) + + end subroutine READSNOW_FORC + + subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) + implicit none + integer :: iret,varid,ncid,ix,jx,nsoil,ierr + real,dimension(ix,jx):: weasd,snodep,cmc,t1 + real,dimension(ix,jx,nsoil):: smc,stc,sh2ox + character(len=*), intent(in) :: inflnm + character(len=256):: units + iret = nf_open(trim(inflnm), NF_NOWRITE, ncid) + if(iret .ne. 0 )then + write(6,*) "Error: failed to open file :",trim(inflnm) + call hydro_stop("In get2d_hrldas() - failed to open file") + endif + + call get2d_hrldas_real("CMC", ncid, cmc, ix, jx) + call get2d_hrldas_real("TSKIN", ncid, t1, ix, jx) + call get2d_hrldas_real("SWE", ncid, weasd, ix, jx) + call get2d_hrldas_real("SNODEP", ncid, snodep, ix, jx) + + call get2d_hrldas_real("SOIL_T_1", ncid, stc(:,:,1), ix, jx) + call get2d_hrldas_real("SOIL_T_2", ncid, stc(:,:,2), ix, jx) + call get2d_hrldas_real("SOIL_T_3", ncid, stc(:,:,3), ix, jx) + call get2d_hrldas_real("SOIL_T_4", ncid, stc(:,:,4), ix, jx) + call get2d_hrldas_real("SOIL_T_5", ncid, stc(:,:,5), ix, jx) + call get2d_hrldas_real("SOIL_T_6", ncid, stc(:,:,6), ix, jx) + call get2d_hrldas_real("SOIL_T_7", ncid, stc(:,:,7), ix, jx) + call get2d_hrldas_real("SOIL_T_8", ncid, stc(:,:,8), ix, jx) + + call get2d_hrldas_real("SOIL_M_1", ncid, SMC(:,:,1), ix, jx) + call get2d_hrldas_real("SOIL_M_2", ncid, SMC(:,:,2), ix, jx) + call get2d_hrldas_real("SOIL_M_3", ncid, SMC(:,:,3), ix, jx) + call get2d_hrldas_real("SOIL_M_4", ncid, SMC(:,:,4), ix, jx) + call get2d_hrldas_real("SOIL_M_5", ncid, SMC(:,:,5), ix, jx) + call get2d_hrldas_real("SOIL_M_6", ncid, SMC(:,:,6), ix, jx) + call get2d_hrldas_real("SOIL_M_7", ncid, SMC(:,:,7), ix, jx) + call get2d_hrldas_real("SOIL_M_8", ncid, SMC(:,:,8), ix, jx) + + call get2d_hrldas_real("SOIL_W_1", ncid, SH2OX(:,:,1), ix, jx) + call get2d_hrldas_real("SOIL_W_2", ncid, SH2OX(:,:,2), ix, jx) + call get2d_hrldas_real("SOIL_W_3", ncid, SH2OX(:,:,3), ix, jx) + call get2d_hrldas_real("SOIL_W_4", ncid, SH2OX(:,:,4), ix, jx) + call get2d_hrldas_real("SOIL_W_5", ncid, SH2OX(:,:,5), ix, jx) + call get2d_hrldas_real("SOIL_W_6", ncid, SH2OX(:,:,6), ix, jx) + call get2d_hrldas_real("SOIL_W_7", ncid, SH2OX(:,:,7), ix, jx) + call get2d_hrldas_real("SOIL_W_8", ncid, SH2OX(:,:,8), ix, jx) + + iret = nf_close(ncid) + return + end subroutine get2d_hrldas + + subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) + implicit none + integer ::iret,varid,ncid,ix,jx + real out_buff(ix,jx) + character(len=*), intent(in) :: var_name + iret = nf_inq_varid(ncid,trim(var_name), varid) + iret = nf_get_var_real(ncid, varid, out_buff) + return + end subroutine get2d_hrldas_real + + subroutine read_stage4(flnm,IX,JX,pcp) + integer IX,JX,ierr,ncid,i,j + real pcp(IX,JX),buf(ix,jx) + character(len=*), intent(in) :: flnm + character(len=256) :: units + + ierr = nf_open(flnm, NF_NOWRITE, ncid) + + if(ierr .ne. 0) then + call hydro_stop("In read_stage4() - failed to open stage4 file.") + endif + + call get_2d_netcdf("RAINRATE",ncid, buf, units, ix, jx, .TRUE., ierr) + ierr = nf_close(ncid) + do j = 1, jx + do i = 1, ix + if(buf(i,j) .lt. 0) then + buf(i,j) = pcp(i,j) + end if + end do + end do + pcp = buf + return + END subroutine read_stage4 + + + + + subroutine read_hydro_forcing_seq( & + indir,olddate,hgrid, & + ix,jx,forc_typ,snow_assim, & + T2,q2x,u,v,pres,xlong,short,prcp1,& + lai,fpar,snodep,dt,k,prcp_old) +! This subrouting is going to read different forcing. + implicit none + ! in variable + character(len=*) :: olddate,hgrid,indir + character(len=256) :: filename + integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& + prcpnew,weasd,snodep,prcp0,prcp2,prcp_old + real :: dt, wrf_dt + ! tmp variable + character(len=256) :: inflnm, inflnm2, product + integer :: i,j,mmflag,ierr_flg + real,dimension(ix,jx):: lai,fpar + character(len=4) nwxst_t + logical :: fexist + + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASIN_DOMAIN"//hgrid + +!!!DJG... Call READFORC_(variable) Subroutine for forcing data... +!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) + if(FORC_TYP.eq.1) then +!!Create forcing data filename... + call geth_newdate(out_date,olddate,nint(dt)) + inflnm = trim(indir)//"/"//& + out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//& + ".LDASIN_DOMAIN"//hgrid + + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then + print*, "no forcing data found", inflnm + call hydro_stop("In read_hydro_forcing_seq") + endif + + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + end if + + + + +!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!) + if(FORC_TYP.eq.2) then +!!Create forcing data filename... + call geth_newdate(out_date,olddate,nint(dt)) + inflnm = trim(indir)//"/"//& + out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//& + out_date(15:16)//".LDASIN_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then + print*, "no forcing data found", inflnm + call hydro_stop("In read_hydro_forcing_seq() - no forcing data found") + endif + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + end if + + + + + +!!!DJG WRF Output File Direct Ingest Forcing... + if(FORC_TYP.eq.3) then +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& + "_"//olddate(12:13)//":00:00" + + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then + print*, "no forcing data found", inflnm + call hydro_stop("In read_hydro_forcing_seq() - no forcing data found") + endif + + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) + if (fexist ) goto 991 + end do +991 continue + + if(.not. fexist) then + write(6,*) "FATAL ERROR: could not find file ",trim(inflnm2) + call hydro_stop("In read_hydro_forcing_seq() - could not find file ") + endif +#ifdef HYDRO_D + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) + + end if + +!!!DJG CONSTant, idealized forcing... + if(FORC_TYP.eq.4) then +! Impose a fixed diurnal cycle... +! assumes model timestep is 1 hr +! assumes K=1 is 12z (Ks or ~ sunrise) +! First Precip... + IF (K.EQ.2) THEN + PRCP1 =25.4/3600.0 !units mm/s (Simulates 1"/hr for first time step...) +! PRCP1 =0./3600.0 !units mm/s (Simulates <1"/hr for first 10 hours...) + ELSEIF (K.GT.1) THEN +! PRCP1 =0./3600.0 !units mm/s +! ELSE + PRCP1 = 0. + END IF +! PRCP1 = 0. +! PRCP1 =10./3600.0 !units mm/s +! Other Met. Vars... + T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + Q2X = 0.01 + U = 1.0 + V = 1.0 + PRES = 100000.0 + XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + +! print *, "PCP", PRCP1 + + end if + +!!!DJG Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr') +! This option uses hard-wired met forcing EXCEPT precipitation which is read in +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' +! + if(FORC_TYP.eq.5) then +! Standard Met. Vars... + T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + Q2X = 0.01 + U = 1.0 + V = 1.0 + PRES = 100000.0 + XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +! product = "trmm" +! inflnm = trim(indir)//"/"//"sat_domain1.nc" +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then + print*, "no specified precipitation data found", inflnm + call hydro_stop("In read_hydro_forcing_seq() - no specified precipitation data found") + endif + + PRCP1 = 0. + PRCP_old = PRCP1 + +#ifdef HYDRO_D + print *, "Opening supplemental precipitation forcing file...",inflnm +#endif + CALL READFORC_MDV(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) + +!If radar or spec. data is ok use if not, skip to original NARR data... + IF (ierr_flg.eq.0) then ! use spec. precip +!Convert units if necessary + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + PRCP1=PRCP2/DT !convert from mm to mm/s +#ifdef HYDRO_D + print*, "Supplemental pcp is accumulated pcp/dt. " +#endif + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s +#ifdef HYDRO_D + print*, "Supplemental pcp is rate. " +#endif + END IF ! Endif mmflag + ELSE ! either stop or default to original forcing data... +#ifdef HYDRO_D + print *,"Current RADAR precip data not found !!! Using previous available file..." +#endif + PRCP1 = PRCP_old + END IF ! Endif ierr_flg + +! Loop through data to screen for plausible values + do i=1,ix + do j=1,jx + if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j) + if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h + end do + end do + + end if + + + + + +!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing... +! This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' + + if(FORC_TYP.eq.6) then + +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASIN_DOMAIN"//hgrid + + inquire (file=trim(inflnm), exist=fexist) + + if ( .not. fexist ) then + do i_forcing = 1, nint(12*3600/dt) + call geth_newdate(out_date,olddate,nint(i_forcing*dt)) + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".LDASIN_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + if(fexist) goto 201 + end do +201 continue + endif + + + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no ATM forcing data found at this time", inflnm +#endif + else +#ifdef HYDRO_D + print*, "reading forcing data at this time", inflnm +#endif + + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... + endif + + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef HYDRO_D + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) + endif +#endif + if ( .not. fexist ) then + prcp1 = PRCP_old ! for missing pcp data use analysis/model input + else + CALL READFORC_MDV(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) +!If radar or spec. data is ok use if not, skip to original NARR data... + if(ierr_flg .ne. 0) then +#ifdef HYDRO_D + print*, "WARNING: pcp reading problem: ", trim(inflnm) +#endif + PRCP1=PRCP_old + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + PRCP1=PRCP2/DT !convert from mm to mm/s + END IF ! Endif mmflag +#ifdef HYDRO_D + print*, "replace pcp successfully! ",trim(inflnm) +#endif + endif + endif + + +! Loop through data to screen for plausible values + where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old + do i=1,ix + do j=1,jx + if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 + if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h + end do + end do + + end if + + +!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing. + + if(FORC_TYP.eq.7) then + +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& + "_"//olddate(12:13)//":00:00" + + inquire (file=trim(inflnm), exist=fexist) + + + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no forcing data found", inflnm +#endif + else + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) + if (fexist ) goto 992 + end do +992 continue + +#ifdef HYDRO_D + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) + PRCP_old = PRCP1 + endif + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef HYDRO_D + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) + endif +#endif + if ( .not. fexist ) then + prcp1 = PRCP_old ! for missing pcp data use analysis/model input + else + CALL READFORC_MDV(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) +!If radar or spec. data is ok use if not, skip to original NARR data... + if(ierr_flg .ne. 0) then +#ifdef HYDRO_D + print*, "WARNING: pcp reading problem: ", trim(inflnm) +#endif + PRCP1=PRCP_old + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... +#ifdef HYDRO_D + write(6,*) "using supplemental pcp time interval ", DT +#endif + PRCP1=PRCP2/DT !convert from mm to mm/s + else +#ifdef HYDRO_D + write(6,*) "using supplemental pcp rates " +#endif + END IF ! Endif mmflag +#ifdef HYDRO_D + print*, "replace pcp successfully! ",trim(inflnm) +#endif + endif + endif + + +! Loop through data to screen for plausible values + where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h + where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h + end if + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!The other forcing data types below here are obsolete and left for reference... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!DJG HRLDAS Single Input with Multiple Input Times File Forcing... +! if(FORC_TYP.eq.6) then +!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& +! olddate(15:16)//".LDASIN_DOMAIN"//hgrid//"_multiple" +!! "MET_LIS_CRO_2D_SANTEE_LU_1KM."//& +!! ".156hrfcst.radar" +! else +! endif +! CALL READFORC_HRLDAS_mult(inflnm,IX,JX,OLDDATE,T2,Q2X,U, & +! PRES,XLONG,SHORT,PRCP1,K) +! +!! IF (K.GT.0.AND.K.LT.10) THEN +!! PRCP1 = 10.0/3600.0 ! units mm/s +!! PRCP1 = 0.254/3600.0 +!! ELSE +!! PRCP1 = 0. +!! END IF +! endif + + + +!!!!!DJG NARR Met. w/ NARR Precip. Forcing Data... +!! Assumes standard 3-hrly NARR data has been resampled to NDHMS grid... +!! Assumes one 3hrly time-step per forcing data file +!! Input precip units here are in 'mm' accumulated over 3 hrs... +! if(FORC_TYP.eq.7) then !NARR Met. w/ NARR Precip. +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +! PRCP1=PRCP1/(3.0*3600.0) ! convert from 3hr accum to mm/s which is what NDHMS expects +! end if !NARR Met. w/ NARR Precip. + + + + + + +!!!!DJG NARR Met. w/ Specified Precip. Forcing Data... +! if(FORC_TYP.eq.8) then !NARR Met. w/ Specified Precip. +! +!!Check to make sure if Noah time step is 3 hrs as is NARR... +! +! PRCP_old = PRCP1 +! +! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid +!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& +!! ".48hrfcst.ncf" +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +!! PRCP1=PRCP1/(3.0*3600.0) !NARR 3hrly precip product in mm +! PRCP1=PRCP1 !NAM model data in mm/s +! end if !3 hr check +! +! +!!Get spec. precip.... +!! NAM Remote sensing... +!!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!! product = "trmm" +!! inflnm = trim(indir)//"/"//"sat_domain1.nc" +!!! inflnm = trim(indir)//"/"//"sat_domain2.nc" +!! PRCP1 = 0. +!! CALL READFORC_NAMPCP(inflnm,IX,JX, & +!! PRCP2,K,product) +!! ierr_flg = 0 +!! mmflag = 0 +!!!Convert pcp grid to units of mm/s... +!! PRCP1=PRCP1/(3.0*3600.0) !3hrly precip product +! +!!Read from filelist (NAME HE...,others)... +!! if (K.eq.1) then +!! open(unit=93,file="filelist.txt",form="formatted",status="old") +!! end if +!! read (93,*) filename +!! inflnm = trim(indir)//"/"//trim(filename) +!! +!! +!!Front Range MDV Radar... +! +!! inflnm = "/ptmp/weiyu/rt_2008/radar_obs/"//& +!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!! olddate(15:16)//"_radar.nc" +!! olddate(15:16)//"_chill.nc" +! +!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/Big_Thomp_04/"//& +!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& +!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!! olddate(15:16)//"00_Pcp60min.nc" +!! olddate(15:16)//"00_Pcp30min.nc" +!! olddate(15:16)//"00_30min.nc" +! olddate(15:16)//"00_Pcp5min.nc" +!! olddate(15:16)//"_chill.nc" +! +!! inflnm = "/d2/hydrolab/HRLDAS/forcing/COWS/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(15:16)//"00_Pcp5min.nc" +!! olddate(15:16)//"00_5.nc" +! +!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step +!! +! +! +!! if (K.le.6) then ! use for 30min nowcast... +!! if (K.eq.1) then +!! open(unit=94,file="start_file.txt",form="formatted",status="replace") +!!! inflnm2 = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& +!! inflnm2 = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(15:16)//"00_" +!! close(94) +!! nwxst_t = "5"! calc minutes from timestep and convert to char... +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.2) then +!! nwxst_t = "10" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm2 +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.3) then +!! nwxst_t = "15" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.4) then +!! nwxst_t = "20" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.5) then +!! nwxst_t = "25" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.6) then +!! nwxst_t = "30" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! else +!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step +!! end if +! +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(15:16)//"00_Pcp30minMerge.nc" +! +! CALL READFORC_MDV(inflnm,IX,JX, & +! PRCP2,mmflag,ierr_flg) +! +!!If radar or spec. data is ok use if not, skip to original NARR data... +! IF (ierr_flg.eq.0) then ! use spec. precip +! PRCP1=PRCP2 !assumes PRCP2 is in mm/s +!!Convert units if necessary +! IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... +! PRCP1=PRCP2/DT !convert from mm to mm/s +! END IF ! Endif mmflag +! ELSE ! either stop or default to original forcing data... +! PRCP1 = PRCP_old +! END IF ! Endif ierr_flg +! +!! Loop through data to screen for plausible values +! do i=1,ix +! do j=1,jx +! if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 +! if (PRCP1(i,j).gt.0.0555) PRCP1(i,j)=0.0555 !set max pcp intens = 200 mm/h +!! PRCP1(i,j) = 0. +!! PRCP1(i,j) = 0.02 !override w/ const. precip for gw testing only... +! end do +! end do +! +!! if (K.eq.1) then ! quick dump for site specific precip... +! open(unit=94,file="Christman_accumpcp.txt",form="formatted",status="new") +! end if +! +! +! end if !NARR Met. w/ Specified Precip. + + + + + +!!!!DJG NLDAS Met. w/ NLDAS Precip. Forcing Data... +!! Assumes standard hrly NLDAS data has been resampled to NDHMS grid... +!! Assumes one 1-hrly time-step per forcing data file +!! Input precip units here are in 'mm' accumulated over 1 hr... +! if(FORC_TYP.eq.9) then !NLDAS Met. w/ NLDAS Precip. +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!!Use this for minute forcing... olddate(15:16)//".LDASIN_DOMAIN"//hgrid +! ".LDASIN_DOMAIN"//hgrid +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +! PRCP1=PRCP1/(1.0*3600.0) ! convert hourly NLDAS hourly accum pcp to mm/s which is what NDHMS expects +! end if !NLDAS Met. w/ NLDAS Precip. + + + + + +!!!!DJG NARR Met. w/ DMIP Precip. & Temp. Forcing Data... +! if(FORC_TYP.eq.10) then ! If/Then for DMIP forcing data... +!!Check to make sure if Noah time step is 3 hrs as is NARR... +! +! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid +!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& +!! ".48hrfcst.ncf" +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +! PRCP1=PRCP1/(3.0*3600.0) ! convert to mm/s which is what HRLDAS expects +! end if !3 hr check +! +!!Get DMIP Precip... +!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/PRECIP_HRAP/precip_finished"//"/"//& +! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/PRECIP_HRAP"//"/"//& +! "proj.xmrg"//& +! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& +! "z.asc" +! PRCP1 = 0. +! CALL READFORC_DMIP(inflnm,IX,JX,PRCP1) +! PRCP1 = PRCP1 / 100.0 ! Convert from native hundreths of mm to mm +!! IF (K.LT.34) THEN +!! PRCP1 = 5.0/3600.0 ! units mm/s +!!! ELSE +!!! PRCP1 = 0. +!! END IF +! +!!Get DMIP Temp... +!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/TEMP_HRAP/tair_finished"//"/"//& +! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/TEMP_HRAP"//"/"//& +! "proj.tair"//& +! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& +! "z.asc" +! CALL READFORC_DMIP(inflnm,IX,JX,T2) +! T2 = (5./9.)*(T2-32.0) + 273.15 !Convert from deg F to deg K +! +! end if !End if for DMIP forcing data... +! +! +! +!! : add reading forcing precipitation data +!! ywinflnm = "/ptmp/weiyu/hrldas/v2/st4"//"/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!! ".LDASIN_DOMAIN2" +!! call read_stage4(ywinflnm,IX,JX,PRCP1) +!!end yw +! +! +!!!!DJG Check for snow data assimilation... + + if (SNOW_ASSIM .eq. 1) then + +! Every 24 hours, update the snow field from analyses. + if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then + if ( OLDDATE(12:13) == "00") then + CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) + endif + else + CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) + endif + + end if + +#ifdef PRECIP_DOUBLE +#ifdef HYDRO_D + print*,'PRECIP DOUBLE' +#endif + PRCP1 = PRCP1 * 2.0 +#endif + + end subroutine read_hydro_forcing_seq + + +#ifdef MPP_LAND + subroutine mpp_readland_hrldas(geo_static_flnm,& + ix,jx,land_cat,soil_cat,& + vegtyp,soltyp,terrain,latitude,longitude,& + global_nx,global_ny,SOLVEG_INITSWC) + implicit none + character(len=*), intent(in) :: geo_static_flnm + integer, intent(in) :: ix, jx, land_cat, soil_cat, & + global_nx,global_ny,SOLVEG_INITSWC + integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp + real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude + real, dimension(global_nx,global_ny) ::g_terrain, g_latitude, g_longitude + integer, dimension(global_nx,global_ny) :: g_vegtyp, g_soltyp + + character(len=256) :: units + integer :: ierr + integer :: ncid,varid + real, dimension(ix,jx) :: xdum + integer flag ! flag = 1 from wrfsi, flag =2 from WPS. + if(my_id.eq.IO_id) then + CALL READLAND_HRLDAS(geo_static_flnm,global_nx, & + global_ny,LAND_CAT,SOIL_CAT, & + g_VEGTYP,g_SOLTYP,g_TERRAIN,g_LATITUDE,g_LONGITUDE, SOLVEG_INITSWC) + end if + ! distribute the data to computation node. + call mpp_land_bcast_int1(LAND_CAT) + call mpp_land_bcast_int1(SOIL_CAT) + call decompose_data_int(g_VEGTYP,VEGTYP) + call decompose_data_int(g_SOLTYP,SOLTYP) + call decompose_data_real(g_TERRAIN,TERRAIN) + call decompose_data_real(g_LATITUDE,LATITUDE) + call decompose_data_real(g_LONGITUDE,LONGITUDE) + return + end subroutine mpp_readland_hrldas + + + subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,& + global_nX, global_ny) + implicit none + + character(len=*), intent(in) :: flnm,OLDDATE + integer, intent(in) :: ix, global_nx,global_ny + integer, intent(in) :: jx + real, dimension(ix,jx), intent(out) :: weasd + real, dimension(ix,jx), intent(out) :: snodep + + real,dimension(global_nX, global_ny):: g_weasd, g_snodep + + character(len=256) :: units + integer :: ierr + integer :: ncid,i,j + + if(my_id .eq. IO_id) then + CALL READSNOW_FORC(trim(flnm),global_nX, global_ny,g_WEASD,g_SNODEP) + endif + call decompose_data_real(g_WEASD,WEASD) + call decompose_data_real(g_SNODEP,SNODEP) + + return + end subroutine MPP_READSNOW_FORC + + subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& + global_nX, global_ny,nsoil,out_SMC,out_SH2OX) + implicit none + + integer, intent(in) :: ix,global_nx,global_ny + integer, intent(in) :: jx,nsoil + real, dimension(ix,jx), intent(in) :: in_smcmax + real, dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox + + real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox + real,dimension(global_nX, global_ny):: g_smcmax + integer :: i,j,k + + + call write_IO_real(in_smcmax,g_smcmax) ! get global grid of smcmax + +#ifdef HYDRO_D + write (*,*) "In deep GW...", nsoil +#endif + +!loop to overwrite soils to saturation... + do i=1,global_nx + do j=1,global_ny + g_smc(i,j,1:NSOIL) = g_smcmax(i,j) + g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j) + end do + end do + +!decompose global grid to parallel tiles... + do k=1,nsoil + call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k)) + call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) + end do + + return + end subroutine MPP_DEEPGW_HRLDAS + + + subroutine read_hydro_forcing_mpp( & + indir,olddate,hgrid, & + ix,jx,forc_typ,snow_assim, & + T2,q2x,u,v,pres,xlong,short,prcp1,& + lai,fpar,snodep,dt,k,prcp_old) +! This subrouting is going to read different forcing. + + + implicit none + ! in variable + character(len=*) :: olddate,hgrid,indir + character(len=256) :: filename + integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& + prcpnew,lai,fpar,snodep,prcp_old + real :: dt + ! tmp variable + character(len=256) :: inflnm, product + integer :: i,j,mmflag + real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & + g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar + integer flag + + + + call write_io_real(T2,g_T2) + call write_io_real(Q2X,g_Q2X) + call write_io_real(U,g_U) + call write_io_real(V,g_V) + call write_io_real(XLONG,g_XLONG) + call write_io_real(SHORT,g_SHORT) + call write_io_real(PRCP1,g_PRCP1) + call write_io_real(PRES,g_PRES) + call write_io_real(prcp_old,g_PRCP_old) + + call write_io_real(lai,g_lai) + call write_io_real(fpar,g_fpar) + call write_io_real(snodep,g_snodep) + + + + if(my_id .eq. IO_id) then + call read_hydro_forcing_seq( & + indir,olddate,hgrid,& + global_nx,global_ny,forc_typ,snow_assim, & + g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,& + g_lai,g_fpar,g_snodep,dt,k,g_prcp_old) +#ifdef HYDRO_D + write(6,*) "finish read forcing,olddate ",olddate +#endif + end if + + call decompose_data_real(g_T2,T2) + call decompose_data_real(g_Q2X,Q2X) + call decompose_data_real(g_U,U) + call decompose_data_real(g_V,V) + call decompose_data_real(g_XLONG,XLONG) + call decompose_data_real(g_SHORT,SHORT) + call decompose_data_real(g_PRCP1,PRCP1) + call decompose_data_real(g_prcp_old,prcp_old) + call decompose_data_real(g_PRES,PRES) + + call decompose_data_real(g_lai,lai) + call decompose_data_real(g_fpar,fpar) + call decompose_data_real(g_snodep,snodep) + + return + end subroutine read_hydro_forcing_mpp +#endif + + integer function nfeb_yw(year) + ! + ! Compute the number of days in February for the given year. + ! + implicit none + integer, intent(in) :: year ! Four-digit year + + nfeb_yw = 28 ! By default, February has 28 days ... + if (mod(year,4).eq.0) then + nfeb_yw = 29 ! But every four years, it has 29 days ... + if (mod(year,100).eq.0) then + nfeb_yw = 28 ! Except every 100 years, when it has 28 days ... + if (mod(year,400).eq.0) then + nfeb_yw = 29 ! Except every 400 years, when it has 29 days ... + if (mod(year,3600).eq.0) then + nfeb_yw = 28 ! Except every 3600 years, when it has 28 days. + endif + endif + endif + endif + end function nfeb_yw + + subroutine geth_newdate (ndate, odate, idt) + implicit none + + ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and + ! delta-time, compute the new date. + + ! on entry - odate - the old hdate. + ! idt - the change in time + + ! on exit - ndate - the new hdate. + + integer, intent(in) :: idt + character (len=*), intent(out) :: ndate + character (len=*), intent(in) :: odate + + ! Local Variables + + ! yrold - indicates the year associated with "odate" + ! moold - indicates the month associated with "odate" + ! dyold - indicates the day associated with "odate" + ! hrold - indicates the hour associated with "odate" + ! miold - indicates the minute associated with "odate" + ! scold - indicates the second associated with "odate" + + ! yrnew - indicates the year associated with "ndate" + ! monew - indicates the month associated with "ndate" + ! dynew - indicates the day associated with "ndate" + ! hrnew - indicates the hour associated with "ndate" + ! minew - indicates the minute associated with "ndate" + ! scnew - indicates the second associated with "ndate" + + ! mday - a list assigning the number of days in each month + + ! i - loop counter + ! nday - the integer number of days represented by "idt" + ! nhour - the integer number of hours in "idt" after taking out + ! all the whole days + ! nmin - the integer number of minutes in "idt" after taking out + ! all the whole days and whole hours. + ! nsec - the integer number of minutes in "idt" after taking out + ! all the whole days, whole hours, and whole minutes. + + integer :: newlen, oldlen + integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + integer :: yrold, moold, dyold, hrold, miold, scold, frold + integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc + logical :: opass + character (len=10) :: hfrc + character (len=1) :: sp + logical :: punct + integer :: yrstart, yrend, mostart, moend, dystart, dyend + integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart + integer :: units + integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) +!yw integer nfeb_yw + + ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." + if (odate(5:5) == "-") then + punct = .TRUE. + else + punct = .FALSE. + endif + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + oldlen = LEN(odate) + if (punct) then + yrstart = 1 + yrend = 4 + mostart = 6 + moend = 7 + dystart = 9 + dyend = 10 + hrstart = 12 + hrend = 13 + mistart = 15 + miend = 16 + scstart = 18 + scend = 19 + frstart = 21 + select case (oldlen) + case (10) + ! Days + units = 1 + case (13) + ! Hours + units = 2 + case (16) + ! Minutes + units = 3 + case (19) + ! Seconds + units = 4 + case (21) + ! Tenths + units = 5 + case (22) + ! Hundredths + units = 6 + case (23) + ! Thousandths + units = 7 + case (24) + ! Ten thousandths + units = 8 + case default + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("In geth_newdate() - error odd length") + end select + + if (oldlen.ge.11) then + sp = odate(11:11) + else + sp = ' ' + end if + + else + + yrstart = 1 + yrend = 4 + mostart = 5 + moend = 6 + dystart = 7 + dyend = 8 + hrstart = 9 + hrend = 10 + mistart = 11 + miend = 12 + scstart = 13 + scend = 14 + frstart = 15 + + select case (oldlen) + case (8) + ! Days + units = 1 + case (10) + ! Hours + units = 2 + case (12) + ! Minutes + units = 3 + case (14) + ! Seconds + units = 4 + case (15) + ! Tenths + units = 5 + case (16) + ! Hundredths + units = 6 + case (17) + ! Thousandths + units = 7 + case (18) + ! Ten thousandths + units = 8 + case default + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("In geth_newdate() - error odd length") + end select + endif + + ! Use internal READ statements to convert the CHARACTER string + ! date into INTEGER components. + + read(odate(yrstart:yrend), '(i4)') yrold + read(odate(mostart:moend), '(i2)') moold + read(odate(dystart:dyend), '(i2)') dyold + if (units.ge.2) then + read(odate(hrstart:hrend),'(i2)') hrold + if (units.ge.3) then + read(odate(mistart:miend),'(i2)') miold + if (units.ge.4) then + read(odate(scstart:scend),'(i2)') scold + if (units.ge.5) then + read(odate(frstart:oldlen),*) frold + end if + end if + end if + end if + + ! Set the number of days in February for that year. + + mday(2) = nfeb_yw(yrold) + + ! Check that ODATE makes sense. + + opass = .TRUE. + + ! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold +#endif + opass = .FALSE. + end if + + ! Check that the day of ODATE makes sense. + + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold +#endif + opass = .FALSE. + end if + + ! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold +#endif + opass = .FALSE. + end if + + ! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold +#endif + opass = .FALSE. + end if + + ! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold +#endif + opass = .FALSE. + end if + + ! Check that the fractional part of ODATE makes sense. + if (.not.opass) then + write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen + call hydro_stop("In geth_newdate") + end if + + ! Date Checks are completed. Continue. + + + ! Compute the number of days, hours, minutes, and seconds in idt + + if (units.ge.5) then !idt should be in fractions of seconds + ifrc = oldlen-(frstart)+1 + ifrc = 10**ifrc + nday = abs(idt)/(86400*ifrc) + nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) + nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) + nsec = mod(abs(idt),60*ifrc)/(ifrc) + nfrac = mod(abs(idt), ifrc) + else if (units.eq.4) then !idt should be in seconds + ifrc = 1 + nday = abs(idt)/86400 ! integer number of days in delta-time + nhour = mod(abs(idt),86400)/3600 + nmin = mod(abs(idt),3600)/60 + nsec = mod(abs(idt),60) + nfrac = 0 + else if (units.eq.3) then !idt should be in minutes + ifrc = 1 + nday = abs(idt)/1440 ! integer number of days in delta-time + nhour = mod(abs(idt),1440)/60 + nmin = mod(abs(idt),60) + nsec = 0 + nfrac = 0 + else if (units.eq.2) then !idt should be in hours + ifrc = 1 + nday = abs(idt)/24 ! integer number of days in delta-time + nhour = mod(abs(idt),24) + nmin = 0 + nsec = 0 + nfrac = 0 + else if (units.eq.1) then !idt should be in days + ifrc = 1 + nday = abs(idt) ! integer number of days in delta-time + nhour = 0 + nmin = 0 + nsec = 0 + nfrac = 0 + else + write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & + oldlen + write(*,*) '#'//odate(1:oldlen)//'#' + call hydro_stop("In geth_newdate") + end if + + if (idt.ge.0) then + + frnew = frold + nfrac + if (frnew.ge.ifrc) then + frnew = frnew - ifrc + nsec = nsec + 1 + end if + + scnew = scold + nsec + if (scnew .ge. 60) then + scnew = scnew - 60 + nmin = nmin + 1 + end if + + minew = miold + nmin + if (minew .ge. 60) then + minew = minew - 60 + nhour = nhour + 1 + end if + + hrnew = hrold + nhour + if (hrnew .ge. 24) then + hrnew = hrnew - 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew + 1 + if (dynew.gt.mday(monew)) then + dynew = dynew - mday(monew) + monew = monew + 1 + if (monew .gt. 12) then + monew = 1 + yrnew = yrnew + 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb_yw(yrnew) + end if + end if + end do + + else if (idt.lt.0) then + + frnew = frold - nfrac + if (frnew .lt. 0) then + frnew = frnew + ifrc + nsec = nsec + 1 + end if + + scnew = scold - nsec + if (scnew .lt. 00) then + scnew = scnew + 60 + nmin = nmin + 1 + end if + + minew = miold - nmin + if (minew .lt. 00) then + minew = minew + 60 + nhour = nhour + 1 + end if + + hrnew = hrold - nhour + if (hrnew .lt. 00) then + hrnew = hrnew + 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew - 1 + if (dynew.eq.0) then + monew = monew - 1 + if (monew.eq.0) then + monew = 12 + yrnew = yrnew - 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb_yw(yrnew) + end if + dynew = mday(monew) + end if + end do + end if + + ! Now construct the new mdate + + newlen = LEN(ndate) + + if (punct) then + + if (newlen.gt.frstart) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew +19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) + + else if (newlen.eq.miend) then + write(ndate,16) yrnew, monew, dynew, hrnew, minew +16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) + + else if (newlen.eq.hrend) then + write(ndate,13) yrnew, monew, dynew, hrnew +13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) + + else if (newlen.eq.dyend) then + write(ndate,10) yrnew, monew, dynew +10 format(i4,'-',i2.2,'-',i2.2) + + end if + + else + + if (newlen.gt.frstart) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew +119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.miend) then + write(ndate,116) yrnew, monew, dynew, hrnew, minew +116 format(i4,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.hrend) then + write(ndate,113) yrnew, monew, dynew, hrnew +113 format(i4,i2.2,i2.2,i2.2) + + else if (newlen.eq.dyend) then + write(ndate,110) yrnew, monew, dynew +110 format(i4,i2.2,i2.2) + + end if + + endif + + if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp + + end subroutine geth_newdate + + + subroutine read_hydro_forcing_mpp1( & + indir,olddate,hgrid, & + ix,jx,forc_typ,snow_assim, & + T2,q2x,u,v,pres,xlong,short,prcp1,& + lai,fpar,snodep,dt,k,prcp_old) +! This subrouting is going to read different forcing. + implicit none + ! in variable + character(len=*) :: olddate,hgrid,indir + character(len=256) :: filename + integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& + prcpnew,weasd,snodep,prcp0,prcp2,prcp_old + real :: dt, wrf_dt + ! tmp variable + character(len=256) :: inflnm, inflnm2, product + integer :: i,j,mmflag,ierr_flg + real,dimension(ix,jx):: lai,fpar + character(len=4) nwxst_t + logical :: fexist + + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASIN_DOMAIN"//hgrid + +!!!DJG... Call READFORC_(variable) Subroutine for forcing data... +!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) + if(FORC_TYP.eq.1) then +!!Create forcing data filename... + call geth_newdate(out_date,olddate,nint(dt)) + inflnm = trim(indir)//"/"//& + out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//& + ".LDASIN_DOMAIN"//hgrid + + inquire (file=trim(inflnm), exist=fexist) + +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif + if ( .not. fexist ) then + print*, "no forcing data found", inflnm + call hydro_stop("In read_hydro_forcing_mpp1() - no forcing data found") + endif + +#ifdef HYDRO_D + print*, "read forcing data at ", OLDDATE, trim(inflnm) +#endif + CALL READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + + where(PRCP1 .lt. 0) PRCP1= 0 ! set minimum to be 0 + where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h + + end if + + + + +!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!) + if(FORC_TYP.eq.2) then +!!Create forcing data filename... + call geth_newdate(out_date,olddate,nint(dt)) + inflnm = trim(indir)//"/"//& + out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//& + out_date(15:16)//".LDASIN_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif + if ( .not. fexist ) then + print*, "no forcing data found", inflnm + call hydro_stop("In read_hydro_forcing_mpp1() - no forcing data found") + endif + CALL READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + + where(PRCP1 .lt. 0) PRCP1= 0 ! set minimum to be 0 + where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h + end if + + + + + +!!!DJG WRF Output File Direct Ingest Forcing... + if(FORC_TYP.eq.3) then +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& + "_"//olddate(12:13)//":00:00" + + inquire (file=trim(inflnm), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif + if ( .not. fexist ) then + print*, "no forcing data found", inflnm + call hydro_stop("read_hydro_forcing_seq") + endif + + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif + if (fexist ) goto 991 + end do +991 continue + + if(.not. fexist) then + write(6,*) "Error: could not find file ",trim(inflnm2) + call hydro_stop("In read_hydro_forcing_mpp1() - could not find WRF forcing file") + endif +#ifdef HYDRO_D + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + + + CALL READFORC_WRF_mpp(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) + + end if + + + + + +!!!DJG CONSTant, idealized forcing... + if(FORC_TYP.eq.4) then +! Impose a fixed diurnal cycle... +! assumes model timestep is 1 hr +! assumes K=1 is 12z (Ks or ~ sunrise) +! First Precip... +! IF (K.GE.1 .and. K.LE.2) THEN + IF (K.EQ.1) THEN + PRCP1 =25.4/3600.0 !units mm/s (Simulates 1"/hr for first time step...) + ELSEIF (K.GT.1) THEN + PRCP1 = 0. + END IF +! Other Met. Vars... + T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + Q2X = 0.01 + U = 1.0 + V = 1.0 + PRES = 100000.0 + XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + end if + + + + + +!!!DJG Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr') +! This option uses hard-wired met forcing EXCEPT precipitation which is read in +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' +! + if(FORC_TYP.eq.5) then +! Standard Met. Vars... + T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + Q2X = 0.01 + U = 1.0 + V = 1.0 + PRES = 100000.0 + XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +! product = "trmm" +! inflnm = trim(indir)//"/"//"sat_domain1.nc" +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif + if ( .not. fexist ) then + print*, "no specified precipitation data found", inflnm + call hydro_stop("In read_hydro_forcing_mpp1() - no specified precipitation data found") + endif + + PRCP1 = 0. + PRCP_old = PRCP1 + +#ifdef HYDRO_D + print *, "Opening supplemental precipitation forcing file...",inflnm +#endif + CALL READFORC_MDV_mpp(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) + +!If radar or spec. data is ok use if not, skip to original NARR data... + IF (ierr_flg.eq.0) then ! use spec. precip +!Convert units if necessary + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + PRCP1=PRCP2/DT !convert from mm to mm/s +#ifdef HYDRO_D + print*, "Supplemental pcp is accumulated pcp/dt. " +#endif + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s +#ifdef HYDRO_D + print*, "Supplemental pcp is rate. " +#endif + END IF ! Endif mmflag + ELSE ! either stop or default to original forcing data... +#ifdef HYDRO_D + print *,"Current RADAR precip data not found !!! Using previous available file..." +#endif + PRCP1 = PRCP_old + END IF ! Endif ierr_flg + +! Loop through data to screen for plausible values + do i=1,ix + do j=1,jx + if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j) + if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h + end do + end do + + end if + + + + + +!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing... +! This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' + + if(FORC_TYP.eq.6) then + +!!Create forcing data filename... + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + do i_forcing = 1, nint(3600*12/dt) + call geth_newdate(out_date,olddate,nint(dt*i_forcing)) + inflnm = trim(indir)//"/"//& + out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//& + ".LDASIN_DOMAIN"//hgrid + + inquire (file=trim(inflnm), exist=fexist) + if(fexist) goto 101 + enddo +101 continue +#ifdef MPP_LAND + endif + call mpp_land_bcast_logical(fexist) +#endif + + if ( .not. fexist ) then +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + do i_forcing = 1, nint(3600*12/dt) + call geth_newdate(out_date,olddate,nint(dt*i_forcing)) + inflnm = trim(indir)//"/"//& + out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//& + out_date(15:16)//".LDASIN_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + if(fexist) goto 102 + end do +102 continue +#ifdef MPP_LAND + endif + call mpp_land_bcast_logical(fexist) +#endif + endif + + + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no ATM forcing data found at this time", inflnm +#endif + else +#ifdef HYDRO_D + print*, "reading forcing data at this time", inflnm +#endif + + CALL READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... + endif + + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!!Create forcing data filename... + call geth_newdate(out_date,olddate,nint(dt)) + inflnm = trim(indir)//"/"//& + out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//& + out_date(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif +#ifdef HYDRO_D + if(my_id .eq. io_id) then + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) + endif + endif +#endif + if ( .not. fexist ) then + prcp1 = PRCP_old ! for missing pcp data use analysis/model input + else + CALL READFORC_MDV_mpp(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) +!If radar or spec. data is ok use if not, skip to original NARR data... + if(ierr_flg .ne. 0) then +#ifdef HYDRO_D + print*, "WARNING: pcp reading problem: ", trim(inflnm) +#endif + PRCP1=PRCP_old + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + PRCP1=PRCP2/DT !convert from mm to mm/s + END IF ! Endif mmflag +#ifdef HYDRO_D + if(my_id .eq. io_id) then + print*, "replace pcp successfully! ",trim(inflnm) + endif +#endif + endif + endif + + +! Loop through data to screen for plausible values + where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old + do i=1,ix + do j=1,jx + if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 + if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h + end do + end do +! write(80,*) prcp1 + + end if + + +!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing. + + if(FORC_TYP.eq.7) then + +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& + "_"//olddate(12:13)//":00:00" + + inquire (file=trim(inflnm), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif + + + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no forcing data found", inflnm +#endif + else + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif + if (fexist ) goto 992 + end do +992 continue + +#ifdef HYDRO_D + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + CALL READFORC_WRF_mpp(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) + PRCP_old = PRCP1 + endif + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef MPP_LAND + call mpp_land_bcast_logical(fexist) +#endif +#ifdef HYDRO_D + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) + endif +#endif + if ( .not. fexist ) then + prcp1 = PRCP_old ! for missing pcp data use analysis/model input + else + CALL READFORC_MDV_mpp(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) +!If radar or spec. data is ok use if not, skip to original NARR data... + if(ierr_flg .ne. 0) then +#ifdef HYDRO_D + print*, "WARNING: pcp reading problem: ", trim(inflnm) +#endif + PRCP1=PRCP_old + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + write(6,*) "using supplemental pcp time interval ", DT + PRCP1=PRCP2/DT !convert from mm to mm/s + else + write(6,*) "using supplemental pcp rates " + END IF ! Endif mmflag +#ifdef HYDRO_D + print*, "replace pcp successfully! ",trim(inflnm) +#endif + endif + endif + + +! Loop through data to screen for plausible values + where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h + where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h + end if + +!!!!DJG Check for snow data assimilation... + + if (SNOW_ASSIM .eq. 1) then + +! Every 24 hours, update the snow field from analyses. + if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then + if ( OLDDATE(12:13) == "00") then + CALL READSNOW_FORC_mpp(inflnm,IX,JX,WEASD,SNODEP) + endif + else + CALL READSNOW_FORC_mpp(inflnm,IX,JX,WEASD,SNODEP) + endif + + end if + +#ifdef PRECIP_DOUBLE +#ifdef HYDRO_D + print*,'PRECIP DOUBLE' +#endif + PRCP1 = PRCP1 * 2.0 +#endif + + end subroutine read_hydro_forcing_mpp1 + + subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx), intent(out) :: t + real, dimension(ix,jx), intent(out) :: q + real, dimension(ix,jx), intent(out) :: u + real, dimension(ix,jx), intent(out) :: v + real, dimension(ix,jx), intent(out) :: p + real, dimension(ix,jx), intent(out) :: lw + real, dimension(ix,jx), intent(out) :: sw + real, dimension(ix,jx), intent(out) :: pcp + real, dimension(ix,jx), intent(inout) :: lai + real, dimension(ix,jx), intent(inout) :: fpar + + character(len=256) :: units + integer :: ierr + integer :: ncid + + ! Open the NetCDF file. +#ifdef MPP_LAND + real, allocatable, dimension(:,:):: buf2 + if(my_id .eq. io_id) then + allocate(buf2(global_nx,global_ny)) + else + allocate(buf2(1,1)) + endif + if(my_id .eq. io_id) then + ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) + endif + call mpp_land_bcast_int1(ierr) + if (ierr /= 0) then + write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READFORC_HRLDAS_mpp() - Problem opening netcdf file") + endif + + if(my_id .eq. io_id ) call get_2d_netcdf("T2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,t) + if(my_id .eq. io_id ) call get_2d_netcdf("Q2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,q) + if(my_id .eq. io_id ) call get_2d_netcdf("U2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,u) + if(my_id .eq. io_id ) call get_2d_netcdf("V2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,v) + if(my_id .eq. io_id ) call get_2d_netcdf("PSFC", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,p) + if(my_id .eq. io_id ) call get_2d_netcdf("LWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,lw) + if(my_id .eq. io_id ) call get_2d_netcdf("SWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,sw) + if(my_id .eq. io_id ) call get_2d_netcdf("RAINRATE", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + call decompose_data_real (buf2,pcp) + if(my_id .eq. io_id ) then + call get_2d_netcdf("VEGFRA", ncid,buf2, units, global_nx, global_ny, .FALSE., 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) + if(my_id .eq. io_id ) call get_2d_netcdf("LAI", ncid, buf2, units, ix, jx, .FALSE., ierr) + call mpp_land_bcast_int1(ierr) + if(ierr == 0) call decompose_data_real (buf2,lai) + + deallocate(buf2) +#else + ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("READFORC_HRLDAS") + endif + call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) + + if (ierr == 0) then + if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 + endif + call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) +#endif + + ierr = nf_close(ncid) + + end subroutine READFORC_HRLDAS_mpp + + subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) + + implicit none + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar + integer tlevel + + character(len=256) :: units + integer :: ierr + integer :: ncid +#ifdef MPP_LAND + real, allocatable, dimension(:,:) :: buf2 +#endif + + tlevel = 1 + + pcpc = 0 + +#ifdef MPP_LAND + if(my_id .eq. io_id) then + allocate(buf2(global_nx, global_ny) ) + else + allocate(buf2(1, 1) ) + endif + + ! Open the NetCDF file. + + if(my_id .eq. io_id) ierr = nf_open(flnm, NF_NOWRITE, ncid) + call mpp_land_bcast_int1(ierr) + if (ierr /= 0) then + write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file") + endif + if(my_id .eq. io_id) call get_2d_netcdf_ruc("T2", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,t) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("Q2", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,q) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("U10", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,u) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("V10", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,v) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("PSFC", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,p) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("GLW", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,lw) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("SWDOWN", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,sw) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("RAINC", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,pcpc) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("RAINNC", ncid, buf2, global_nx, global_ny,tlevel, .true., ierr) + call decompose_data_real (buf2,pcp) + if(my_id .eq. io_id) call get_2d_netcdf_ruc("LAI", ncid, buf2, global_nx, global_ny,tlevel, .false., ierr) + 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. + endif + call mpp_land_bcast_int1(ierr) + if(ierr == 0) call decompose_data_real (buf2,fpar) + deallocate(buf2) +#else + + ! Open the NetCDF file. + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then + write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file") + endif + call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) + 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. + endif + call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .false., ierr) + +#endif + + + pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... + ierr = nf_close(ncid) + + + end subroutine READFORC_WRF_mpp + + subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + integer, intent(out) :: ierr_flg + integer :: it,jew,zsn + real, dimension(ix,jx), intent(out) :: pcp + + character(len=256) :: units + integer :: ierr,i,j,i2,j2,varid + integer :: ncid,mmflag + real, dimension(ix,jx) :: temp +#ifdef MPP_LAND + real, allocatable, dimension(:,:) :: buf2 + if(my_id .eq. io_id) then + allocate(buf2(global_nx, global_ny)) + else + allocate(buf2(1,1)) + endif +#endif + + mmflag = 0 ! flag for units spec. (0=mm, 1=mm/s) + + +!open NetCDF file... +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(ierr_flg) +#endif + if (ierr_flg /= 0) then + write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') & + trim(flnm) +#ifdef MPP_LAND + deallocate(buf2) +#endif + return + end if + +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + ierr = nf_inq_varid(ncid, "precip", varid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(ierr) +#endif + if(ierr /= 0) ierr_flg = ierr + if (ierr /= 0) then +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + ierr = nf_inq_varid(ncid, "precip_rate", 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) +#endif + return + end if + ierr_flg = ierr + mmflag = 1 + end if +#ifdef MPP_LAND + if(my_id .eq. io_id) then + ierr = nf_get_var_real(ncid, varid, buf2) + endif + call mpp_land_bcast_int1(ierr) + if(ierr ==0) call decompose_data_real (buf2,pcp) + deallocate(buf2) +#else + ierr = nf_get_var_real(ncid, varid, pcp) +#endif + if (ierr /= 0) then + write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) + end if + ierr = nf_close(ncid) + + end subroutine READFORC_MDV_mpp + + subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + real, dimension(ix,jx), intent(out) :: weasd + real, dimension(ix,jx), intent(out) :: snodep + real, dimension(ix,jx) :: tmp + + character(len=256) :: units + integer :: ierr + integer :: ncid,i,j +#ifdef MPP_LAND + real, allocatable, dimension(:,:) :: buf2 + if(my_id .eq. io_id) then + allocate(buf2(global_nx, global_ny)) + else + allocate(buf2(1,1)) + endif +#endif + + ! Open the NetCDF file. +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + ierr = nf_open(flnm, NF_NOWRITE, ncid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(ierr) +#endif + if (ierr /= 0) then + write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) + call hydro_stop("In READSNOW_FORC_mpp() - Problem opening netcdf file") + endif + +#ifdef MPP_LAND + if(my_id .eq. io_id) then + call get_2d_netcdf("WEASD", ncid, buf2, units, ix, jx, .FALSE., ierr) + endif + call mpp_land_bcast_int1(ierr) + if(ierr == 0) call decompose_data_real (buf2,tmp) +#else + call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) +#endif + if (ierr /= 0) then + call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + units = "mm" +#ifdef HYDRO_D + print *, "read WEASD from wrfoutput ...... " +#endif + weasd = tmp * 1.E-3 + endif + else + weasd = tmp + if (trim(units) == "m") then + ! No conversion necessary + else if (trim(units) == "mm") then + ! convert WEASD from mm to m + weasd = weasd * 1.E-3 + endif + endif + + if (ierr /= 0) then + print *, "!!!!! NO WEASD present in input file...initialize to 0." + endif +#ifdef MPP_LAND + if(my_id .eq. io_id) then + call get_2d_netcdf("SNODEP", ncid, buf2, units, ix, jx, .FALSE., ierr) + endif + call mpp_land_bcast_int1(ierr) + if(ierr == 0) call decompose_data_real (buf2,tmp) +#else + call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) +#endif + if (ierr /= 0) then + ! Quick assumption regarding snow depth. + +#ifdef MPP_LAND + if(my_id .eq. io_id) then + call get_2d_netcdf("SNOWH", ncid, buf2, units, ix, jx, .FALSE., ierr) + endif + call mpp_land_bcast_int1(ierr) + if(ierr == 0) call decompose_data_real (buf2,tmp) +#else + call get_2d_netcdf("SNOWH", ncid, tmp, units, ix, jx, .FALSE., ierr) +#endif + if(ierr .eq. 0) then +#ifdef HYDRO_D + print *, "read snow depth from wrfoutput ... " +#endif + snodep = tmp + endif + else + snodep = tmp + endif + + if (ierr /= 0) then + ! Quick assumption regarding snow depth. +!yw snodep = weasd * 10. + where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... + endif + +!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... + where(snodep .lt. 0) snodep = 0 + where(weasd .lt. 0) weasd = 0 + ierr = nf_close(ncid) + + end subroutine READSNOW_FORC_mpp + + subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) + + implicit none + logical :: fexist + integer :: ix,jx + character(len=*) :: olddate,hgrid,indir + character(len=19) :: outdate + character(len=256) :: inflnm, inflnm2 + real :: dt + real, dimension(ix,jx):: infxsrt,infxsrt2,soldrain,soldrain2 + integer :: ncid, ierr + character(len=256) :: units +#ifdef MPP_LAND + real, dimension(global_nx,global_ny) :: gArr +#endif + + ! check for file with hours first + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + + if(.not. fexist) then + ! check for file with minutes + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//olddate(15:16)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + endif + if(.not. fexist) then + write(6,*) "Error: input file does not exist. Check ", trim(olddate) + call hydro_stop( "LDASOUT input Error") + endif + + call geth_newdate(outdate,olddate,nint(dt)) + ! check file for next date + ! check for file with hours first + inflnm2 = trim(indir)//"/"//& + outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm2), exist=fexist) + + if(.not. fexist) then + ! check for file with minutes + inflnm2 = trim(indir)//"/"//& + outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//outdate(15:16)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm2), exist=fexist) + endif + if(.not. fexist) then + write(6,*) "FATAL ERROR: input file does not exist. Check ", trim(outdate) + call hydro_stop( "LDASOUT input Error") + endif +! read file1 +#ifdef MPP_LAND + if(my_id .eq. io_id) then + ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + call get_2d_netcdf("SFCRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) + endif + call decompose_data_real (gArr,infxsrt) + if(my_id .eq. io_id) then + call get_2d_netcdf("UGDRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) + endif + call decompose_data_real (gArr,soldrain) + if(my_id .eq. io_id) then + ierr = nf_close(ncid) + endif +#else + ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + call get_2d_netcdf("SFCRNOFF", ncid, infxsrt, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("UGDRNOFF", ncid, soldrain, units, ix, jx, .TRUE., ierr) + ierr = nf_close(ncid) +#endif +! read file2 +#ifdef MPP_LAND + if(my_id .eq. io_id) then + ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + call get_2d_netcdf("SFCRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) + endif + call decompose_data_real (gArr,infxsrt2) + if(my_id .eq. io_id) then + call get_2d_netcdf("UGDRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) + endif + call decompose_data_real (gArr,soldrain2) + if(my_id .eq. io_id) then + ierr = nf_close(ncid) + endif +#else + ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + call get_2d_netcdf("SFCRNOFF", ncid, infxsrt2, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("UGDRNOFF", ncid, soldrain2, units, ix, jx, .TRUE., ierr) + ierr = nf_close(ncid) +#endif + + infxsrt = infxsrt2 - infxsrt + soldrain = soldrain2 - soldrain + + end subroutine read_ldasout + +!temporary for Noah model + + subroutine read_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) + implicit none + logical :: fexist + integer :: ix,jx + character(len=*) :: olddate,hgrid,indir + character(len=19) :: outdate + character(len=256) :: inflnm, inflnm2 + real :: dt + real, dimension(ix,jx):: infxsrt,infxsrt2,soldrain,soldrain2 + integer :: ncid, ierr + character(len=256) :: units + + ! check for file with hours first + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + + if(.not. fexist) then + ! check for file with minutes + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//olddate(15:16)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + endif + if(.not. fexist) then + write(6,*) "FATAL ERROR: input file does not exist. Check ", trim(olddate) + call hydro_stop( "LDASOUT input Error") + endif + + call geth_newdate(outdate,olddate,nint(dt)) + ! check file for next date + ! check for file with hours first + inflnm2 = trim(indir)//"/"//& + outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm2), exist=fexist) + + if(.not. fexist) then + ! check for file with minutes + inflnm2 = trim(indir)//"/"//& + outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//outdate(15:16)//& + ".LDASOUT_DOMAIN"//hgrid + inquire (file=trim(inflnm2), exist=fexist) + endif + if(.not. fexist) then + write(6,*) "FATAL ERROR: input file does not exist. Check ", trim(outdate) + call hydro_stop( "LDASOUT input Error") + endif +! read file1 + ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + call get_2d_netcdf("SFCRNOFF", ncid, infxsrt, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("UGDRNOFF", ncid, soldrain, units, ix, jx, .TRUE., ierr) + ierr = nf_close(ncid) +! read file2 + ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + call get_2d_netcdf("SFCRNOFF", ncid, infxsrt2, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("UGDRNOFF", ncid, soldrain2, units, ix, jx, .TRUE., ierr) + ierr = nf_close(ncid) + + infxsrt = infxsrt2 - infxsrt + soldrain = soldrain2 - soldrain + + end subroutine read_ldasout_seq +end module module_lsm_forcing + + subroutine read_forc_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) + use module_lsm_forcing, only: read_ldasout + implicit none + integer :: ix,jx + character(len=*) :: olddate,hgrid,indir + real :: dt + real, dimension(ix,jx):: infxsrt,soldrain + call read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) + end subroutine read_forc_ldasout + + subroutine read_forc_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) +! temporary for Noah model + use module_lsm_forcing, only: read_ldasout_seq + implicit none + integer :: ix,jx + character(len=*) :: olddate,hgrid,indir + real :: dt + real, dimension(ix,jx):: infxsrt,soldrain + call read_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) + end subroutine read_forc_ldasout_seq + diff --git a/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F b/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F new file mode 100644 index 00000000..5e44d1e7 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F @@ -0,0 +1,114 @@ +! Program Name: +! 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_noah_chan_param_init_rt + + +CONTAINS +! +!----------------------------------------------------------------- + SUBROUTINE CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) +!----------------------------------------------------------------- + + IMPLICIT NONE + + integer :: IINDEX, CHANCATS + integer :: ORDER, IUNIT + integer, PARAMETER :: NCHANTYPES=50 + real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann + character(LEN=11) :: DATATYPE + +!-----SPECIFY CHANNEL RELATED CHARACTERISTICS : +! ORDER: Strahler Stream Order +! BOTWID: Channel Bottom Width (meters) +! HLINK_INIT: Initial depth of flow in channel (meters) +! CHAN_SS: Channel side slope (assuming trapezoidal channel geom) +! CHMann: Channel Manning's N roughness coefficient + + +!-----READ IN CHANNEL PROPERTIES FROM CHANPARM.TBL : + IUNIT = 23 + OPEN(IUNIT, & +#ifndef NCEP_WCOSS + FILE='CHANPARM.TBL', & +#endif + FORM='FORMATTED',STATUS='OLD') + READ (IUNIT,*) + READ (IUNIT,2000,END=2002) DATATYPE +#ifdef HYDRO_D + PRINT *, DATATYPE +#endif + READ (IUNIT,*)CHANCATS,IINDEX +2000 FORMAT (A11) + +!-----Read in Channel Parameters as functions of stream order... + + IF(DATATYPE.EQ.'StreamOrder')THEN +#ifdef HYDRO_D + PRINT *, 'CHANNEL DATA SOURCE TYPE = ',DATATYPE,' FOUND', & + CHANCATS,' CATEGORIES' +#endif + DO ORDER=1,CHANCATS + READ (IUNIT,*)IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & + & CHMann(ORDER) +#ifdef HYDRO_D + PRINT *, IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & + & CHMann(ORDER) +#endif + ENDDO + ENDIF + + +!-----Read in Channel Parameters as functions of ???other method??? (TBC)... + + +2002 CONTINUE + + CLOSE (IUNIT) + END SUBROUTINE CHAN_PARM_INIT + + + +#ifdef MPP_LAND + SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) + use module_mpp_land, only: my_id, IO_id,mpp_land_bcast_int1, & + mpp_land_bcast_real,mpp_land_bcast_int,mpp_land_bcast_real1 + implicit none + integer :: IINDEX, CHANCATS + integer :: ORDER + integer, PARAMETER :: NCHANTYPES=50 + real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann + character(LEN=11) :: DATATYPE + + if(my_id.eq.io_id) then + call CHAN_PARM_INIT(BOTWID,HLINK_INIT,CHAN_SS,CHMann) + end if + call mpp_land_bcast_real(NCHANTYPES,BOTWID) + call mpp_land_bcast_real(NCHANTYPES,HLINK_INIT) + call mpp_land_bcast_real(NCHANTYPES,CHAN_SS) + call mpp_land_bcast_real(NCHANTYPES,CHMann) + return + END SUBROUTINE mpp_CHAN_PARM_INIT +#endif +!----------------------------------------------------------------- +!----------------------------------------------------------------- + + +END MODULE module_Noah_chan_param_init_rt diff --git a/wrfv2_fire/hydro/Routing/rtFunction.F b/wrfv2_fire/hydro/Routing/rtFunction.F new file mode 100644 index 00000000..9334307f --- /dev/null +++ b/wrfv2_fire/hydro/Routing/rtFunction.F @@ -0,0 +1,222 @@ + subroutine exeRouting (did) + use module_RT_data, only: rt_domain + use module_GW_baseflow_data, only: gw2d + use module_GW_baseflow, only: simp_gw_buck, gwstep + use module_channel_routing, only: drive_channel + use module_namelist, only: nlst_rt + +#ifdef MPP_LAND + use module_mpp_land +#endif + + + implicit none + integer did, i + real, dimension(RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT):: & + QSTRMVOLRT_DUM,LAKE_INFLORT_DUM, & + QSTRMVOLRT_TS, LAKE_INFLORT_TS + + real :: dx + integer ii,jj,kk + + + IF (nlst_rt(did)%SUBRTSWCRT.EQ.1 .or. nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) THEN + + QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT + LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT + +#ifdef HYDRO_D + write(6,*) "*****yw******start drive_RT " +#endif + + + +! write(6,*) "yyww RT_DOMAIN(did)%SH2OX(15,1,7)= ", RT_DOMAIN(did)%SH2OX(15,1,7) + + call drive_RT( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& + RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%STC,RT_DOMAIN(did)%SH2OX, & + RT_DOMAIN(did)%INFXSRT,RT_DOMAIN(did)%SFCHEADRT,RT_DOMAIN(did)%SMCMAX1,& + RT_DOMAIN(did)%SMCREF1,RT_DOMAIN(did)%LKSAT, & + RT_DOMAIN(did)%SMCWLT1, RT_DOMAIN(did)%SMCRTCHK,RT_DOMAIN(did)%DSMC,& + RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SMCAGGRT,& + RT_DOMAIN(did)%STCAGGRT,RT_DOMAIN(did)%SH2OAGGRT, & + RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%SOLDEPRT,& + RT_DOMAIN(did)%INFXSAGGRT,RT_DOMAIN(did)%DHRT,RT_DOMAIN(did)%QSTRMVOLRT, & + RT_DOMAIN(did)%QBDRYRT,RT_DOMAIN(did)%LAKE_INFLORT,& + RT_DOMAIN(did)%SFCHEADSUBRT,RT_DOMAIN(did)%INFXSWGT,& + RT_DOMAIN(did)%LKSATRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%OVROUGHRT,& + RT_DOMAIN(did)%QSUBRT,RT_DOMAIN(did)%ZWATTABLRT, & + RT_DOMAIN(did)%QSUBBDRYRT, & + RT_DOMAIN(did)%RETDEPRT,RT_DOMAIN(did)%SOXRT,RT_DOMAIN(did)%SOYRT,& + RT_DOMAIN(did)%SUB_RESID,RT_DOMAIN(did)%SMCRT,& + RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCWLTRT, & + RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%LAKE_MSKRT,& + RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%LSMVOL,RT_DOMAIN(did)%DSMCTOT, & + RT_DOMAIN(did)%SMCTOT1,& + RT_DOMAIN(did)%SMCTOT2,RT_DOMAIN(did)%suminfxs1, & + RT_DOMAIN(did)%suminfxsrt,RT_DOMAIN(did)%SO8RT, & + RT_DOMAIN(did)%SO8RT_D,nlst_rt(did)%AGGFACTRT, & + nlst_rt(did)%SUBRTSWCRT,nlst_rt(did)%OVRTSWCRT, & + RT_DOMAIN(did)%LAKE_CT, RT_DOMAIN(did)%STRM_CT, & + nlst_rt(did)%RT_OPTION,RT_DOMAIN(did)%OV_ROUGH, & + RT_DOMAIN(did)%INFXSAGG1RT,RT_DOMAIN(did)%SFCHEADAGG1RT,& + RT_DOMAIN(did)%SFCHEADAGGRT,& + nlst_rt(did)%DTRT, & + nlst_rt(did)%DT,RT_DOMAIN(did)%LAKE_INFLOTRT,& + RT_DOMAIN(did)%QBDRYTRT,RT_DOMAIN(did)%QSUBBDRYTRT,& + RT_DOMAIN(did)%QSTRMVOLTRT,RT_DOMAIN(did)%q_sfcflx_x,& + RT_DOMAIN(did)%q_sfcflx_y,RT_DOMAIN(did)%LKSATFAC,& + RT_DOMAIN(did)%OVROUGHRTFAC,rt_domain(did)%dist_lsm(:,:,9) ) + + QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-QSTRMVOLRT_DUM + LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-LAKE_INFLORT_DUM + +#ifdef HYDRO_D + write(6,*) "*****yw******end drive_RT " +#endif + end if + + + +!------------------------------------------------------------------ +!DJG Begin GW/Baseflow Routines +!------------------------------------------------------------------- + + IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow + +! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow + + If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme + +#ifdef HYDRO_D + write(6,*) "*****yw******start simp_gw_buck " +#endif + + call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& + RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& + RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & + RT_DOMAIN(did)%SOLDRAIN, & + RT_DOMAIN(did)%z_gwsubbas,& + RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& + RT_DOMAIN(did)%qinflowbase,& + RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & + RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& + RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%z_max,& + nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + open (unit=51,file='GW_inflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=52,file='GW_outflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=53,file='GW_zlev.txt',form='formatted',& + status='unknown',position='append') + do i=1,RT_DOMAIN(did)%numbasns + write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) +951 FORMAT(I3,1X,A19,1X,F11.3) + write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) + write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) + end do + close(51) + close(52) + close(53) +#ifdef MPP_LAND + endif +#endif + +#ifdef HYDRO_D + write(6,*) "*****yw******end simp_gw_buck " +#endif + +!!!For parameter setup runs output the percolation for each basin, +!!!otherwise comment out this output... + else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then + +#ifdef HYDRO_D + write(6,*) "*****bf******start 2d_gw_model " +#endif + + DX = abs(nlst_rt(did)%DXRT0 * nlst_rt(did)%AGGFACTRT) + + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + gw2d(did)%istep) + + +! bftodo head postprocessing block +! GW-SOIL-CHANNEL interaction section + gw2d(did)%ho = gw2d(did)%h + +#ifdef HYDRO_D + write(6,*) "*****bf******end 2d_gw_model " +#endif + + End if + + END IF !DJG (End if for RTE SWC activation) +!------------------------------------------------------------------ +!DJG End GW/Baseflow Routines +!------------------------------------------------------------------- + +!------------------------------------------------------------------- +!------------------------------------------------------------------- +!DJG,DNY Begin Channel and Lake Routing Routines +!------------------------------------------------------------------- + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN + + call drive_CHANNEL(RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & + LAKE_INFLORT_TS, QSTRMVOLRT_TS,& + RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& + RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& + RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & + RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTRT, & + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& + RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & + RT_DOMAIN(did)%Bw,& + RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& + RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & + RT_DOMAIN(did)%ORIFICEA, & + RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & + RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& + RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & + RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & + RT_DOMAIN(did)%RETDEP_CHAN & + , RT_DOMAIN(did)%node_area & +#ifdef MPP_LAND + ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& + RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & + RT_DOMAIN(did)%yw_mpp_nlinks & +#endif + ) + endif + +#ifdef HYDRO_D + write(6,*) "*****yw******end drive_CHANNEL " +#endif + + end subroutine exeRouting + + subroutine time_seconds(i3) + integer time_array(8) + real*8 i3 + call date_and_time(values=time_array) + i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & + time_array(7) + 0.001 * time_array(8) + return + end subroutine time_seconds + + diff --git a/wrfv2_fire/hydro/Run/HYDRO.TBL b/wrfv2_fire/hydro/Run/HYDRO.TBL new file mode 100644 index 00000000..1d691a08 --- /dev/null +++ b/wrfv2_fire/hydro/Run/HYDRO.TBL @@ -0,0 +1,51 @@ + 28 USGS for OV_ROUGH + SFC_ROUGH' + 0.025, 'Urban and Built-Up Land' + 0.035, 'Dryland Cropland and Pasture' + 0.035, 'Irrigated Cropland and Pasture' + 0.055, 'Mixed Dryland/Irrigated Cropland and Pasture' + 0.035, 'Cropland/Grassland Mosaic' + 0.068, 'Cropland/Woodland Mosaic' + 0.055, 'Grassland' + 0.055, 'Shrubland' + 0.055, 'Mixed Shrubland/Grassland' + 0.055, 'Savanna' + 0.200, 'Deciduous Broadleaf Forest' + 0.200, 'Deciduous Needleleaf Forest' + 0.200, 'Evergreen Broadleaf Forest' + 0.200, 'Evergreen Needleleaf Forest' + 0.200, 'Mixed Forest' + 0.005, 'Water Bodies' + 0.070, 'Herbaceous Wetland' + 0.070, 'Wooded Wetland' + 0.035, 'Barren or Sparsely Vegetated' + 0.055, 'Herbaceous Tundra' + 0.055, 'Wooded Tundra' + 0.055, 'Mixed Tundra' + 0.055, 'Bare Ground Tundra' + 0.010, 'Snow or Ice' + 0.010, 'Playa' + 0.100, 'Lava' + 0.010, 'White Sand' + 0.005, 'Non-Ocean Water Bodies' +19, for SATDK +SATDK MAXSMC REFSMC WLTSMC QTZ ' +1.07E-6, 0.339, 0.236, 0.010, 0.92, 'SAND' +1.41E-5, 0.421, 0.383, 0.028, 0.82, 'LOAMY SAND' +5.23E-6, 0.434, 0.383, 0.047, 0.60, 'SANDY LOAM' +2.81E-6, 0.476, 0.360, 0.084, 0.25, 'SILT LOAM' +2.81E-6, 0.476, 0.383, 0.084, 0.10, 'SILT' +3.38E-6, 0.439, 0.329, 0.066, 0.40, 'LOAM' +4.45E-6, 0.404, 0.314, 0.067, 0.60, 'SANDY CLAY LOAM' +2.04E-6, 0.464, 0.387, 0.120, 0.10, 'SILTY CLAY LOAM' +2.45E-6, 0.465, 0.382, 0.103, 0.35, 'CLAY LOAM' +7.22E-6, 0.406, 0.338, 0.100, 0.52, 'SANDY CLAY' +1.34E-6, 0.468, 0.404, 0.126, 0.10, 'SILTY CLAY' +9.74E-7, 0.468, 0.412, 0.138, 0.25, 'CLAY' +3.38E-6, 0.439, 0.329, 0.066, 0.05, 'ORGANIC MATERIAL' + 0.0, 1.0, 0.0, 0.0, 0.60, 'WATER' +1.75E-5, 0.20, 0.170, 0.006, 0.07, 'BEDROCK' +1.41E-5, 0.421, 0.283, 0.028, 0.25, 'OTHER(land-ice)' +9.74E-7, 0.468, 0.454, 0.030, 0.60, 'PLAYA' +1.41E-4, 0.200, 0.170, 0.006, 0.52, 'LAVA' +1.07E-6, 0.339, 0.236, 0.01, 0.92, 'WHITE SAND' diff --git a/wrfv2_fire/hydro/Run/hydro.namelist b/wrfv2_fire/hydro/Run/hydro.namelist new file mode 100644 index 00000000..376d762a --- /dev/null +++ b/wrfv2_fire/hydro/Run/hydro.namelist @@ -0,0 +1,102 @@ +&HYDRO_nlist + +!!!! SYSTEM COUPLING !!!! +!Specify what is being coupled with WRF-Hydro: 1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM + sys_cpl = 1 + + + + +!!!! MODEL INPUT DATA FILES !!! +!Specify land surface model gridded static input data file...(e.g.: "geo_em.d03.nc") + GEO_STATIC_FLNM = "./DOMAIN/geo_em.d01.nc.conus_1km" + +!Specify the static high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc") + GEO_FINEGRID_FLNM = "./DOMAIN/Fulldom_hires_netcdf_file_nhd_mask.nc" + +!Specify the name of the restart file if starting from restart...comment out with '!' if not... +!RESTART_FILE = 'HYDRO_RST.2013-09-11_02:00_DOMAIN3' + + + + +!!!! MODEL SETUP AND I/O CONTROL !!!! +!Specify the domain or nest number identifier...(integer) + IGRID = 1 + +!Specify the restart file write frequency...(minutes, value of -99999 provides monthly restart files) +!rst_dt = -99999 + rst_dt = 360 + +!Specify the output file write frequency...(minutes) + out_dt = 60 ! minutes + +!Specify the number of output times to be contained within each output history file...(integer) +! SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!! +! SET = 1 WHEN RUNNING COUPLED TO WRF!!! + SPLIT_OUTPUT_COUNT = 1 + +!Switch to overwrite the restart or initialization of soil variables with values from the routing restart file (=0-no reset, 1-yes reset using routing restart) + rst_typ = 1 + +!Switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0) + RSTRT_SWC = 0 + +!Switches to specify if routing restart files are to be read in/output in a flat binary format (=0 no, 1-yes read/write in binary format) + rst_bi_in = 1 ! read restart in binary format + rst_bi_out = 1 ! output restart in binary format + +!Routing output netcdf file control...(=0 no files written, =1 files are written) + CHRTOUT_DOMAIN = 1 ! Netcdf and ASCII point timeseries output at all channel points and at user-define points (frxst_pts) + CHRTOUT_GRID = 1 ! Netcdf grid of channel streamflow values + LSMOUT_DOMAN = 0 ! Netcdf grid of variables passed between LSM and routing components + RTOUT_DOMAIN = 1 ! Netcdf grid of terrain routing variables on routing grid + output_gw = 0 ! Netcdf grid of groundwater-baseflow bucket information + outlake = 0 ! Netcdf point timeseries output of lake information + +!Specify the minimum stream order to output to netcdf point file...(integer) +!Note: lower value of stream order produces more output. + order_to_write = 1 + + + + +!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!! +!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes +!Note: This option is not yet active in Verion 3.0... +! WRF has this capability so be careful not to double apply the correction!!! + TERADJ_SOLAR = 0 + +!Specify the grid spacing of the terrain routing grid...(meters) + DXRT = 250 +!Specify the integer multiple between the land model grid and the terrain routing grid...(integer) + AGGFACTRT = 4 +!Specify the routing model timestep...(seconds) + DTRT = 4 + + +!Switch activate saturated subsurface routing...(0=no, 1=yes) + SUBRTSWCRT = 1 + + +!Switch activate surface overland flow routing...(0=no, 1=yes) + OVRTSWCRT = 1 +!Switch to specify channel routing Routing Option: 1=Seepest Descent (D8) 2=CASC2D + rt_option = 1 + + +!Switch to activate channel routing option...((0=no, 1=yes) + CHANRTSWCRT = 1 +!Switch specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded + channel_option =3 +!Specify the reach file for reach-based routing options...(Only req'd for channel_options 1&2) + route_link_f = "" + + +!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through) + GWBASESWCRT = 0 +!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file) + GW_RESTART = 0 +!Groundwater/baseflow mask specified on land surface model grid...(Only required if baseflow bucket model is active) + gwbasmskfil = "" +/ diff --git a/wrfv2_fire/hydro/arc/Makefile.Noah b/wrfv2_fire/hydro/arc/Makefile.Noah new file mode 100644 index 00000000..c0ac9977 --- /dev/null +++ b/wrfv2_fire/hydro/arc/Makefile.Noah @@ -0,0 +1,30 @@ +# Makefile +all: + (rm -f Run/wrf_hydro.exe ) + (make -f Makefile.comm BASIC) + @if [ -d "LandModel_cpl" ]; then \ + (cd LandModel_cpl; make) \ + fi + if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \ + (cd lib;rm -f librapid.a); \ + fi + if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \ + (cd Rapid_routing; make -f makefile.cpl rapid); \ + fi + + @if [ -d "LandModel" ]; then \ + (cd LandModel; make ; rm -f ../../Run/wrf_hydro.exe; mv Run/Noah_hrldas_beta ../../Run/wrf_hydro.exe ) \ + fi + +clean: + @if [ -d "LandModel_cpl" ]; then \ + (cd LandModel_cpl; make clean) \ + fi + (make -f Makefile.comm clean) + @if [ -d "LandModel" ]; then \ + (cd LandModel; make clean) \ + fi + if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \ + (cd Rapid_routing; make -f makefile.cpl clean); \ + fi + (rm -f */*.mod */*.o lib/*.a Run/wrf_hydro.exe) diff --git a/wrfv2_fire/hydro/arc/Makefile.NoahMP b/wrfv2_fire/hydro/arc/Makefile.NoahMP new file mode 100644 index 00000000..e4b2aa43 --- /dev/null +++ b/wrfv2_fire/hydro/arc/Makefile.NoahMP @@ -0,0 +1,30 @@ +# Makefile +all: + (rm -f Run/wrf_hydro.exe ) + (make -f Makefile.comm BASIC) + @if [ -d "LandModel_cpl" ]; then \ + (cd LandModel_cpl; make) \ + fi + if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \ + (cd lib;rm -f librapid.a); \ + fi + if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \ + (cd Rapid_routing; make -f makefile.cpl rapid); \ + fi + + @if [ -d "LandModel" ]; then \ + (cd LandModel; make ; rm -f ../../Run/wrf_hydro.exe; mv run/hrldas.exe ../../Run/wrf_hydro.exe ) \ + fi + +clean: + @if [ -d "LandModel_cpl" ]; then \ + (cd LandModel_cpl; make clean) \ + fi + (make -f Makefile.comm clean) + @if [ -d "LandModel" ]; then \ + (cd LandModel; make clean) \ + fi + if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \ + (cd Rapid_routing; make -f makefile.cpl clean); \ + fi + (rm -f */*.mod */*.o lib/*.a Run/wrf_hydro.exe) diff --git a/wrfv2_fire/hydro/arc/Makefile.mpp b/wrfv2_fire/hydro/arc/Makefile.mpp new file mode 100644 index 00000000..a494e8df --- /dev/null +++ b/wrfv2_fire/hydro/arc/Makefile.mpp @@ -0,0 +1,17 @@ +# Makefile + +all: + (make -f Makefile.comm BASIC) + +BASIC: + (cd MPP ; make -f Makefile) + (cd Data_Rec ; make -f Makefile) + (cd Routing; make -f Makefile) + (cd HYDRO_drv; make -f Makefile) + +clean: + (cd Data_Rec; make -f Makefile clean) + (cd HYDRO_drv; make -f Makefile clean) + (cd MPP; make -f Makefile clean) + (cd Routing; make -f Makefile clean) + (rm -f lib/*.a */*.mod */*.o CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/Makefile.seq b/wrfv2_fire/hydro/arc/Makefile.seq new file mode 100644 index 00000000..386935ce --- /dev/null +++ b/wrfv2_fire/hydro/arc/Makefile.seq @@ -0,0 +1,36 @@ +# Makefile + +all: + (make -f Makefile BASIC) + +BASIC: + (cd Data_Rec ; make -f Makefile) + (cd Routing; make -f Makefile) + ifeq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING) + (cd nudging; make -f Makefile) + endif + (cd HYDRO_drv; make -f Makefile) + +LIS: + (make -f Makefile BASIC) + (cd LIS_cpl ; make -f Makefile) + +CLM: + (make -f Makefile BASIC) + (cd CLM_cpl ; make -f Makefile) + +WRF: + (make -f Makefile BASIC) + (cd WRF_cpl ; make -f Makefile) + +HYDRO: + (make -f Makefile BASIC) + +clean: + (cd Data_Rec; make -f Makefile clean) + (cd HYDRO_drv; make -f Makefile clean) + ifeq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING) + (cd nudging; make -f Makefile clean) + endif + (cd Routing; make -f Makefile clean) + (rm -f lib/*.a */*.mod CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r new file mode 100644 index 00000000..880e8089 --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r @@ -0,0 +1,43 @@ +.IGNORE: + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +RM = rm -f +RMD = rm -f +COMPILER90= mpxlf90_r +F90FLAGS = -O2 -qfree=f90 -c -w -qspill=20000 -qmaxmem=64000 +LDFLAGS = -O2 -qfree=f90 -w -qspill=20000 -qmaxmem=64000 +MODFLAG = -I./ -I ../MPP -I../../MPP -I ../mod +LDFLAGS = +CPP = cpp +LIBS = +CPPFLAGS = -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf + diff --git a/wrfv2_fire/hydro/arc/macros.mpp.gfort b/wrfv2_fire/hydro/arc/macros.mpp.gfort new file mode 100644 index 00000000..c58e5ce1 --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.mpp.gfort @@ -0,0 +1,46 @@ +.IGNORE: + +ifeq ($(SPATIAL_SOIL),1) +SPATIAL_SOIL = -DSPATIAL_SOIL +else +SPATIAL_SOIL = +endif + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +RMD = rm -f +COMPILER90= mpif90 +F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 +MODFLAG = -I"./" -I"../../MPP" -I"../MPP" -I"../mod" +LDFLAGS = +CPP = cpp +CPPFLAGS = -P -xassembler-with-cpp -traditional -DMPP_LAND -I"../Data_Rec" $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.mpp.ifort b/wrfv2_fire/hydro/arc/macros.mpp.ifort new file mode 100644 index 00000000..ce3bc096 --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.mpp.ifort @@ -0,0 +1,96 @@ +## If you have multiple mpi biulds on a single machine +## this example may be relevant to you. +## Ex: The hydro-c1 machine has mpi and netcdf built against portland +## fortran in the PATH. However mpi and netcd built against intel +## fortran is also available. Here's how I build WRF HYDRO against +## intel +## Below, in this file, I make the changes: +## COMPILER90 = $(ifortCompiler90) +## LDFLAGS = $(ifortLdFlags) +## NETCDFINC = $(ifortNetcdfInc) +## NETCDFLIB = -L$(ifortNetcdfLib) -lnetcdff -lnetcdf +## In my ~/.bashrc I have +## ## WRF HYDRO +## export NETCDF=/opt/netcdf +## export WRF_HYDRO=1 +## export HYDRO_D=1 +## ### manage ifort on hydro +## export ifortNetcdfLib="/opt/netcdf-4.3.0+ifort-12.1/lib/" +## export ifortNetcdfInc="/opt/netcdf-4.3.0+ifort-12.1/include/" +## # RPATH for ifort (pgi is already default so no need) +## ifortMpiLib="/opt/openmpi-1.10.0-intel/lib/" +## export ifortLdFlags="-Wl,-rpath,${ifortNetcdfLib}:${ifortMpiLib} -L${ifortNetcdfLib} -L${ifortMpiLib}" +## export ifortCompiler90='/opt/openmpi-1.10.0-intel/bin/mpif90' +## # Aliases for invoking ifort +## alias impirun='/opt/openmpi-1.10.0-intel/bin/mpirun' +## alias iman='man -M/opt/openmpi+intel/man' +## # Bonus: Check your wrf hydro environment - up you to maintain to your needs. +## alias henv='printenv | egrep -i "(HYDRO|NUDG|PRECIP|CHAN_CONN|^NETCDF|^LDFLAGS|^ifort)" | egrep -v PWD' + +.IGNORE: + +ifeq ($(SPATIAL_SOIL),1) +SPATIAL_SOIL = -DSPATIAL_SOIL +else +SPATIAL_SOIL = +endif + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +ifeq ($(WRF_HYDRO_NUDGING),1) +WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING +else +WRF_HYDRO_NUDGING = +endif + +ifeq ($(OUTPUT_CHAN_CONN),1) +OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN +else +OUTPUT_CHAN_CONN = +endif + +ifeq ($(PRECIP_DOUBLE),1) +PRECIP_DOUBLE = -DPRECIP_DOUBLE +else +PRECIP_DOUBLE = +endif + + +RMD = rm -f +COMPILER90 = mpif90 +FORMAT_FREE = -FR +BYTESWAPIO = -convert big_endian +F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) +MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) $(PRECIP_DOUBLE) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.mpp.ifort.luna b/wrfv2_fire/hydro/arc/macros.mpp.ifort.luna new file mode 100644 index 00000000..24778bc2 --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.mpp.ifort.luna @@ -0,0 +1,96 @@ +## If you have multiple mpi biulds on a single machine +## this example may be relevant to you. +## Ex: The hydro-c1 machine has mpi and netcdf built against portland +## fortran in the PATH. However mpi and netcd built against intel +## fortran is also available. Here's how I build WRF HYDRO against +## intel +## Below, in this file, I make the changes: +## COMPILER90 = $(ifortCompiler90) +## LDFLAGS = $(ifortLdFlags) +## NETCDFINC = $(ifortNetcdfInc) +## NETCDFLIB = -L$(ifortNetcdfLib) -lnetcdff -lnetcdf +## In my ~/.bashrc I have +## ## WRF HYDRO +## export NETCDF=/opt/netcdf +## export WRF_HYDRO=1 +## export HYDRO_D=1 +## ### manage ifort on hydro +## export ifortNetcdfLib="/opt/netcdf-4.3.0+ifort-12.1/lib/" +## export ifortNetcdfInc="/opt/netcdf-4.3.0+ifort-12.1/include/" +## # RPATH for ifort (pgi is already default so no need) +## ifortMpiLib="/opt/openmpi-1.10.0-intel/lib/" +## export ifortLdFlags="-Wl,-rpath,${ifortNetcdfLib}:${ifortMpiLib} -L${ifortNetcdfLib} -L${ifortMpiLib}" +## export ifortCompiler90='/opt/openmpi-1.10.0-intel/bin/mpif90' +## # Aliases for invoking ifort +## alias impirun='/opt/openmpi-1.10.0-intel/bin/mpirun' +## alias iman='man -M/opt/openmpi+intel/man' +## # Bonus: Check your wrf hydro environment - up you to maintain to your needs. +## alias henv='printenv | egrep -i "(HYDRO|NUDG|PRECIP|CHAN_CONN|^NETCDF|^LDFLAGS|^ifort)" | egrep -v PWD' + +.IGNORE: + +ifeq ($(SPATIAL_SOIL),1) +SPATIAL_SOIL = -DSPATIAL_SOIL +else +SPATIAL_SOIL = +endif + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +ifeq ($(WRF_HYDRO_NUDGING),1) +WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING +else +WRF_HYDRO_NUDGING = +endif + +ifeq ($(OUTPUT_CHAN_CONN),1) +OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN +else +OUTPUT_CHAN_CONN = +endif + +ifeq ($(PRECIP_DOUBLE),1) +PRECIP_DOUBLE = -DPRECIP_DOUBLE +else +PRECIP_DOUBLE = +endif + + +RMD = rm -f +COMPILER90 = ftn +FORMAT_FREE = -FR +BYTESWAPIO = -convert big_endian +F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) +MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) $(PRECIP_DOUBLE) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.mpp.linux b/wrfv2_fire/hydro/arc/macros.mpp.linux new file mode 100644 index 00000000..203bad57 --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.mpp.linux @@ -0,0 +1,67 @@ +.IGNORE: + +ifeq ($(SPATIAL_SOIL),1) +SPATIAL_SOIL = -DSPATIAL_SOIL +else +SPATIAL_SOIL = +endif + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +ifeq ($(WRF_HYDRO_NUDGING),1) +WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING +else +WRF_HYDRO_NUDGING = +endif + +ifeq ($(OUTPUT_CHAN_CONN),1) +OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN +else +OUTPUT_CHAN_CONN = +endif + +ifeq ($(PRECIP_DOUBLE),1) +PRECIP_DOUBLE = -DPRECIP_DOUBLE +else +PRECIP_DOUBLE = +endif + + +RM = rm -f +RMD = rm -f +COMPILER90= mpif90 +F90FLAGS = -Mfree -c -byteswapio -O2 -Kieee +LDFLAGS = $(F90FLAGS) +MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) $(PRECIP_DOUBLE) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -Wl,-rpath,$(NETCDF_LIB) -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r new file mode 100644 index 00000000..099daa3b --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r @@ -0,0 +1,43 @@ +.IGNORE: + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + + + +RM = rm -f +RMD = rm -f +COMPILER90= xlf90_r +F90FLAGS = -c -O2 -qfree=f90 -qmaxmem=819200 +MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +LDFLAGS = +CPP = cpp -P +CPPFLAGS = -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.gfort b/wrfv2_fire/hydro/arc/macros.seq.gfort new file mode 100644 index 00000000..dd6bdb3f --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.seq.gfort @@ -0,0 +1,47 @@ +.IGNORE: + +ifeq ($(SPATIAL_SOIL),1) +SPATIAL_SOIL = -DSPATIAL_SOIL +else +SPATIAL_SOIL = +endif + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + + +RMD = rm -f +COMPILER90= gfortran +F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 +MODFLAG = -I./ -I../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -P -xassembler-with-cpp -traditional -I"../Data_Rec" $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.ifort b/wrfv2_fire/hydro/arc/macros.seq.ifort new file mode 100644 index 00000000..7e16c80e --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.seq.ifort @@ -0,0 +1,60 @@ +.IGNORE: + +ifeq ($(SPATIAL_SOIL),1) +SPATIAL_SOIL = -DSPATIAL_SOIL +else +SPATIAL_SOIL = +endif + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +ifeq ($(WRF_HYDRO_NUDGING),1) +WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING +else +WRF_HYDRO_NUDGING = +endif + +ifeq ($(OUTPUT_CHAN_CONN),1) +OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN +else +OUTPUT_CHAN_CONN = +endif + +RMD = rm -f +COMPILER90= ifort +##F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 +F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise -FR -convert big_endian + +MODFLAG = -I./ -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -P -traditional -I ../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.linux b/wrfv2_fire/hydro/arc/macros.seq.linux new file mode 100644 index 00000000..367e3421 --- /dev/null +++ b/wrfv2_fire/hydro/arc/macros.seq.linux @@ -0,0 +1,61 @@ +.IGNORE: + +ifeq ($(SPATIAL_SOIL),1) +SPATIAL_SOIL = -DSPATIAL_SOIL +else +SPATIAL_SOIL = +endif + +ifeq ($(HYDRO_REALTIME),1) +HYDRO_REALTIME = -DHYDRO_REALTIME +else +HYDRO_REALTIME = +endif + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME) +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME) +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +ifeq ($(WRF_HYDRO_NUDGING),1) +WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING +else +WRF_HYDRO_NUDGING = +endif + +ifeq ($(OUTPUT_CHAN_CONN),1) +OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN +else +OUTPUT_CHAN_CONN = +endif + + +RMD = ls +RM = rm -f +COMPILER90= pgf90 +F90FLAGS = -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2 -Kieee +LDFLAGS = $(F90FLAGS) +MODFLAG = -I./ -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRF_HYDRO) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -Wl,-rpath,$(NETCDF_LIB) -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/configure b/wrfv2_fire/hydro/configure new file mode 100755 index 00000000..a98e9d1c --- /dev/null +++ b/wrfv2_fire/hydro/configure @@ -0,0 +1,113 @@ +#!/usr/bin/perl + + if(! defined($ENV{NETCDF_INC})){ + if(defined($ENV{NETCDF})) { + $tt = `echo "NETCDF_INC = \${NETCDF}/include" > macros.tmp` ; + } else { + print"Error: environment variable NETCDF_INC not defined. \n"; + exit(0); + } + } + + ${NETCDF_LIB} = $ENV{NETCDF_LIB}; + if(! defined($ENV{NETCDF_LIB})){ + if(defined($ENV{NETCDF})) { + $tt = `echo "NETCDF_LIB = \${NETCDF}/lib" >> macros.tmp` ; + ${NETCDF_LIB} = $ENV{NETCDF}."/lib"; + } else { + print"Error: environment variable NETCDF_LIB not defined. \n"; + exit(0); + } + } + + if(! -e "${NETCDF_LIB}/libnetcdff.a"){ + $tt = `echo "NETCDFLIB = -L${NETCDF_LIB} -lnetcdf" >> macros.tmp `; + } + + if(-e macros) {system (rm -f macros);} +# if(-e Makefile) {system "rm -f Makefile" ;} + +# system("cp arc/Makefile ."); + + if($#ARGV == 0) { + $response = shift(@ARGV) ; + print("Configure hydro: $response \n"); + }else { + print "Please select from following supported options. \n\n"; + + print " 1. Linux PGI compiler sequential \n"; + print " 2. Linux PGI compiler dmpar \n"; + print " 3. IBM AIX compiler sequential, xlf90_r\n"; + print " 4. IBM AIX compiler dmpar \n"; + print " 5. Linux gfort compiler sequential \n"; + print " 6. Linux gfort compiler dmpar \n"; + print " 7. Linux ifort compiler sequential \n"; + print " 8. Linux ifort compiler dmpar \n"; + print " 9. Linux ifort compiler dmpar (WCOSS Luna) \n"; + print " 0. exit only \n"; + + printf "\nEnter selection [%d-%d] : ",0,9 ; + + $response = ; + chop($response); + } + + use Switch; + switch ($response) { + case 1 { + # sequential linux + system "cp arc/macros.seq.linux macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + + case 2 { + # mpp linux + system "cp arc/macros.mpp.linux macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + + case 3 { + # sequential IBM AIX + system "cp arc/macros.seq.IBM.xlf90_r macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + + case 4 { + # mpp IBM AIX + system "cp arc/macros.mpp.IBM.xlf90_r macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + + case 5 { + # GFORTRAN only + system "cp arc/macros.seq.gfort macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + + case 6 { + # GFORTRAN dmpar only + system "cp arc/macros.mpp.gfort macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + case 7 { + # ifort sequential + system "cp arc/macros.seq.ifort macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + case 8 { + # ifort dmpar only + system "cp arc/macros.mpp.ifort macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + case 9 { + # ifort Luna dmpar only + system "cp arc/macros.mpp.ifort.luna macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + + else {print "no selection $response\n"; last} + } + if(! (-e lib)) {mkdir lib;} + if(! (-e mod)) {mkdir mod;} + if(-e "macros.tmp") { system("cat macros macros.tmp > macros.a; rm -f macros.tmp; mv macros.a macros");} + # if((-d "LandModel") ) {system "cat macros LandModel/user_build_options.bak > LandModel/user_build_options";} diff --git a/wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL b/wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL new file mode 100644 index 00000000..1de05f57 --- /dev/null +++ b/wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL @@ -0,0 +1,50 @@ + 27 USGS for OV_ROUGH + SFC_ROUGH' + 0.025, 'Urban and Built-Up Land' + 0.035, 'Dryland Cropland and Pasture' + 0.035, 'Irrigated Cropland and Pasture' + 0.055, 'Mixed Dryland/Irrigated Cropland and Pasture' + 0.035, 'Cropland/Grassland Mosaic' + 0.068, 'Cropland/Woodland Mosaic' + 0.055, 'Grassland' + 0.055, 'Shrubland' + 0.055, 'Mixed Shrubland/Grassland' + 0.055, 'Savanna' + 0.200, 'Deciduous Broadleaf Forest' + 0.200, 'Deciduous Needleleaf Forest' + 0.200, 'Evergreen Broadleaf Forest' + 0.200, 'Evergreen Needleleaf Forest' + 0.200, 'Mixed Forest' + 0.005, 'Water Bodies' + 0.070, 'Herbaceous Wetland' + 0.070, 'Wooded Wetland' + 0.035, 'Barren or Sparsely Vegetated' + 0.055, 'Herbaceous Tundra' + 0.055, 'Wooded Tundra' + 0.055, 'Mixed Tundra' + 0.055, 'Bare Ground Tundra' + 0.010, 'Snow or Ice' + 0.010, 'Playa' + 0.100, 'Lava' + 0.010, 'White Sand' +19, for SATDK +SATDK MAXSMC REFSMC WLTSMC QTZ ' +1.07E-6, 0.339, 0.236, 0.010, 0.92, 'SAND' +1.41E-5, 0.421, 0.383, 0.028, 0.82, 'LOAMY SAND' +5.23E-6, 0.434, 0.383, 0.047, 0.60, 'SANDY LOAM' +2.81E-6, 0.476, 0.360, 0.084, 0.25, 'SILT LOAM' +2.81E-6, 0.476, 0.383, 0.084, 0.10, 'SILT' +3.38E-6, 0.439, 0.329, 0.066, 0.40, 'LOAM' +4.45E-6, 0.404, 0.314, 0.067, 0.60, 'SANDY CLAY LOAM' +2.04E-6, 0.464, 0.387, 0.120, 0.10, 'SILTY CLAY LOAM' +2.45E-6, 0.465, 0.382, 0.103, 0.35, 'CLAY LOAM' +7.22E-6, 0.406, 0.338, 0.100, 0.52, 'SANDY CLAY' +1.34E-6, 0.468, 0.404, 0.126, 0.10, 'SILTY CLAY' +9.74E-7, 0.468, 0.412, 0.138, 0.25, 'CLAY' +3.38E-6, 0.439, 0.329, 0.066, 0.05, 'ORGANIC MATERIAL' + 0.0, 1.0, 0.0, 0.0, 0.60, 'WATER' +1.41E-4, 0.20, 0.170, 0.006, 0.07, 'BEDROCK' +1.41E-5, 0.421, 0.283, 0.028, 0.25, 'OTHER(land-ice)' +9.74E-7, 0.468, 0.454, 0.030, 0.60, 'PLAYA' +1.41E-4, 0.200, 0.170, 0.006, 0.52, 'LAVA' +1.07E-6, 0.339, 0.236, 0.01, 0.92, 'WHITE SAND' diff --git a/wrfv2_fire/hydro/template/HYDRO/hydro.namelist b/wrfv2_fire/hydro/template/HYDRO/hydro.namelist new file mode 100644 index 00000000..0ac93c57 --- /dev/null +++ b/wrfv2_fire/hydro/template/HYDRO/hydro.namelist @@ -0,0 +1,142 @@ +&HYDRO_nlist + +!!!! SYSTEM COUPLING !!!! +!Specify what is being coupled: 1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM + sys_cpl = 1 + +!!!! MODEL INPUT DATA FILES !!! +!Specify land surface model gridded input data file...(e.g.: "geo_em.d03.nc") + GEO_STATIC_FLNM = "../DOMAIN/geo_em.d03.nc" + +!Specify the high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc" + GEO_FINEGRID_FLNM = "../DOMAIN/Fulldom_hires_netcdf_file.nc" + +!Specify the name of the restart file if starting from restart...comment out with '!' if not... + RESTART_FILE = 'HYDRO_RST.2013-09-12_04:00_DOMAIN3' + +!!!! MODEL SETUP AND I/O CONTROL !!!! +!Specify the domain or nest number identifier...(integer) + IGRID = 3 + +!Specify the restart file write frequency...(minutes) + rst_dt = 120 +! rst_dt = 1440 + +!Specify the output file write frequency...(minutes) + out_dt = 60 ! minutes + +!Specify the number of output times to be contained within each output history file...(integer) +! SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!! +! SET = 1 WHEN RUNNING COUPLED TO WRF!!! + SPLIT_OUTPUT_COUNT = 1 + +! rst_typ = 1 : overwrite the soil variables from routing restart file. + rst_typ = 1 + +!Output netcdf file control + CHRTOUT_DOMAIN = 1 ! 0: nooutput. 1: Netcdf point timeseries output at all channel points + ! 2 : for fast output of stream flow variable. + CHRTOUT_GRID = 1 ! Netcdf grid of channel streamflow values + LSMOUT_DOMAIN = 0 ! Netcdf grid of variables passed between LSM and routing components + RTOUT_DOMAIN = 0 ! Netcdf grid of terrain routing variables on routing grid + output_gw = 0 ! Netcdf grid of GW + outlake = 0 ! Netcdf grid of lake + !0: no output. 1: point netcdf. 2: for fast output. + + rst_bi_in = 1 !0: use netcdf restart file. + !1: use parallel io for reading multiple restart files by each core. + rst_bi_out = 1 !0: use netcdf restart file. + !1: use parallel io for output multiple restart files. + + + +!Restart switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0) + RSTRT_SWC = 0 + +!Specify the minimum stream order to output to netcdf point file...(integer) +!Note: lower value of stream order produces more output. + order_to_write = 4 + +!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!! +!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes +!Note: This option is not yet active in Verion 1.0... +! WRF has this capability so be careful not to double apply the correction!!! + TERADJ_SOLAR = 0 + +!Specify the number of soil layers (integer) and the depth of the bottom of each layer (meters)... +! Notes: In Version 1 of WRF-Hydro these must be the same as in the namelist.input file +! Future versions will permit this to be different. + NSOIL=4 + ZSOIL8(1) = -0.10 + ZSOIL8(2) = -0.40 + ZSOIL8(3) = -1.00 + ZSOIL8(4) = -2.00 + +!Specify the grid spacing of the terrain routing grid...(meters) + DXRT = 100.0 + +!Specify the integer multiple between the land model grid and the terrain routing grid...(integer) + AGGFACTRT = 10 + +!Specify the routing model timestep...(seconds) + DTRT_CH = 60 + DTRT_TER = 10 + +!Switch activate subsurface routing...(0=no, 1=yes) + SUBRTSWCRT = 1 + +!Switch activate surface overland flow routing...(0=no, 1=yes) + OVRTSWCRT = 1 +!Sspecify overland flow routing Routing Option: 1=Seepest Descent(D8) 2=CASC2D + rt_option = 1 + +!Switch to activate channel routing: + CHANRTSWCRT = 1 +!Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded, 4=Rapid routing. + channel_option = 2 + +!Specify the reach file for reach-based routing options... + ! route_link_f = "../DOMAIN/Route_Link.bak.csv" + ! route_link_f = "../DOMAIN/Route_Link.csv" + route_link_f = "DOMAIN/Route_Link_2.nc" + +! simulated LAKE PARAM files, it will looking for LAKEPARM.TBL if this line has been commented. +route_lake_f = "../DOMAIN/LAKEPARM.nc" + +!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through) + GWBASESWCRT = 1 + +!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file) + GW_RESTART = 1 + +!Groundwater/baseflow mask specified on land surface model grid... +!Note: Only required if baseflow bucket model is active + gwbasmskfil = "../DOMAIN/gw_basns_geogrid.txt" + GWBUCKPARM_file = "DOMAIN/GWBUCKPARM_NHD.nc" + +! Realtime IOC run configuration option: 0=diagnostic, 1=analysis, 2=short-range, 3=medium-range, 4=long-range +iocflag=1 + +! User defined mapping, such NHDPlus +!0: deafult none. 1: yes +UDMP_OPT = 1 +udmap_file = "DOMAIN/spatialweights_geo_em.d02._100m_fixedj.nc" + +/ + +&NUDGING_nlist + +nudgingParamFile = "DOMAIN/nudgingParams.nc" +netwkReExFile = "DOMAIN/netwkReExFile.nc" + +!! Parallel input of nudging timeslice observation files? +readTimesliceParallel = .TRUE. + +! temporalPersistence defaults to true, only runs if necessary params present. +temporalPersistence = .FALSE. + +! nudgingLastObsFile defaults to '', which will look for nudgingLastObs.YYYY-mm-dd_HH:MM:SS.nc +! **AT THE INITALIZATION TIME OF THE RUN**. Set to a missing file to use no restart. +nudgingLastObsFile = 'notAFile.junk' + +/ diff --git a/wrfv2_fire/hydro/wrf_hydro_config b/wrfv2_fire/hydro/wrf_hydro_config new file mode 100755 index 00000000..47548324 --- /dev/null +++ b/wrfv2_fire/hydro/wrf_hydro_config @@ -0,0 +1,28 @@ +#!/usr/bin/perl +#input argument: Compiler/System sequential/parallel +#This is called by WRF configuration only. +if($#ARGV ne 1) { + print("Error: No such configuration for Hydro \n"); + exit(1); +} + $x = lc(shift(@ARGV)); + $paropt = lc(shift(@ARGV)); + + print("Configure option for Hydro : $x $paropt \n"); + if($x =~ "pgi") { + if($paropt eq 'serial') { system("./configure 1");} + else {system("./configure 2");} + } + if($x =~ "aix") { + if($paropt eq 'serial') { system("./configure 3");} + else {system("./configure 4");} + } + if($x =~ "gfortran") { + if($paropt eq 'serial') { system("./configure 5");} + else {system("./configure 6");} + } + if($x =~ "ifort") { + if($paropt eq 'serial') { system("./configure 7");} + else {system("./configure 8");} + } + diff --git a/wrfv2_fire/inc/.gitignore b/wrfv2_fire/inc/.gitignore new file mode 100644 index 00000000..14f1e0ed --- /dev/null +++ b/wrfv2_fire/inc/.gitignore @@ -0,0 +1,14 @@ +# This is the top-level .gitignore file for the "inc" directory for the WRF # +# Model # +# # +# Filenames and wildcards added below will not be tracked by git anywhere in # +# this directory or any of its subdirectories. Note that these rules will be # +# supplemented by rules in the top-level .gitignore file # +# # +# Ignored file types should include executables, build-time temporary files, # +# and other files which should not ever be added to the code repository. # +# # +# USE CAUTION WHEN ADDING WILDCARDS, as some builds use different filename # +# conventions than others # +############################################################################## +*.inc diff --git a/wrfv2_fire/inc/version_decl b/wrfv2_fire/inc/version_decl index c56cf50e..acf3c4f9 100644 --- a/wrfv2_fire/inc/version_decl +++ b/wrfv2_fire/inc/version_decl @@ -1 +1 @@ - CHARACTER (LEN=10) :: release_version = 'V3.9.1 ' + CHARACTER (LEN=10) :: release_version = 'V3.9.1.1 ' diff --git a/wrfv2_fire/test/em_real/.gitignore b/wrfv2_fire/test/em_real/.gitignore new file mode 100644 index 00000000..0d6de210 --- /dev/null +++ b/wrfv2_fire/test/em_real/.gitignore @@ -0,0 +1,27 @@ +# This is the top-level .gitignore file for the "test/em_real" directory # +# # +# Filenames and wildcards added below will not be tracked by git in this # +# directory. Note that these rules will be supplemented by rules in the # +# top-level .gitignore file # +# # +# The ignored files in this directory should include the files that are # +# linked in by the Makefile from the "run" directory at compile time. Thus, # +# this file may require ongoing maintenance as new capabilities are added. # +# # +# USE CAUTION WHEN ADDING WILDCARDS THAT YOU DO NOT IMPACT VERSIONED FILES # +############################################################################## +CAM* +CCN_ACTIVATE.BIN +CLM* +ETAMPNEW_DATA* +*.TBL +*DATA +aerosol* +*s_0_03_0_9 +*.asc +grib2map.tbl +gribmap.txt +ozone*formatted +tr49t67 +tr49t85 +tr67t85