diff --git a/README.rst b/README.rst index 43311a4..c240025 100644 --- a/README.rst +++ b/README.rst @@ -5,6 +5,18 @@ Model for Scale Adaptive River Transport The Model for Scale Adaptive River Transport, Mosart, is part of the Community Earth System Model. +IMPORTANT NOTE: MOSART is Obsolescent! + +MOSART is part of CESM3, but is obsolescent. + +We do not have support for creating input datasets for MOSART and +as such can NOT use MOSART for Paleo work. + +Longer term MOSART will be removed in future versions of CESM and the new model +mizuRoute will be used for Paleo work as well as present day. +It's also possible that external collaborators will support the use of MOSART +for present day climate even as mizuRoute becomes the default model for CESM. + See the CESM web site for documentation and information: http://www.cesm.ucar.edu diff --git a/cime_config/buildnml b/cime_config/buildnml index 56c8cb7..68dbebc 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -79,7 +79,7 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path #---------------------------------------------------- run_type = case.get_value("RUN_TYPE") - finidat_rtm = str(nmlgen.get_value("finidat_rtm")) + finidat = str(nmlgen.get_value("finidat")) if run_type == 'branch' or run_type == 'hybrid': run_refcase = case.get_value("RUN_REFCASE") run_refdate = case.get_value("RUN_REFDATE") @@ -90,17 +90,17 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path filename = "%s.mosart.r.%s-%s.nc" %(run_refcase, run_refdate, run_tod) if run_type == "hybrid": - nmlgen.add_default("finidat_rtm", value=filename, ignore_abs_path=True) + nmlgen.add_default("finidat", value=filename, ignore_abs_path=True) else: - nmlgen.add_default("nrevsn_rtm", value=filename) - elif finidat_rtm.strip() == '': - nmlgen.set_value('finidat_rtm', value=' ') + nmlgen.add_default("nrevsn", value=filename) + elif finidat.strip() == '': + nmlgen.set_value('finidat', value=' ') else: - if nmlgen.get_default('finidat_rtm') == 'UNSET': - nmlgen.add_default('finidat_rtm', value=' ', ignore_abs_path=True) + if nmlgen.get_default('finidat') == 'UNSET': + nmlgen.add_default('finidat', value=' ', ignore_abs_path=True) else: - nmlgen.add_default("finidat_rtm") + nmlgen.add_default("finidat") ncpl_base_period = case.get_value('NCPL_BASE_PERIOD') if ncpl_base_period == 'hour': @@ -131,8 +131,8 @@ def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path coupling_period = basedt // mosart_ncpl nmlgen.set_value("coupling_period", value=coupling_period) - if ( nmlgen.get_value("frivinp_rtm") == "UNSET" and config["mosart_mode"] != "NULL" ): - raise SystemExit("ERROR: Direction file is NOT set and is required when MOSART is active: frivinp_rtm") + if ( nmlgen.get_value("frivinp") == "UNSET" and config["mosart_mode"] != "NULL" ): + raise SystemExit("ERROR: Direction file is NOT set and is required when MOSART is active: frivinp") bypass_routing_option = nmlgen.get_value("bypass_routing_option") qgwl_runoff_option = nmlgen.get_value("qgwl_runoff_option") diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index 2e0d1e2..bcdb077 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -37,8 +37,9 @@ + R2000MOSART - 2000_SATM_DLND%LCPL_SICE_SOCN_MIZUROUTE_SGLC_SWAV + 2000_SATM_DLND%LCPL_SICE_SOCN_MOSART_SGLC_SWAV diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index 5ea8bd0..86f5224 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -8,20 +8,6 @@ - - logical - mosart - mosart_inparm - - .true. - .false. - - - If .true., turn on mosart flooding back to clm - Note that mosart flood is not supported in CESM1.1 - - - logical mosart @@ -61,30 +47,30 @@ - + char mosart mosart_inparm - opt,Xonly,Yonly + basin,1d,roundrobin - Xonly + roundrobin - sparse matrix mct setting. Xonly is bfb on different pe counts, - opt and Yonly might involve partial sums + Decomposition Option for mosart - - char + + logical mosart mosart_inparm - basin,1d,roundrobin - roundrobin + .false. - Decomposition Option for mosart + If true, add capability to have halo option for mosart fields. + In particular these can be used to create derivatives using halo values + from neighboring cells. @@ -115,7 +101,7 @@ - + char mosart mosart_inparm @@ -124,11 +110,12 @@ UNSET - Full pathname of initial rtm file + Full pathname of initial conditions file. If blank or UNSET Mosart will startup from + cold start initial conditions. - + char mosart mosart_inparm @@ -140,7 +127,7 @@ - + char mosart abs @@ -152,11 +139,11 @@ $DIN_LOC_ROOT/rof/mosart/MOSART_routing_0.125nldas2_cdf5_c200727.nc - Full pathname of input datafile for RTM. + Full pathname of input mosart datafile - + char(1000) history mosart_inparm @@ -168,7 +155,7 @@ - + char(1000) history mosart_inparm @@ -180,7 +167,7 @@ - + char(1000) history mosart_inparm @@ -192,7 +179,7 @@ - + char(1000) history mosart_inparm @@ -204,7 +191,7 @@ - + char(1000) history mosart_inparm @@ -216,7 +203,7 @@ - + char(1000) history mosart_inparm @@ -228,7 +215,7 @@ - + integer(6) history mosart_inparm @@ -240,7 +227,7 @@ - + integer(6) history mosart_inparm @@ -254,7 +241,7 @@ - + integer(6) history mosart_inparm @@ -268,4 +255,43 @@ + + char + mosart + mosart_inparm + + LIQ:ICE + + + Colon delimited string of mosart tracers. + + + + + char + mosart + mosart_inparm + + T:F + + + Colon delimited string of toggle to turn on Euler algorithm for + tracer name in mosart_tracers. + + + + + integer(6) + mosart + mosart_inparm + + -24 + + + Frequency to perform budget check. Similar to nhtfrq, + positive means in time steps, 0=monthly, negative means hours + (i.e. 24 means every 24 time-steps and -24 means every day + + + diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index b70990a..ce171cf 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -1,128 +1,131 @@ - + - - + + + + + - + - + - + + - + - - + + - + - + - + + - + - + - + + + - - - - - - - - - - + - + - + + - + - + - - + + + + + + - + - - - - - - - - - - + + - + - + + + - + - + + + + - + - + + + - + - + - + + diff --git a/cime_config/testdefs/testmods_dirs/mosart/decompOpts/include_user_mods b/cime_config/testdefs/testmods_dirs/mosart/decompOpts/include_user_mods new file mode 100644 index 0000000..fe0e18c --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/mosart/decompOpts/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/testdefs/testmods_dirs/mosart/decompOpts/user_nl_mosart b/cime_config/testdefs/testmods_dirs/mosart/decompOpts/user_nl_mosart index a172ec6..bdc5366 100644 --- a/cime_config/testdefs/testmods_dirs/mosart/decompOpts/user_nl_mosart +++ b/cime_config/testdefs/testmods_dirs/mosart/decompOpts/user_nl_mosart @@ -1,2 +1 @@ - smat_option = 'opt' decomp_option = '1d' diff --git a/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart b/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart index d60ef17..6dad334 100644 --- a/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart +++ b/cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart @@ -1,4 +1,4 @@ -! ice_runoff = .true. - rtmhist_ndens = 1,1,1 - rtmhist_nhtfrq =-24,-8 - rtmhist_mfilt = 1,1 +! ice_runoff = .true. + ndens = 1,1,1 + nhtfrq =-24,-8 + mfilt = 1,1 diff --git a/cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods b/cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods new file mode 100644 index 0000000..fe0e18c --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart b/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart index 84b6ee6..449ffb8 100644 --- a/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart +++ b/cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart @@ -1 +1 @@ - finidat_rtm = ' ' + finidat = ' ' diff --git a/cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods b/cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods new file mode 100644 index 0000000..fe0e18c --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods @@ -0,0 +1 @@ +../default diff --git a/cime_config/user_nl_mosart b/cime_config/user_nl_mosart index e8f3087..e7c8865 100644 --- a/cime_config/user_nl_mosart +++ b/cime_config/user_nl_mosart @@ -1,7 +1,7 @@ !---------------------------------------------------------------------------------- ! Users should add all user specific namelist changes below in the form of ! namelist_var = new_namelist_value -! NOTE: namelist variable rtm_tstep CAN ONLY be changed by modifying the value +! NOTE: namelist variable delt_mosart (the time-step) CAN ONLY be changed by modifying the value ! of the xml variable ROF_NCPL in env_run.xml !---------------------------------------------------------------------------------- diff --git a/docs/ChangeLog b/docs/ChangeLog index d1ce81d..444d6d9 100644 --- a/docs/ChangeLog +++ b/docs/ChangeLog @@ -1,3 +1,122 @@ +=============================================================== +Tag name: mosart1_1_02 +Originator(s): mvertens +Date: Jun 21, 2024 +One-line Summary: cism runoff will be now routed to ocn via mosart + +Enables CISM runoff to be routed to the ocean via mosart. + +All runoff from CISM will be routed directly to the outlet points +New fields will be advertised in the mosart cap +call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl_glc') +call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi_glc') + +Issues addressed: +Fixes #92 +Fixes #102 + +Testing: standard testing + izumi -- OK + cheyenne -- OK + +See https://github.com/ESCOMP/MOSART/pull/94 for more details + +=============================================================== +Tag name: mosart1_1_01 +Originator(s): mvertens +Date: Jun 06, 2024 +One-line Summary: major mosart refactor including addition of new halo capability + +Removed all references to rtm + +files have been renamed and namelists no longer contain rtm in the name + +New modularity: + +introduced new modules with new derived types and methods +mosart_control_type.F90 +mosart_tctl_type.F90 +mosart_tparameter_type.F90 +mosart_tspatialunit_type.F90 +mosart_tstatusflux_type.F90 + +the new modules modularize a lot of the complexity and variables that were previously found in RunOffMod.F90 and permit decomposition initialization to be more flexible and transparent. + +New halo capability + +Ability to have halo regions and communication using ESMF. This is needed for computing derivatives in upcoming new additions to MOSART. +New halo namelist - use_halo_option. When this is set to true halos can be activated. See the test_halo subroutine in mosart_control_type.F90 module. +Verified that the results for the halos are bfb identical regardless of the number of processors that are used. +-To set the values for the exclusive region that will be used in halo operations - you need to access the pointer as is done in the test_halo routine in mosart_control_type.F90: + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. + end do + + call ESMF_ArrayHalo(this%haloArray, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + +Issues addressed: +Fixes #93 "if (ierr /= PIO_NOERR)" will not be invoked unless PIO_BCAST_ERROR is explicitly set +Fixes #98 Change namelist items to remove "rtm" in the names of namelist variables +Fixes #97 Remove RTM in more of the MOSART code (filenames, subroutines, variables etc.) +Fixes #99 Add a new mosart_noresm testlist + +Testing: standard testing + izumi -- OK + cheyenne -- OK + +See https://github.com/ESCOMP/MOSART/pull/76 for more details + +=============================================================== +Tag name: mosart1_0_49 +Originator(s): mvertens +Date: Feb 02, 2024 +One-line Summary: Remove MCT, some cleanup and high level refactoring + +Removes all MCT references from the code and replaces them with ESMF routehandles and mapping calls +major changes to RtmMod.F90 along with other code cleanup described below + +RtmVar +Now contains new ESMF data types needed for the MOSART mapping + type(ESMF_Field) , public :: srcField + type(ESMF_Field) , public :: dstField + type(ESMF_RouteHandle) , public :: rh_dnstream + type(ESMF_RouteHandle) , public :: rh_direct + type(ESMF_RouteHandle) , public :: rh_eroutUp + +RtmMod: +now have two new init phases for mosart. The first init phase is now called MOSART_init1 and replaces Rtmini. This has mostly what was there before but moves the creation of all routehandles to the second init phase - MOSART_init2 which must be called after the mesh has been read in. Also - moved the section of code for MOSART_init2 to be right below the section for MOSART_init1. +removed the mapping for Smatp_dnstrm since it was not used and there is no reason to create a map that is not needed. The associated code that was commented out for this has also been removed. +renamed RtmRun to MOSART_run +new indentation +MOSART_physics.F90 +now using the computed routehandle rh_eroutUp +new indentation +Removed namelist variable do_rtmflood and xml variable MOSART_FLOOD_MODE. Also removed subroutine MOSART_FloodInit in RtmMod.F90 which was never activated and in fact the model aborted if you tried to invoke it. +Verified that this was no longer needed in consult with @swensosc. +masterproc -> mainproc +updated the MOSART testlist for derecho and betzy (betzy is a NorESM platform) and added a PFS test + +Issues resolved: + Resolves #65 -- Remove MCT + Resolves #75 -- masterproc to mainproc + Resolves #73 -- testlist to Derecho + Resolved #85 -- Remove RtmFileUtils + +Testing: standard testing + izumi -- PASS + cheyenne -- PASS (following change answers but determined to be OK) +ERP_D.f10_f10_mg37.I1850Clm50Bgc.derecho_intel.mosart-qgrwlOpts +PEM_D.f10_f10_mg37.I1850Clm50Sp.derecho_intel.mosart-inplacethreshold +SMS_D.f10_f10_mg37.I1850Clm50Bgc.derecho_intel.mosart-decompOpts + +(first two due to baseline not having history output, so rerunning shows b4b) +(Last one shows roundoff level answer changes) + +See https://github.com/ESCOMP/MOSART/pull/74 for more details + =============================================================== Tag name: mosart1_0_48 Originator(s): erik diff --git a/src/cpl/mct/mosart_cpl_indices.F90 b/src/cpl/mct/mosart_cpl_indices.F90 deleted file mode 100644 index 403db10..0000000 --- a/src/cpl/mct/mosart_cpl_indices.F90 +++ /dev/null @@ -1,91 +0,0 @@ -module mosart_cpl_indices - - !----------------------------------------------------------------------- - ! DESCRIPTION: - ! Module containing the indices for the fields passed between MOSART and - ! the driver. - !----------------------------------------------------------------------- - - ! USES: - implicit none - private ! By default make data private - - ! PUBLIC MEMBER FUNCTIONS: - public :: mosart_cpl_indices_set ! Set the coupler indices - - ! PUBLIC DATA MEMBERS: - integer, public :: index_x2r_Flrl_rofsur = 0 ! lnd->rof liquid surface runoff forcing from land - integer, public :: index_x2r_Flrl_rofgwl = 0 ! lnd->rof liquid gwl runoff from land - integer, public :: index_x2r_Flrl_rofsub = 0 ! lnd->rof liquid subsurface runoff from land - integer, public :: index_x2r_Flrl_rofdto = 0 ! lnd->rof liquid direct to ocean runoff - integer, public :: index_x2r_Flrl_rofi = 0 ! lnd->rof ice runoff forcing from land - integer, public :: index_x2r_Flrl_irrig = 0 ! lnd->rof fraction of volr to be removed for irrigation - integer, public :: nflds_x2r = 0 - - ! roff to driver (part of land for now) (optional if ROF is off) - integer, public :: index_r2x_Forr_rofl = 0 ! rof->ocn liquid runoff to ocean - integer, public :: index_r2x_Forr_rofi = 0 ! rof->ocn ice runoff to ocean - integer, public :: index_r2x_Flrr_flood = 0 ! rof->lnd flood runoff (>fthresh) back to land - integer, public :: index_r2x_Flrr_volr = 0 ! rof->lnd volr total volume back to land - integer, public :: index_r2x_Flrr_volrmch = 0 ! rof->lnd volr main channel back to land - integer, public :: nflds_r2x = 0 - -!======================================================================= -contains -!======================================================================= - - subroutine mosart_cpl_indices_set(flds_x2r, flds_r2x ) - - !----------------------------------------------------------------------- - ! Description: - ! Set the indices needed by the mosart model coupler interface. - ! (mosart -> ocn) and (mosart->lnd) - ! - use mct_mod, only: mct_aVect, mct_aVect_init, mct_avect_indexra - use mct_mod, only: mct_aVect_clean, mct_avect_nRattr - ! - ! Arguments: - character(len=*), intent(in) :: flds_x2r - character(len=*), intent(in) :: flds_r2x - ! - ! Local variables: - type(mct_aVect) :: avtmp ! temporary av - character(len=32) :: subname = 'mosart_cpl_indices_set' ! subroutine name - !----------------------------------------------------------------------- - - !------------------------------------------------------------- - ! driver -> mosart - !------------------------------------------------------------- - - call mct_aVect_init(avtmp, rList=flds_x2r, lsize=1) - - index_x2r_Flrl_rofsur = mct_avect_indexra(avtmp,'Flrl_rofsur') - index_x2r_Flrl_rofgwl = mct_avect_indexra(avtmp,'Flrl_rofgwl') - index_x2r_Flrl_rofsub = mct_avect_indexra(avtmp,'Flrl_rofsub') - index_x2r_Flrl_rofdto = mct_avect_indexra(avtmp,'Flrl_rofdto') - index_x2r_Flrl_rofi = mct_avect_indexra(avtmp,'Flrl_rofi') - index_x2r_Flrl_irrig = mct_avect_indexra(avtmp,'Flrl_irrig') - - nflds_x2r = mct_avect_nRattr(avtmp) - - call mct_aVect_clean(avtmp) - - !------------------------------------------------------------- - ! mosart -> driver - !------------------------------------------------------------- - - call mct_aVect_init(avtmp, rList=flds_r2x, lsize=1) - - index_r2x_Forr_rofl = mct_avect_indexra(avtmp,'Forr_rofl') - index_r2x_Forr_rofi = mct_avect_indexra(avtmp,'Forr_rofi') - index_r2x_Flrr_flood = mct_avect_indexra(avtmp,'Flrr_flood') - index_r2x_Flrr_volr = mct_avect_indexra(avtmp,'Flrr_volr') - index_r2x_Flrr_volrmch = mct_avect_indexra(avtmp,'Flrr_volrmch') - - nflds_r2x = mct_avect_nRattr(avtmp) - - call mct_aVect_clean(avtmp) - - end subroutine mosart_cpl_indices_set - -end module mosart_cpl_indices diff --git a/src/cpl/mct/mosart_import_export.F90 b/src/cpl/mct/mosart_import_export.F90 deleted file mode 100644 index 1ea0c88..0000000 --- a/src/cpl/mct/mosart_import_export.F90 +++ /dev/null @@ -1,194 +0,0 @@ -module mosart_import_export - - use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl - use shr_sys_mod , only : shr_sys_abort - use mosart_cpl_indices , only : index_x2r_Flrl_rofsur, index_x2r_Flrl_rofi - use mosart_cpl_indices , only : index_x2r_Flrl_rofgwl, index_x2r_Flrl_rofsub - use mosart_cpl_indices , only : index_x2r_Flrl_irrig - use mosart_cpl_indices , only : index_r2x_Forr_rofl, index_r2x_Forr_rofi - use mosart_cpl_indices , only : index_r2x_Flrr_flood - use mosart_cpl_indices , only : index_r2x_Flrr_volr, index_r2x_Flrr_volrmch - use RunoffMod , only : rtmCTL, TRunoff - use RtmVar , only : iulog, ice_runoff, nt_rtm, rtm_tracers - use RtmSpmd , only : masterproc, iam - use RtmTimeManager , only : get_nstep - - implicit none - - private ! except - - public :: mosart_import - public :: mosart_export - - integer ,parameter :: debug = 1 ! internal debug level - character(*),parameter :: F01 = "('(mosart_import_export) ',a,i5,2x,i8,2x,d21.14)" - -!=============================================================================== -contains -!=============================================================================== - - subroutine mosart_import( x2r ) - - !--------------------------------------------------------------------------- - ! Obtain the runoff input from the coupler - ! convert from kg/m2s to m3/s - ! - ! Arguments: - real(r8), intent(in) :: x2r(:,:) ! driver import state to mosart - ! - ! Local variables - integer :: n2, n, nt, begr, endr, nliq, nfrz - character(len=32), parameter :: sub = 'mosart_import' - !--------------------------------------------------------------------------- - - ! Note that ***runin*** are fluxes - - nliq = 0 - nfrz = 0 - do nt = 1,nt_rtm - if (trim(rtm_tracers(nt)) == 'LIQ') then - nliq = nt - endif - if (trim(rtm_tracers(nt)) == 'ICE') then - nfrz = nt - endif - enddo - if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(sub),': ERROR in rtm_tracers LIQ ICE ',nliq,nfrz,rtm_tracers - call shr_sys_abort() - endif - - begr = rtmCTL%begr - endr = rtmCTL%endr - do n = begr,endr - n2 = n - begr + 1 - - rtmCTL%qsur(n,nliq) = x2r(index_x2r_Flrl_rofsur,n2) * (rtmCTL%area(n)*0.001_r8) - rtmCTL%qsub(n,nliq) = x2r(index_x2r_Flrl_rofsub,n2) * (rtmCTL%area(n)*0.001_r8) - rtmCTL%qgwl(n,nliq) = x2r(index_x2r_Flrl_rofgwl,n2) * (rtmCTL%area(n)*0.001_r8) - - rtmCTL%qsur(n,nfrz) = x2r(index_x2r_Flrl_rofi ,n2) * (rtmCTL%area(n)*0.001_r8) - rtmCTL%qirrig(n) = x2r(index_x2r_Flrl_irrig,n2) * (rtmCTL%area(n)*0.001_r8) - - rtmCTL%qsub(n,nfrz) = 0.0_r8 - rtmCTL%qgwl(n,nfrz) = 0.0_r8 - enddo - - if (debug > 0 .and. masterproc .and. get_nstep() < 5) then - do n = begr,endr - write(iulog,F01)'import: nstep, n, Flrl_rofsur = ',get_nstep(),n,rtmCTL%qsur(n,nliq) - write(iulog,F01)'import: nstep, n, Flrl_rofsub = ',get_nstep(),n,rtmCTL%qsub(n,nliq) - write(iulog,F01)'import: nstep, n, Flrl_rofgwl = ',get_nstep(),n,rtmCTL%qgwl(n,nliq) - write(iulog,F01)'import: nstep, n, Flrl_rofi = ',get_nstep(),n,rtmCTL%qsur(n,nfrz) - write(iulog,F01)'import: nstep, n, Flrl_irrig = ',get_nstep(),n,rtmCTL%qirrig(n) - end do - end if - - end subroutine mosart_import - - !==================================================================================== - - subroutine mosart_export( r2x ) - - !--------------------------------------------------------------------------- - ! Send the runoff model export state to the coupler - ! convert from m3/s to kg/m2s - ! - ! Arguments: - real(r8), intent(out) :: r2x(:,:) ! mosart export state to driver - ! - ! Local variables - integer :: ni, n, nt, nliq, nfrz - logical,save :: first_time = .true. - character(len=32), parameter :: sub = 'mosart_export' - !--------------------------------------------------------------------------- - - nliq = 0 - nfrz = 0 - do nt = 1,nt_rtm - if (trim(rtm_tracers(nt)) == 'LIQ') then - nliq = nt - endif - if (trim(rtm_tracers(nt)) == 'ICE') then - nfrz = nt - endif - enddo - if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(sub),': ERROR in rtm_tracers LIQ ICE ',nliq,nfrz,rtm_tracers - call shr_sys_abort() - endif - - r2x(:,:) = 0._r8 - - if (first_time) then - if (masterproc) then - if ( ice_runoff )then - write(iulog,*)'Snow capping will flow out in frozen river runoff' - else - write(iulog,*)'Snow capping will flow out in liquid river runoff' - endif - endif - first_time = .false. - end if - - ni = 0 - if ( ice_runoff )then - ! separate liquid and ice runoff - do n = rtmCTL%begr,rtmCTL%endr - ni = ni + 1 - r2x(index_r2x_Forr_rofl,ni) = rtmCTL%direct(n,nliq) / (rtmCTL%area(n)*0.001_r8) - r2x(index_r2x_Forr_rofi,ni) = rtmCTL%direct(n,nfrz) / (rtmCTL%area(n)*0.001_r8) - if (rtmCTL%mask(n) >= 2) then - ! liquid and ice runoff are treated separately - this is what goes to the ocean - r2x(index_r2x_Forr_rofl,ni) = r2x(index_r2x_Forr_rofl,ni) + rtmCTL%runoff(n,nliq) / (rtmCTL%area(n)*0.001_r8) - r2x(index_r2x_Forr_rofi,ni) = r2x(index_r2x_Forr_rofi,ni) + rtmCTL%runoff(n,nfrz) / (rtmCTL%area(n)*0.001_r8) - if (ni > rtmCTL%lnumr) then - write(iulog,*) sub, ' : ERROR runoff count',n,ni - call shr_sys_abort( sub//' : ERROR runoff > expected' ) - endif - endif - end do - else - ! liquid and ice runoff added to liquid runoff, ice runoff is zero - do n = rtmCTL%begr,rtmCTL%endr - ni = ni + 1 - r2x(index_r2x_Forr_rofl,ni) = (rtmCTL%direct(n,nfrz)+rtmCTL%direct(n,nliq)) / (rtmCTL%area(n)*0.001_r8) - if (rtmCTL%mask(n) >= 2) then - r2x(index_r2x_Forr_rofl,ni) = r2x(index_r2x_Forr_rofl,ni) + & - (rtmCTL%runoff(n,nfrz)+rtmCTL%runoff(n,nliq)) / (rtmCTL%area(n)*0.001_r8) - if (ni > rtmCTL%lnumr) then - write(iulog,*) sub, ' : ERROR runoff count',n,ni - call shr_sys_abort( sub//' : ERROR runoff > expected' ) - endif - endif - end do - end if - - ! Flooding back to land, sign convention is positive in land->rof direction - ! so if water is sent from rof to land, the flux must be negative. - ni = 0 - do n = rtmCTL%begr, rtmCTL%endr - ni = ni + 1 - r2x(index_r2x_Flrr_flood,ni) = -rtmCTL%flood(n) / (rtmCTL%area(n)*0.001_r8) - !scs: is there a reason for the wr+wt rather than volr (wr+wt+wh)? - !r2x(index_r2x_Flrr_volr,ni) = (Trunoff%wr(n,nliq) + Trunoff%wt(n,nliq)) / rtmCTL%area(n) - - r2x(index_r2x_Flrr_volr,ni) = rtmCTL%volr(n,nliq)/ rtmCTL%area(n) - r2x(index_r2x_Flrr_volrmch,ni) = Trunoff%wr(n,nliq) / rtmCTL%area(n) - end do - - if (debug > 0 .and. masterproc .and. get_nstep() < 5) then - ni = 0 - do n = rtmCTL%begr, rtmCTL%endr - ni = ni + 1 - write(iulog,F01)'export: nstep, n, Flrr_flood = ',get_nstep(), n, r2x(index_r2x_Flrr_flood ,ni) - write(iulog,F01)'export: nstep, n, Flrr_volr = ',get_nstep(), n, r2x(index_r2x_Flrr_volr ,ni) - write(iulog,F01)'export: nstep, n, Flrr_volrmch = ',get_nstep(), n, r2x(index_r2x_Flrr_volrmch,ni) - write(iulog,F01)'export: nstep, n, Forr_rofl = ',get_nstep() ,n, r2x(index_r2x_Forr_rofl , ni) - write(iulog,F01)'export: nstep, n, Forr_rofi = ',get_nstep() ,n, r2x(index_r2x_Forr_rofi , ni) - end do - end if - - end subroutine mosart_export - -end module mosart_import_export diff --git a/src/cpl/mct/rof_comp_mct.F90 b/src/cpl/mct/rof_comp_mct.F90 deleted file mode 100644 index 56b4c90..0000000 --- a/src/cpl/mct/rof_comp_mct.F90 +++ /dev/null @@ -1,499 +0,0 @@ -module rof_comp_mct - - !---------------------------------------------------------------------------- - ! This is the MCT cap for MOSART - !---------------------------------------------------------------------------- - - use seq_flds_mod , only : seq_flds_x2r_fields, seq_flds_r2x_fields - use shr_flds_mod , only : shr_flds_dom_coord, shr_flds_dom_other - use shr_kind_mod , only : r8 => shr_kind_r8, CL => shr_kind_cl - use shr_file_mod , only : shr_file_setLogUnit, shr_file_setLogLevel, & - shr_file_getLogUnit, shr_file_getLogLevel, & - shr_file_getUnit, shr_file_setIO - use shr_const_mod , only : SHR_CONST_REARTH - use seq_cdata_mod , only : seq_cdata, seq_cdata_setptrs - use seq_timemgr_mod , only : seq_timemgr_EClockGetData, seq_timemgr_StopAlarmIsOn, & - seq_timemgr_RestartAlarmIsOn, seq_timemgr_EClockDateInSync - use seq_infodata_mod , only : seq_infodata_type, seq_infodata_GetData, seq_infodata_PutData, & - seq_infodata_start_type_start, seq_infodata_start_type_cont, & - seq_infodata_start_type_brnch - use seq_comm_mct , only : seq_comm_suffix, seq_comm_inst, seq_comm_name - use RunoffMod , only : rtmCTL, TRunoff - use RtmVar , only : rtmlon, rtmlat, ice_runoff, iulog, & - nsrStartup, nsrContinue, nsrBranch, & - inst_index, inst_suffix, inst_name, RtmVarSet, & - nt_rtm, rtm_tracers - use RtmSpmd , only : masterproc, mpicom_rof, npes, iam, RtmSpmdInit, ROFID - use RtmMod , only : Rtmini, Rtmrun, Rtminit_namelist - use RtmTimeManager , only : timemgr_setup, get_curr_date, get_step_size, advance_timestep - use perf_mod , only : t_startf, t_stopf, t_barrierf - - use mosart_import_export, only : mosart_import, mosart_export - use mosart_cpl_indices , only : mosart_cpl_indices_set - use mosart_cpl_indices , only : index_x2r_Flrl_rofsur, index_x2r_Flrl_rofi - use mosart_cpl_indices , only : index_x2r_Flrl_rofgwl, index_x2r_Flrl_rofsub - use mosart_cpl_indices , only : index_x2r_Flrl_irrig - use mosart_cpl_indices , only : index_r2x_Forr_rofl, index_r2x_Forr_rofi, index_r2x_Flrr_flood - use mosart_cpl_indices , only : index_r2x_Flrr_volr, index_r2x_Flrr_volrmch - - use mct_mod - use ESMF -! -! PUBLIC MEMBER FUNCTIONS: - implicit none - SAVE - private ! By default make data private -! -! PUBLIC MEMBER FUNCTIONS: - public :: rof_init_mct ! rof initialization - public :: rof_run_mct ! rof run phase - public :: rof_final_mct ! rof finalization/cleanup -! -! PUBLIC DATA MEMBERS: -! None -! -! PRIVATE MEMBER FUNCTIONS: - private :: rof_SetgsMap_mct ! Set the river runoff model MCT GS map - private :: rof_domain_mct ! Set the river runoff model domain information - -!=============================================================== -contains -!=============================================================== - - subroutine rof_init_mct( EClock, cdata_r, x2r_r, r2x_r, NLFilename) - - !--------------------------------------------------------------------------- - ! DESCRIPTION: - ! Initialize runoff model and obtain relevant atmospheric model arrays - ! back from (i.e. albedos, surface temperature and snow cover over land). - ! - ! !ARGUMENTS: - type(ESMF_Clock), intent(inout) :: EClock ! Input synchronization clock - type(seq_cdata), intent(inout) :: cdata_r ! Input runoff-model driver data - type(mct_aVect) , intent(inout) :: x2r_r ! River import state - type(mct_aVect), intent(inout) :: r2x_r ! River export state - character(len=*), optional, intent(in) :: NLFilename ! Namelist filename to read - ! - ! !LOCAL VARIABLES: - logical :: rof_prognostic = .true. ! flag - logical :: flood_present ! flag - integer :: mpicom_loc ! mpi communicator - type(mct_gsMap), pointer :: gsMap_rof ! runoff model MCT GS map - type(mct_gGrid), pointer :: dom_r ! runoff model domain - type(seq_infodata_type), pointer :: infodata ! CESM driver level info data - integer :: lsize ! size of attribute vector - integer :: g,i,j,n ! indices - logical :: exists ! true if file exists - integer :: nsrest ! restart type - integer :: ref_ymd ! reference date (YYYYMMDD) - integer :: ref_tod ! reference time of day (sec) - integer :: start_ymd ! start date (YYYYMMDD) - integer :: start_tod ! start time of day (sec) - integer :: stop_ymd ! stop date (YYYYMMDD) - integer :: stop_tod ! stop time of day (sec) - logical :: brnch_retain_casename ! flag if should retain the case name on a branch start type - integer :: lbnum ! input to memory diagnostic - integer :: shrlogunit,shrloglev ! old values for log unit and log level - integer :: begr, endr - character(len=CL) :: caseid ! case identifier name - character(len=CL) :: ctitle ! case description title - character(len=CL) :: starttype ! start-type (startup, continue, branch, hybrid) - character(len=CL) :: calendar ! calendar type name - character(len=CL) :: hostname ! hostname of machine running on - character(len=CL) :: version ! Model version - character(len=CL) :: username ! user running the model - character(len=CL) :: model_doi_url ! Web address for model Digital Object Identifier (DOI) - character(len=32), parameter :: sub = 'rof_init_mct' - character(len=*), parameter :: format = "('("//trim(sub)//") :',A)" - !--------------------------------------------------------------------------- - - ! Obtain cdata_r (initalized in ccsm_comp_mod.F90 in the call to - ! seq_cdata_init for cdata_rr) - call seq_cdata_setptrs(cdata_r, ID=ROFID, mpicom=mpicom_loc, & - gsMap=gsMap_rof, dom=dom_r, infodata=infodata) - - ! Determine attriute vector indices - call mosart_cpl_indices_set(seq_flds_x2r_fields, seq_flds_r2x_fields) - - ! Initialize mosart MPI communicator - call RtmSpmdInit(mpicom_loc) - -#if (defined _MEMTRACE) - if(masterproc) then - lbnum=1 - call memmon_dump_fort('memmon.out','rof_init_mct:start::',lbnum) - endif -#endif - - ! Initialize io log unit - inst_name = seq_comm_name(ROFID) - inst_index = seq_comm_inst(ROFID) - inst_suffix = seq_comm_suffix(ROFID) - - call shr_file_getLogUnit (shrlogunit) - if (masterproc) then - inquire(file='rof_modelio.nml'//trim(inst_suffix),exist=exists) - if (exists) then - iulog = shr_file_getUnit() - call shr_file_setIO('rof_modelio.nml'//trim(inst_suffix),iulog) - end if - write(iulog,format) "MOSART model initialization" - else - iulog = shrlogunit - end if - - call shr_file_getLogLevel(shrloglev) - call shr_file_setLogUnit (iulog) - - if (masterproc) then - write(iulog,*) ' mosart npes = ',npes - write(iulog,*) ' mosart iam = ',iam - write(iulog,*) ' inst_name = ',trim(inst_name) - endif - - ! Initialize mosart - call seq_timemgr_EClockGetData(EClock, & - start_ymd=start_ymd, & - start_tod=start_tod, ref_ymd=ref_ymd, & - ref_tod=ref_tod, stop_ymd=stop_ymd, & - stop_tod=stop_tod, & - calendar=calendar ) - - call seq_infodata_GetData(infodata, case_name=caseid, & - case_desc=ctitle, start_type=starttype, & - brnch_retain_casename=brnch_retain_casename, & - model_version=version, & - model_doi_url=model_doi_url, & - hostname=hostname, username=username) - - call timemgr_setup(calendar_in=calendar, & - start_ymd_in=start_ymd, start_tod_in=start_tod, & - ref_ymd_in=ref_ymd, ref_tod_in=ref_tod, & - stop_ymd_in=stop_ymd, stop_tod_in=stop_tod) - - if ( trim(starttype) == trim(seq_infodata_start_type_start)) then - nsrest = nsrStartup - else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then - nsrest = nsrContinue - else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then - nsrest = nsrBranch - else - call shr_sys_abort( sub//' ERROR: unknown starttype' ) - end if - - call RtmVarSet(caseid_in=caseid, ctitle_in=ctitle, & - brnch_retain_casename_in=brnch_retain_casename, & - nsrest_in=nsrest, version_in=version, & - model_doi_url_in=model_doi_url, & - hostname_in=hostname, username_in=username) - - ! Read namelist, grid and surface data - call Rtminit_namelist(flood_active=flood_present) - call Rtmini() - - if (rof_prognostic) then - ! Initialize memory for input state - begr = rtmCTL%begr - endr = rtmCTL%endr - - ! Initialize rof gsMap for ocean rof and land rof - call rof_SetgsMap_mct( mpicom_rof, ROFID, gsMap_rof) - - ! Initialize rof domain - lsize = mct_gsMap_lsize(gsMap_rof, mpicom_rof) - call rof_domain_mct( lsize, gsMap_rof, dom_r ) - - ! Initialize lnd -> mosart attribute vector - call mct_aVect_init(x2r_r, rList=seq_flds_x2r_fields, lsize=lsize) - call mct_aVect_zero(x2r_r) - - ! Initialize mosart -> ocn attribute vector - call mct_aVect_init(r2x_r, rList=seq_flds_r2x_fields, lsize=lsize) - call mct_aVect_zero(r2x_r) - - ! Create mct river runoff export state - call mosart_export( r2x_r%rattr ) - end if - - ! Fill in infodata - call seq_infodata_PutData( infodata, rof_present=rof_prognostic, rof_nx = rtmlon, rof_ny = rtmlat, & - rof_prognostic=rof_prognostic, rofice_present=.false.) - call seq_infodata_PutData( infodata, flood_present=flood_present) - - ! Reset shr logging to original values - call shr_file_setLogUnit (shrlogunit) - call shr_file_setLogLevel(shrloglev) - -#if (defined _MEMTRACE) - if(masterproc) then - write(iulog,*) TRIM(Sub) // ':end::' - lbnum=1 - call memmon_dump_fort('memmon.out','rof_int_mct:end::',lbnum) - call memmon_reset_addr() - endif -#endif - - end subroutine rof_init_mct - -!--------------------------------------------------------------------------- - - subroutine rof_run_mct( EClock, cdata_r, x2r_r, r2x_r) - - !------------------------------------------------------- - ! DESCRIPTION: - ! Run runoff model - - ! ARGUMENTS: - implicit none - type(ESMF_Clock) , intent(inout) :: EClock ! Input synchronization clock from driver - type(seq_cdata) , intent(inout) :: cdata_r ! Input driver data for runoff model - type(mct_aVect) , intent(inout) :: x2r_r ! Import state from runoff model - type(mct_aVect) , intent(inout) :: r2x_r ! Export state from runoff model - - ! LOCAL VARIABLES: - integer :: ymd_sync, ymd ! current date (YYYYMMDD) - integer :: yr_sync, yr ! current year - integer :: mon_sync, mon ! current month - integer :: day_sync, day ! current day - integer :: tod_sync, tod ! current time of day (sec) - logical :: rstwr ! .true. ==> write restart file before returning - logical :: nlend ! .true. ==> signaling last time-step - integer :: shrlogunit,shrloglev ! old values for share log unit and log level - integer :: lsize ! local size - integer :: lbnum ! input to memory diagnostic - integer :: g,i ! indices - type(mct_gGrid), pointer :: dom_r ! runoff model domain - type(seq_infodata_type),pointer :: infodata ! CESM information from the driver - real(r8), pointer :: data(:) ! temporary - character(len=32) :: rdate ! date char string for restart file names - character(len=32), parameter :: sub = "rof_run_mct" - !------------------------------------------------------- - -#if (defined _MEMTRACE) - if(masterproc) then - lbnum=1 - call memmon_dump_fort('memmon.out','rof_run_mct:start::',lbnum) - endif -#endif - - ! Reset shr logging to my log file - call shr_file_getLogUnit (shrlogunit) - call shr_file_getLogLevel(shrloglev) - call shr_file_setLogUnit (iulog) - - ! Determine time of next atmospheric shortwave calculation - call seq_timemgr_EClockGetData(EClock, & - curr_ymd=ymd, curr_tod=tod_sync, & - curr_yr=yr_sync, curr_mon=mon_sync, curr_day=day_sync) - - ! Map MCT to land data type (output is totrunin, subrunin) - call t_startf ('lc_rof_import') - call mosart_import( x2r_r%rattr ) - call t_stopf ('lc_rof_import') - - ! Run mosart (input is *runin, output is rtmCTL%runoff) - ! First advance mosart time step - write(rdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr_sync,mon_sync,day_sync,tod_sync - nlend = seq_timemgr_StopAlarmIsOn( EClock ) - rstwr = seq_timemgr_RestartAlarmIsOn( EClock ) - call advance_timestep() - call Rtmrun(rstwr,nlend,rdate) - - ! Map roff data to MCT datatype (input is rtmCTL%runoff, output is r2x_r) - call t_startf ('lc_rof_export') - call mosart_export( r2x_r%rattr ) - call t_stopf ('lc_rof_export') - - ! Check that internal clock is in sync with master clock - call get_curr_date( yr, mon, day, tod ) - ymd = yr*10000 + mon*100 + day - tod = tod - if ( .not. seq_timemgr_EClockDateInSync( EClock, ymd, tod ) )then - call seq_timemgr_EclockGetData( EClock, curr_ymd=ymd_sync, curr_tod=tod_sync ) - write(iulog,*)' mosart ymd=',ymd ,' mosart tod= ',tod - write(iulog,*)'sync ymd=',ymd_sync,' sync tod= ',tod_sync - call shr_sys_abort( sub//":: MOSART clock is not in sync with Master Sync clock" ) - end if - - ! Reset shr logging to my original values - call shr_file_setLogUnit (shrlogunit) - call shr_file_setLogLevel(shrloglev) - -#if (defined _MEMTRACE) - if(masterproc) then - lbnum=1 - call memmon_dump_fort('memmon.out','rof_run_mct:end::',lbnum) - call memmon_reset_addr() - endif -#endif - - end subroutine rof_run_mct - -!=============================================================================== - - subroutine rof_final_mct( EClock, cdata_r, x2r_r, r2x_r) - - !----------------------------------------------------- - ! DESCRIPTION: - ! Finalize rof surface model - ! - ! ARGUMENTS: - implicit none - type(ESMF_Clock) , intent(inout) :: EClock ! Input synchronization clock from driver - type(seq_cdata) , intent(inout) :: cdata_r ! Input driver data for runoff model - type(mct_aVect) , intent(inout) :: x2r_r ! Import state from runoff model - type(mct_aVect) , intent(inout) :: r2x_r ! Export state from runoff model - !----------------------------------------------------- - - ! fill this in - end subroutine rof_final_mct - -!=============================================================================== - - subroutine rof_SetgsMap_mct( mpicom_r, ROFID, gsMap_rof) - - !----------------------------------------------------- - ! DESCRIPTION: - ! Set the MCT GS map for the runoff model - ! - ! ARGUMENTS: - implicit none - integer , intent(in) :: mpicom_r ! MPI communicator for rof model - integer , intent(in) :: ROFID ! Land model identifier - type(mct_gsMap), intent(inout) :: gsMap_rof ! MCT gsmap for runoff -> land data - ! - ! LOCAL VARIABLES - integer,allocatable :: gindex(:) ! indexing for runoff grid cells - integer :: n, ni ! indices - integer :: lsize,gsize ! size of runoff data and number of grid cells - integer :: begr, endr ! beg, end runoff indices - integer :: ier ! error code - character(len=32), parameter :: sub = 'rof_SetgsMap_mct' - !----------------------------------------------------- - - begr = rtmCTL%begr - endr = rtmCTL%endr - lsize = rtmCTL%lnumr - gsize = rtmlon*rtmlat - - ! Check - ni = 0 - do n = begr,endr - ni = ni + 1 - if (ni > lsize) then - write(iulog,*) sub, ' : ERROR runoff count',n,ni,rtmCTL%lnumr - call shr_sys_abort( sub//' ERROR: runoff > expected' ) - endif - end do - if (ni /= lsize) then - write(iulog,*) sub, ' : ERROR runoff total count',ni,rtmCTL%lnumr - call shr_sys_abort( sub//' ERROR: runoff not equal to expected' ) - endif - - ! Determine gsmap_rof - allocate(gindex(lsize),stat=ier) - ni = 0 - do n = begr,endr - ni = ni + 1 - gindex(ni) = rtmCTL%gindex(n) - end do - call mct_gsMap_init( gsMap_rof, gindex, mpicom_r, ROFID, lsize, gsize ) - deallocate(gindex) - - end subroutine rof_SetgsMap_mct - -!=============================================================================== - - subroutine rof_domain_mct( lsize, gsMap_r, dom_r ) - - !----------------------------------------------------- - ! - ! !DESCRIPTION: - ! Send the runoff model domain information to the coupler - ! - ! !ARGUMENTS: - implicit none - integer , intent(in) :: lsize ! Size of runoff domain information - type(mct_gsMap), intent(inout) :: gsMap_r ! Output MCT GS map for runoff model - type(mct_ggrid), intent(out) :: dom_r ! Domain information from the runoff model - ! - ! LOCAL VARIABLES - integer :: n, ni ! index - integer , pointer :: idata(:) ! temporary - real(r8), pointer :: data(:) ! temporary - real(r8) :: re = SHR_CONST_REARTH*0.001_r8 ! radius of earth (km) - character(len=32), parameter :: sub = 'rof_domain_mct' - !----------------------------------------------------- - - ! lat/lon in degrees, area in radians^2, mask is 1 (land), 0 (non-land) - ! Note that in addition land carries around landfrac for the purposes of domain checking - call mct_gGrid_init( GGrid=dom_r, CoordChars=trim(shr_flds_dom_coord), & - OtherChars=trim(shr_flds_dom_other), lsize=lsize ) - - ! Allocate memory - allocate(data(lsize)) - - ! Determine global gridpoint number attribute, GlobGridNum, which is set automatically by MCT - call mct_gsMap_orderedPoints(gsMap_r, iam, idata) - call mct_gGrid_importIAttr(dom_r,'GlobGridNum',idata,lsize) - - ! Determine domain (numbering scheme is: West to East and South to North to South pole) - ! Initialize attribute vector with special value - data(:) = -9999.0_R8 - call mct_gGrid_importRAttr(dom_r,"lat" ,data,lsize) - call mct_gGrid_importRAttr(dom_r,"lon" ,data,lsize) - call mct_gGrid_importRAttr(dom_r,"area" ,data,lsize) - call mct_gGrid_importRAttr(dom_r,"aream",data,lsize) - data(:) = 0.0_R8 - call mct_gGrid_importRAttr(dom_r,"mask" ,data,lsize) - - ! Determine bounds numbering consistency - ni = 0 - do n = rtmCTL%begr,rtmCTL%endr - ni = ni + 1 - if (ni > rtmCTL%lnumr) then - write(iulog,*) sub, ' : ERROR runoff count',n,ni,rtmCTL%lnumr - call shr_sys_abort( sub//' ERROR: runoff > expected' ) - end if - end do - if (ni /= rtmCTL%lnumr) then - write(iulog,*) sub, ' : ERROR runoff total count',ni,rtmCTL%lnumr - call shr_sys_abort( sub//' ERROR: runoff not equal to expected' ) - endif - - ! Fill in correct values for domain components - ni = 0 - do n = rtmCTL%begr,rtmCTL%endr - ni = ni + 1 - data(ni) = rtmCTL%lonc(n) - end do - call mct_gGrid_importRattr(dom_r,"lon",data,lsize) - - ni = 0 - do n = rtmCTL%begr,rtmCTL%endr - ni = ni + 1 - data(ni) = rtmCTL%latc(n) - end do - call mct_gGrid_importRattr(dom_r,"lat",data,lsize) - - ni = 0 - do n = rtmCTL%begr,rtmCTL%endr - ni = ni + 1 - data(ni) = rtmCTL%area(n)*1.0e-6_r8/(re*re) - end do - call mct_gGrid_importRattr(dom_r,"area",data,lsize) - - ni = 0 - do n = rtmCTL%begr,rtmCTL%endr - ni = ni + 1 - data(ni) = 1.0_r8 - end do - call mct_gGrid_importRattr(dom_r,"mask",data,lsize) - call mct_gGrid_importRattr(dom_r,"frac",data,lsize) - - deallocate(data) - deallocate(idata) - - end subroutine rof_domain_mct - -end module rof_comp_mct diff --git a/src/cpl/nuopc/rof_comp_nuopc.F90 b/src/cpl/nuopc/rof_comp_nuopc.F90 index 396dff5..29b75d4 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -4,39 +4,51 @@ module rof_comp_nuopc ! This is the NUOPC cap for MOSART !---------------------------------------------------------------------------- - use ESMF - use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize - use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeSet - use NUOPC_Model , only : model_routine_SS => SetServices - use NUOPC_Model , only : SetVM - use NUOPC_Model , only : model_label_Advance => label_Advance - use NUOPC_Model , only : model_label_DataInitialize => label_DataInitialize - use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock - use NUOPC_Model , only : model_label_Finalize => label_Finalize - use NUOPC_Model , only : NUOPC_ModelGet - use shr_kind_mod , only : R8=>SHR_KIND_R8, CL=>SHR_KIND_CL - use shr_sys_mod , only : shr_sys_abort - use shr_file_mod , only : shr_file_getlogunit, shr_file_setlogunit - use shr_cal_mod , only : shr_cal_noleap, shr_cal_gregorian, shr_cal_ymd2date - use RtmVar , only : rtmlon, rtmlat, iulog - use RtmVar , only : nsrStartup, nsrContinue, nsrBranch - use RtmVar , only : inst_index, inst_suffix, inst_name, RtmVarSet - use RtmSpmd , only : RtmSpmdInit, masterproc, mpicom_rof, ROFID, iam, npes - use RunoffMod , only : rtmCTL - use RtmMod , only : Rtminit_namelist, Rtmini, Rtmrun - use RtmTimeManager , only : timemgr_setup, get_curr_date, get_step_size, advance_timestep - use perf_mod , only : t_startf, t_stopf, t_barrierf - use rof_import_export , only : advertise_fields, realize_fields - use rof_import_export , only : import_fields, export_fields - use nuopc_shr_methods , only : chkerr, state_setscalar, state_getscalar, state_diagnose, alarmInit - use nuopc_shr_methods , only : set_component_logging, get_component_instance, log_clock_advance -!$ use omp_lib , only : omp_set_num_threads + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSetEntryPoint, ESMF_State, & + ESMF_Clock, ESMF_ClockGet, ESMF_ClockSet, ESMF_ClockAdvance, & + ESMF_ClockGetAlarm, ESMF_ClockGetNextTime, ESMF_ClockGet, ESMF_ClockGetAlarm, & + ESMF_ClockGetAlarmList, ESMF_Alarm, ESMF_AlarmSet, ESMF_AlarmIsRinging, & + ESMF_AlarmRingerOff, ESMF_Time, ESMF_TimeGet, ESMF_TimeInterval, & + ESMF_CalKind_Flag, ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN, & + ESMF_Mesh, ESMF_MeshCreate, ESMF_FILEFORMAT_ESMFMESH, & + ESMF_DistGrid, ESMF_DistGridCreate, & + ESMF_MethodRemove,ESMF_VM, ESMF_VMGet, ESMF_LogFoundError, & + ESMF_SUCCESS, ESMF_LogWrite, ESMF_FAILURE, ESMF_LogFoundError, & + ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_ERROR, ESMF_LOGMSG_INFO, & + ESMF_METHOD_INITIALIZE, ESMF_ALARMLIST_ALL, & + operator(==), operator(/=), operator(<), operator(<=), & + operator(>), operator(>=), operator(-), operator(+) + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet, NUOPC_CompAttributeSet + use NUOPC_Model , only : model_routine_SS => SetServices, & + model_label_Advance => label_Advance, & + model_label_DataInitialize => label_DataInitialize, & + model_label_SetRunClock => label_SetRunClock, & + model_label_Finalize => label_Finalize, & + NUOPC_ModelGet + use shr_kind_mod , only : R8=>SHR_KIND_R8, CL=>SHR_KIND_CL, CS=>SHR_KIND_CS + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use shr_cal_mod , only : shr_cal_noleap, shr_cal_gregorian, shr_cal_ymd2date + use mosart_vars , only : nsrStartup, nsrContinue, nsrBranch, & + inst_index, inst_suffix, inst_name, & + mainproc, mpicom_rof, iam, npes, iulog, vm, & + nsrest, caseid, ctitle, version, hostname, username + use mosart_data , only : ctl + use mosart_driver , only : mosart_read_namelist, mosart_init1, mosart_init2, mosart_run + use mosart_timemanager , only : timemgr_setup, get_curr_date, get_step_size, advance_timestep + use mosart_io , only : ncd_pio_init + use mosart_restfile , only : brnch_retain_casename + use rof_import_export , only : import_fields, export_fields, advertise_fields, realize_fields + use nuopc_shr_methods , only : chkerr, state_setscalar, state_getscalar, state_diagnose, alarmInit, & + set_component_logging, get_component_instance, log_clock_advance + use perf_mod , only : t_startf, t_stopf, t_barrierf + implicit none private ! except ! Module routines public :: SetServices - public :: SetVM private :: InitializeP0 private :: InitializeAdvertise private :: InitializeRealize @@ -53,10 +65,7 @@ module rof_comp_nuopc integer :: flds_scalar_index_nx = 0 integer :: flds_scalar_index_ny = 0 integer :: flds_scalar_index_nextsw_cday = 0._r8 - - logical :: do_rtmflood integer :: nthrds - integer , parameter :: debug = 1 character(*), parameter :: modName = "(rof_comp_nuopc)" character(*), parameter :: u_FILE_u = & @@ -149,10 +158,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) type(ESMF_Time) :: refTime ! Ref time type(ESMF_TimeInterval) :: timeStep ! Model timestep type(ESMF_CalKind_Flag) :: esmf_caltype ! esmf calendar type - type(ESMF_VM) :: vm ! esmf virtual machine - integer :: mpicom - character(CL) :: cvalue - character(len=CL) :: logmsg integer :: ref_ymd ! reference date (YYYYMMDD) integer :: ref_tod ! reference time of day (sec) integer :: yy,mm,dd ! Temporaries for time query @@ -162,21 +167,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer :: stop_tod ! stop time of day (sec) integer :: curr_ymd ! Start date (YYYYMMDD) integer :: curr_tod ! Start time of day (sec) - logical :: flood_present ! flag - logical :: rof_prognostic ! flag integer :: shrlogunit ! original log unit - integer :: n,ni ! indices - integer :: nsrest ! restart type + integer :: n ! indices character(CL) :: calendar ! calendar type name - character(CL) :: username ! user name - character(CL) :: caseid ! case identifier name - character(CL) :: ctitle ! case description title - character(CL) :: hostname ! hostname of machine running on - character(CL) :: model_version ! model version character(CL) :: starttype ! start-type (startup, continue, branch, hybrid) - character(CL) :: stdname, shortname ! needed for advertise - logical :: brnch_retain_casename ! flag if should retain the case name on a branch start type logical :: isPresent, isSet + character(CL) :: cvalue + character(len=CL) :: logmsg character(len=*), parameter :: subname=trim(modName)//':(InitializeAdvertise) ' character(len=*), parameter :: format = "('("//trim(subname)//") :',A)" !------------------------------------------------------------------------------- @@ -188,23 +185,15 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! generate local mpi comm !---------------------------------------------------------------------------- + ! Note vm is in mosart_vars.F90 and can be shared among components + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, mpiCommunicator=mpicom, rc=rc) + call ESMF_VMGet(vm, mpiCommunicator=mpicom_rof, peCount=npes, localPet=iam, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !---------------------------------------------------------------------------- - ! initialize MOSART MPI communicator - !---------------------------------------------------------------------------- - - ! The following call initializees the module variable mpicom_rof in RtmSpmd - call RtmSpmdInit(mpicom) - - ! Set ROFID - needed for the mosart code that requires MCT - call NUOPC_CompAttributeGet(gcomp, name='MCTID', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) ROFID ! convert from string to integer + mainproc = (iam == 0) !---------------------------------------------------------------------------- ! determine instance information @@ -219,8 +208,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! reset shr logging to my log file !---------------------------------------------------------------------------- - call set_component_logging(gcomp, masterproc, iulog, shrlogunit, rc) + call set_component_logging(gcomp, mainproc, iulog, shrlogunit, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call shr_log_setLogUnit (iulog) !---------------------------------------------------------------------------- ! advertise fields @@ -280,7 +270,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxNextSwCday') endif - ! Need to run the initial phase of rtm here to determine if do_flood is true in order to + ! Need to run the initial phase of mosart here in order to ! get the advertise phase correct !---------------------- @@ -300,9 +290,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) starttype + if ( trim(starttype) == trim('startup')) then + nsrest = nsrStartup + else if (trim(starttype) == trim('continue') ) then + nsrest = nsrContinue + else if (trim(starttype) == trim('branch')) then + nsrest = nsrBranch + else + call shr_sys_abort( subname//' ERROR: unknown starttype' ) + end if + call NUOPC_CompAttributeGet(gcomp, name='model_version', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) model_version + read(cvalue,*) version call NUOPC_CompAttributeGet(gcomp, name='hostname', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -366,68 +366,30 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! Read namelist, grid and surface data !---------------------- - if (masterproc) then + if (mainproc) then write(iulog,*) "MOSART river model initialization" write(iulog,*) ' mosart npes = ',npes write(iulog,*) ' mosart iam = ',iam write(iulog,*) ' inst_name = ',trim(inst_name) endif - ! Initialize RtmVar module variables - ! TODO: the following strings must not be hard-wired - must have module variables - ! like seq_infodata_start_type_type - maybe another entry in seq_flds_mod? - if ( trim(starttype) == trim('startup')) then - nsrest = nsrStartup - else if (trim(starttype) == trim('continue') ) then - nsrest = nsrContinue - else if (trim(starttype) == trim('branch')) then - nsrest = nsrBranch - else - call shr_sys_abort( subname//' ERROR: unknown starttype' ) - end if - - call RtmVarSet(& - caseid_in=caseid, & - ctitle_in=ctitle, & - brnch_retain_casename_in=brnch_retain_casename, & - nsrest_in=nsrest, & - version_in=model_version, & - hostname_in=hostname, & - username_in=username) - !---------------------- - ! Initialize Mosart + ! Read in mosart namelist !---------------------- - ! - Read in mosart namelist - ! - Initialize mosart time manager - ! - Initialize number of mosart tracers - ! - Read input data (river direction file) (global) - ! - Deriver gridbox edges (global) - ! - Determine mosart ocn/land mask (global) - ! - Compute total number of basins and runoff ponts - ! - Compute river basins, actually compute ocean outlet gridcell - ! - Allocate basins to pes - ! - Count and distribute cells to rglo2gdc (determine rtmCTL%begr, rtmCTL%endr) - ! - Adjust area estimation from DRT algorithm for those outlet grids - ! - useful for grid-based representation only - ! - need to compute areas where they are not defined in input file - ! - Initialize runoff datatype (rtmCTL) - - call Rtminit_namelist(do_rtmflood) + call mosart_read_namelist() !---------------------------------------------------------------------------- ! Now advertise fields !---------------------------------------------------------------------------- - call advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) + call advertise_fields(gcomp, flds_scalar_name, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------------------------- ! Reset shr logging to original values !---------------------------------------------------------------------------- - call shr_file_setLogUnit (shrlogunit) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end subroutine InitializeAdvertise @@ -445,7 +407,6 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! local variables type(ESMF_Mesh) :: Emesh - type(ESMF_DistGrid) :: DistGrid ! esmf global index space descriptor type(ESMF_VM) :: vm integer , allocatable :: gindex(:) ! global index space on my processor integer :: lbnum ! input to memory diagnostic @@ -455,6 +416,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) integer :: n,ni integer :: localPet integer :: localPeCount + integer :: rofid ! component id for pio character(len=*), parameter :: subname=trim(modName)//':(InitializeRealize) ' !--------------------------------------------------------------------------- @@ -462,13 +424,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + call shr_log_setLogUnit (iulog) + !---------------------------------------------------------------------------- ! Reset shr logging to my log file !---------------------------------------------------------------------------- - call shr_file_getLogUnit (shrlogunit) - call shr_file_setLogUnit (iulog) - call ESMF_GridCompGet(gcomp, vm=vm, localPet=localPet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) @@ -487,41 +448,70 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) else nthrds = localPeCount endif - !$ call omp_set_num_threads(nthrds) #if (defined _MEMTRACE) - if (masterproc) then + if (mainproc) then lbnum=1 call memmon_dump_fort('memmon.out','rof_comp_nuopc_InitializeRealize:start::',lbnum) endif #endif - call Rtmini() + + !------------------------------------------------------- + ! Initialize mosart pio + !------------------------------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name='MCTID', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) rofid ! convert from string to integer + + call ncd_pio_init(rofid) + + !------------------------------------------------------- + ! Call first phase of mosart initialization (set decomp, grid) + !------------------------------------------------------- + + ! - Initialize mosart time manager + ! - Initialize number of mosart tracers + ! - Read input data (river direction file) (global) + ! - Deriver gridbox edges (global) + ! - Determine mosart ocn/land mask (global) + ! - Compute total number of basins and runoff ponts + ! - Compute river basins, actually compute ocean outlet gridcell + ! - Allocate basins to pes + ! - Count and distribute cells to rglo2gdc (determine ctl%begr, ctl%endr) + ! - Adjust area estimation from DRT algorithm for those outlet grids + ! - useful for grid-based representation only + ! - need to compute areas where they are not defined in input file + + call mosart_init1(rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + !-------------------------------- ! generate the mesh and realize fields !-------------------------------- ! determine global index array - lsize = rtmCTL%endr - rtmCTL%begr + 1 + lsize = ctl%endr - ctl%begr + 1 allocate(gindex(lsize)) ni = 0 - do n = rtmCTL%begr,rtmCTL%endr + do n = ctl%begr,ctl%endr ni = ni + 1 - gindex(ni) = rtmCTL%gindex(n) + gindex(ni) = ctl%gindex(n) end do ! create distGrid from global index array - DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + ctl%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(gindex) ! read in the mesh call NUOPC_CompAttributeGet(gcomp, name='mesh_rof', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (masterproc) then + if (mainproc) then write(iulog,*)'mesh file for domain is ',trim(cvalue) end if - EMesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, elementDistgrid=Distgrid, rc=rc) + EMesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, elementDistgrid=ctl%Distgrid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- @@ -531,19 +521,29 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + !------------------------------------------------------- + ! Initialize mosart maps and restart + ! This must be called after the ESMF mesh is read in + !------------------------------------------------------- + + call t_startf('mosarti_mosart_init') + call mosart_init2(Emesh, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosarti_mosart_init') + !-------------------------------- ! Create MOSART export state !-------------------------------- - call export_fields(gcomp, rc) + call export_fields(gcomp, ctl%begr, ctl%endr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Set global grid size scalars in export state - call State_SetScalar(dble(rtmlon), flds_scalar_index_nx, exportState, & + call State_SetScalar(dble(ctl%nlon), flds_scalar_index_nx, exportState, & flds_scalar_name, flds_scalar_num, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetScalar(dble(rtmlat), flds_scalar_index_ny, exportState, & + call State_SetScalar(dble(ctl%nlat), flds_scalar_index_ny, exportState, & flds_scalar_name, flds_scalar_num, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -551,7 +551,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! Reset shr logging !---------------------------------------------------------------------------- - call shr_file_setLogUnit (shrlogunit) + call shr_log_setLogUnit (shrlogunit) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) !-------------------------------- @@ -564,7 +564,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) endif #if (defined _MEMTRACE) - if(masterproc) then + if(mainproc) then write(iulog,*) TRIM(Sub) // ':end::' lbnum=1 call memmon_dump_fort('memmon.out','rof_comp_nuopc_InitializeRealize:end::',lbnum) @@ -605,19 +605,18 @@ subroutine ModelAdvance(gcomp, rc) logical :: nlend ! .true. ==> signaling last time-step integer :: lbnum ! input to memory diagnostic integer :: g,i ! indices - character(len=32) :: rdate ! date char string for restart file names + character(len=CS) :: rdate ! date char string for restart file names character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' !------------------------------------------------------- rc = ESMF_SUCCESS call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - call shr_file_getLogUnit (shrlogunit) - call shr_file_setLogUnit (iulog) -!$ call omp_set_num_threads(nthrds) + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (iulog) #if (defined _MEMTRACE) - if(masterproc) then + if(mainproc) then lbnum=1 call memmon_dump_fort('memmon.out','mosart_comp_nuopc_ModelAdvance:start::',lbnum) endif @@ -668,7 +667,7 @@ subroutine ModelAdvance(gcomp, rc) call t_startf ('lc_mosart_import') - call import_fields(gcomp, rc) + call import_fields(gcomp, ctl%begr, ctl%endr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf ('lc_mosart_import') @@ -689,24 +688,22 @@ subroutine ModelAdvance(gcomp, rc) call shr_cal_ymd2date(yr_sync, mon_sync, day_sync, ymd_sync) write(rdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr_sync, mon_sync, day_sync, tod_sync - ! Advance mosart time step then run MOSART (export data is in rtmCTL and Trunoff data types) + ! Advance mosart time step then run MOSART (export data is in ctl and Trunoff data types) call advance_timestep() - call Rtmrun(rstwr, nlend, rdate) + call mosart_run(ctl%begr, ctl%endr, ctl%ntracers, rstwr, nlend, rdate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- ! Pack export state to mediator !-------------------------------- - ! (input is rtmCTL%runoff, output is r2x) call t_startf ('lc_rof_export') - - call export_fields(gcomp, rc) + call export_fields(gcomp, ctl%begr, ctl%endr, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call t_stopf ('lc_rof_export') !-------------------------------- - ! Check that internal clock is in sync with master clock + ! Check that internal clock is in sync with sync clock !-------------------------------- dtime = get_step_size() @@ -718,7 +715,7 @@ subroutine ModelAdvance(gcomp, rc) write(iulog,*)' mosart ymd=',ymd ,' mosart tod= ',tod write(iulog,*)' sync ymd=',ymd_sync,' sync tod= ',tod_sync rc = ESMF_FAILURE - call ESMF_LogWrite(subname//" MOSART clock not in sync with Master Sync clock",ESMF_LOGMSG_ERROR) + call ESMF_LogWrite(subname//" MOSART clock not in sync with sync clock",ESMF_LOGMSG_ERROR) end if !-------------------------------- @@ -740,10 +737,10 @@ subroutine ModelAdvance(gcomp, rc) ! Reset shr logging to my original values !-------------------------------- - call shr_file_setLogUnit (shrlogunit) + call shr_log_setLogUnit (shrlogunit) #if (defined _MEMTRACE) - if(masterproc) then + if(mainproc) then lbnum=1 call memmon_dump_fort('memmon.out','mosart_comp_nuopc_ModelAdvance:end::',lbnum) call memmon_reset_addr() @@ -896,7 +893,7 @@ subroutine ModelFinalize(gcomp, rc) rc = ESMF_SUCCESS call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - if (masterproc) then + if (mainproc) then write(iulog,F91) write(iulog,F00) 'MOSART: end of main integration loop' write(iulog,F91) diff --git a/src/cpl/nuopc/rof_import_export.F90 b/src/cpl/nuopc/rof_import_export.F90 index 30fe4fb..08dbc60 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -1,20 +1,18 @@ module rof_import_export - use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet - use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError - use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag - use ESMF , only : operator(/=), operator(==) - use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected - use NUOPC_Model , only : NUOPC_ModelGet - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_abort - use nuopc_shr_methods , only : chkerr - use RunoffMod , only : rtmCTL, TRunoff, TUnit - use RtmVar , only : iulog, nt_rtm, rtm_tracers - use RtmSpmd , only : masterproc, mpicom_rof - use RtmTimeManager , only : get_nstep - use nuopc_shr_methods , only : chkerr + use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet + use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError + use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag + use ESMF , only : operator(/=), operator(==) + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + use mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff + use mosart_data , only : ctl, TRunoff, TUnit + use mosart_timemanager , only : get_nstep + use nuopc_shr_methods , only : chkerr implicit none private ! except @@ -29,6 +27,7 @@ module rof_import_export private :: state_getimport private :: state_setexport private :: check_for_nans + private :: fldchk type fld_list_type character(len=128) :: stdname @@ -45,7 +44,6 @@ module rof_import_export real(r8), allocatable :: mod2med_areacor(:) real(r8), allocatable :: med2mod_areacor(:) - integer ,parameter :: debug = 0 ! internal debug level character(*),parameter :: F01 = "('(mosart_import_export) ',a,i5,2x,i8,2x,d21.14)" character(*),parameter :: u_FILE_u = & __FILE__ @@ -54,18 +52,16 @@ module rof_import_export contains !=============================================================================== - subroutine advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) + subroutine advertise_fields(gcomp, flds_scalar_name, rc) ! input/output variables type(ESMF_GridComp) :: gcomp character(len=*) , intent(in) :: flds_scalar_name - logical , intent(in) :: do_rtmflood integer , intent(out) :: rc ! local variables type(ESMF_State) :: importState type(ESMF_State) :: exportState - character(ESMF_MAXSTR) :: stdname character(ESMF_MAXSTR) :: cvalue ! Character string read from driver attribute logical :: isPresent ! Atribute is present logical :: isSet ! Atribute is set @@ -87,9 +83,12 @@ subroutine advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) read(cvalue,*) flds_r2l_stream_channel_depths + call fldlist_add(fldsFrRof_num, fldsFrRof, trim(flds_scalar_name)) call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi') + call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl_glc') + call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi_glc') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_flood') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volr') call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volrmch') @@ -114,6 +113,10 @@ subroutine advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') + if ( ctl%rof_from_glc ) then + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofl') ! liq runoff from glc + call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofi') ! ice runoff from glc + end if do n = 1,fldsToRof_num call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & @@ -202,9 +205,9 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) allocate(mod2med_areacor(numOwnedElements)) allocate(med2mod_areacor(numOwnedElements)) n = 0 - do g = rtmCTL%begr,rtmCTL%endr + do g = ctl%begr,ctl%endr n = n + 1 - model_areas(n) = rtmCTL%area(g)*1.0e-6_r8/(re*re) + model_areas(n) = ctl%area(g)*1.0e-6_r8/(re*re) mod2med_areacor(n) = model_areas(n) / mesh_areas(n) med2mod_areacor(n) = mesh_areas(n) / model_areas(n) end do @@ -220,17 +223,26 @@ subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom_rof) call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom_rof) - if (masterproc) then + if (mainproc) then write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOSART' write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOSART' end if + if (fldchk(importState, 'Fgrg_rofl') .and. fldchk(importState, 'Fgrg_rofl')) then + ctl%rof_from_glc = .true. + else + ctl%rof_from_glc = .false. + end if + if (mainproc) then + write(iulog,'(A,l1)') trim(subname) //' rof from glc is ',ctl%rof_from_glc + end if + end subroutine realize_fields !=============================================================================== - subroutine import_fields( gcomp, rc ) + subroutine import_fields( gcomp, begr, endr, rc ) !--------------------------------------------------------------------------- ! Obtain the runoff input from the mediator and convert from kg/m2s to m3/s @@ -238,13 +250,13 @@ subroutine import_fields( gcomp, rc ) ! input/output variables type(ESMF_GridComp) :: gcomp + integer, intent(in) :: begr, endr integer, intent(out) :: rc ! Local variables type(ESMF_State) :: importState integer :: n,nt - integer :: begr, endr - integer :: nliq, nfrz + integer :: nliq, nice character(len=*), parameter :: subname='(rof_import_export:import_fields)' !--------------------------------------------------------------------------- @@ -255,76 +267,75 @@ subroutine import_fields( gcomp, rc ) call NUOPC_ModelGet(gcomp, importState=importState, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Set tracers - nliq = 0 - nfrz = 0 - do nt = 1,nt_rtm - if (trim(rtm_tracers(nt)) == 'LIQ') nliq = nt - if (trim(rtm_tracers(nt)) == 'ICE') nfrz = nt - enddo - if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(subname),': ERROR in rtm_tracers LIQ ICE ',nliq,nfrz,rtm_tracers - call shr_sys_abort() - endif - - begr = rtmCTL%begr - endr = rtmCTL%endr + nliq = ctl%nt_liq + nice = ctl%nt_ice ! determine output array and scale by unit convertsion ! NOTE: the call to state_getimport will convert from input kg/m2s to m3/s - call state_getimport(importState, 'Flrl_rofsur', begr, endr, rtmCTL%area, output=rtmCTL%qsur(:,nliq), & + call state_getimport(importState, 'Flrl_rofsur', begr, endr, ctl%area, output=ctl%qsur(:,nliq), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_rofsub', begr, endr, rtmCTL%area, output=rtmCTL%qsub(:,nliq), & + call state_getimport(importState, 'Flrl_rofsub', begr, endr, ctl%area, output=ctl%qsub(:,nliq), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_rofgwl', begr, endr, rtmCTL%area, output=rtmCTL%qgwl(:,nliq), & + call state_getimport(importState, 'Flrl_rofgwl', begr, endr, ctl%area, output=ctl%qgwl(:,nliq), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_rofi', begr, endr, rtmCTL%area, output=rtmCTL%qsur(:,nfrz), & + call state_getimport(importState, 'Flrl_rofi', begr, endr, ctl%area, output=ctl%qsur(:,nice), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'Flrl_irrig', begr, endr, rtmCTL%area, output=rtmCTL%qirrig(:), & + call state_getimport(importState, 'Flrl_irrig', begr, endr, ctl%area, output=ctl%qirrig(:), & do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - rtmCTL%qsub(begr:endr, nfrz) = 0.0_r8 - rtmCTL%qgwl(begr:endr, nfrz) = 0.0_r8 + ctl%qsub(begr:endr, nice) = 0.0_r8 + ctl%qgwl(begr:endr, nice) = 0.0_r8 + + if (ctl%rof_from_glc) then + call state_getimport(importState, 'Fgrg_rofl', begr, endr, ctl%area, output=ctl%qglc_liq(:), & + do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Fgrg_rofi', begr, endr, ctl%area, output=ctl%qglc_ice(:), & + do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + ctl%qglc_liq(:) = 0._r8 + ctl%qglc_ice(:) = 0._r8 + end if end subroutine import_fields !==================================================================================== - subroutine export_fields (gcomp, rc) + subroutine export_fields (gcomp, begr, endr, rc) !--------------------------------------------------------------------------- ! Send the runoff model export state to the mediator and convert from m3/s to kg/m2s !--------------------------------------------------------------------------- - ! uses - use RtmVar, only : ice_runoff - ! input/output/variables type(ESMF_GridComp) :: gcomp + integer, intent(in) :: begr, endr integer, intent(out) :: rc ! Local variables - type(ESMF_State) :: exportState - integer :: n,nt - integer :: begr,endr - integer :: nliq, nfrz - real(r8), pointer :: rofl(:) - real(r8), pointer :: rofi(:) - real(r8), pointer :: flood(:) - real(r8), pointer :: volr(:) - real(r8), pointer :: volrmch(:) - real(r8), pointer :: tdepth(:) - real(r8), pointer :: tdepth_max(:) - logical, save :: first_time = .true. + type(ESMF_State) :: exportState + integer :: n,nt + integer :: nliq, nice + real(r8) :: rofl(begr:endr) + real(r8) :: rofi(begr:endr) + real(r8) :: rofl_glc(begr:endr) + real(r8) :: rofi_glc(begr:endr) + real(r8) :: flood(begr:endr) + real(r8) :: volr(begr:endr) + real(r8) :: volrmch(begr:endr) + real(r8) :: tdepth(begr:endr) + real(r8) :: tdepth_max(begr:endr) + logical, save :: first_time = .true. character(len=*), parameter :: subname='(rof_import_export:export_fields)' !--------------------------------------------------------------------------- @@ -336,19 +347,11 @@ subroutine export_fields (gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Set tracers - nliq = 0 - nfrz = 0 - do nt = 1,nt_rtm - if (trim(rtm_tracers(nt)) == 'LIQ') nliq = nt - if (trim(rtm_tracers(nt)) == 'ICE') nfrz = nt - enddo - if (nliq == 0 .or. nfrz == 0) then - write(iulog,*) trim(subname),': ERROR in rtm_tracers LIQ ICE ',nliq,nfrz,rtm_tracers - call shr_sys_abort() - endif + nliq = ctl%nt_liq + nice = ctl%nt_ice if (first_time) then - if (masterproc) then + if (mainproc) then if ( ice_runoff )then write(iulog,*)'Snow capping will flow out in frozen river runoff' else @@ -358,50 +361,42 @@ subroutine export_fields (gcomp, rc) first_time = .false. end if - begr = rtmCTL%begr - endr = rtmCTL%endr - - allocate(rofl(begr:endr)) - allocate(rofi(begr:endr)) - allocate(flood(begr:endr)) - allocate(volr(begr:endr)) - allocate(volrmch(begr:endr)) - if ( flds_r2l_stream_channel_depths )then - allocate(tdepth(begr:endr)) - allocate(tdepth_max(begr:endr)) - end if - if ( ice_runoff )then ! separate liquid and ice runoff do n = begr,endr - rofl(n) = rtmCTL%direct(n,nliq) / (rtmCTL%area(n)*0.001_r8) - rofi(n) = rtmCTL%direct(n,nfrz) / (rtmCTL%area(n)*0.001_r8) - if (rtmCTL%mask(n) >= 2) then + rofl(n) = ctl%direct(n,nliq) / (ctl%area(n)*0.001_r8) + rofi(n) = ctl%direct(n,nice) / (ctl%area(n)*0.001_r8) + if (ctl%mask(n) >= 2) then ! liquid and ice runoff are treated separately - this is what goes to the ocean - rofl(n) = rofl(n) + rtmCTL%runoff(n,nliq) / (rtmCTL%area(n)*0.001_r8) - rofi(n) = rofi(n) + rtmCTL%runoff(n,nfrz) / (rtmCTL%area(n)*0.001_r8) + rofl(n) = rofl(n) + ctl%runoff(n,nliq) / (ctl%area(n)*0.001_r8) + rofi(n) = rofi(n) + ctl%runoff(n,nice) / (ctl%area(n)*0.001_r8) end if end do else ! liquid and ice runoff added to liquid runoff, ice runoff is zero do n = begr,endr - rofl(n) = (rtmCTL%direct(n,nfrz) + rtmCTL%direct(n,nliq)) / (rtmCTL%area(n)*0.001_r8) - if (rtmCTL%mask(n) >= 2) then - rofl(n) = rofl(n) + (rtmCTL%runoff(n,nfrz) + rtmCTL%runoff(n,nliq)) / (rtmCTL%area(n)*0.001_r8) + rofl(n) = (ctl%direct(n,nice) + ctl%direct(n,nliq)) / (ctl%area(n)*0.001_r8) + if (ctl%mask(n) >= 2) then + rofl(n) = rofl(n) + (ctl%runoff(n,nice) + ctl%runoff(n,nliq)) / (ctl%area(n)*0.001_r8) endif rofi(n) = 0._r8 end do end if + do n = begr,endr + rofl_glc(n) = ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) + rofi_glc(n) = ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) + end do + ! Flooding back to land, sign convention is positive in land->rof direction ! so if water is sent from rof to land, the flux must be negative. ! scs: is there a reason for the wr+wt rather than volr (wr+wt+wh)? - ! volr(n) = (Trunoff%wr(n,nliq) + Trunoff%wt(n,nliq)) / rtmCTL%area(n) + ! volr(n) = (Trunoff%wr(n,nliq) + Trunoff%wt(n,nliq)) / ctl%area(n) do n = begr, endr - flood(n) = -rtmCTL%flood(n) / (rtmCTL%area(n)*0.001_r8) - volr(n) = rtmCTL%volr(n,nliq)/ rtmCTL%area(n) - volrmch(n) = Trunoff%wr(n,nliq) / rtmCTL%area(n) + flood(n) = -ctl%flood(n) / (ctl%area(n)*0.001_r8) + volr(n) = ctl%volr(n,nliq)/ ctl%area(n) + volrmch(n) = Trunoff%wr(n,nliq) / ctl%area(n) if ( flds_r2l_stream_channel_depths )then tdepth(n) = Trunoff%yt(n,nliq) ! assume height to width ratio is the same for tributaries and main channel @@ -415,6 +410,12 @@ subroutine export_fields (gcomp, rc) call state_setexport(exportState, 'Forr_rofi', begr, endr, input=rofi, do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport(exportState, 'Forr_rofl_glc', begr, endr, input=rofl_glc, do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call state_setexport(exportState, 'Forr_rofi_glc', begr, endr, input=rofi_glc, do_area_correction=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_setexport(exportState, 'Flrr_flood', begr, endr, input=flood, do_area_correction=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -432,21 +433,6 @@ subroutine export_fields (gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (debug > 0 .and. masterproc .and. get_nstep() < 5) then - do n = begr,endr - write(iulog,F01)'export: nstep, n, Flrr_flood = ',get_nstep(), n, flood(n) - write(iulog,F01)'export: nstep, n, Flrr_volr = ',get_nstep(), n, volr(n) - write(iulog,F01)'export: nstep, n, Flrr_volrmch = ',get_nstep(), n, volrmch(n) - write(iulog,F01)'export: nstep, n, Forr_rofl = ',get_nstep() ,n, rofl(n) - write(iulog,F01)'export: nstep, n, Forr_rofi = ',get_nstep() ,n, rofi(n) - end do - end if - - deallocate(rofl, rofi, flood, volr, volrmch) - if ( flds_r2l_stream_channel_depths ) then - deallocate(tdepth, tdepth_max) - end if - end subroutine export_fields !=============================================================================== @@ -671,7 +657,7 @@ subroutine check_for_nans(array, fname, begg) use shr_infnan_mod, only : isnan => shr_infnan_isnan ! input/output variables - real(r8), pointer :: array(:) + real(r8) , pointer :: array(:) character(len=*) , intent(in) :: fname integer , intent(in) :: begg @@ -693,4 +679,25 @@ subroutine check_for_nans(array, fname, begg) end if end subroutine check_for_nans + !=============================================================================== + logical function fldchk(state, fldname) + ! ---------------------------------------------- + ! Determine if field with fldname is in the input state + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: fldname + + ! local variables + type(ESMF_StateItem_Flag) :: itemFlag + ! ---------------------------------------------- + call ESMF_StateGet(state, trim(fldname), itemFlag) + if (itemflag /= ESMF_STATEITEM_NOTFOUND) then + fldchk = .true. + else + fldchk = .false. + endif + end function fldchk + end module rof_import_export diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 deleted file mode 100644 index a2d327f..0000000 --- a/src/riverroute/MOSART_physics_mod.F90 +++ /dev/null @@ -1,710 +0,0 @@ -!----------------------------------------------------------------------- -! -MODULE MOSART_physics_mod -! Description: core code of MOSART. Can be incoporated within any land model via a interface module -! -! Developed by Hongyi Li, 12/29/2011. -! REVISION HISTORY: -! Jan 2012, only consider land surface water routing, no parallel computation -! May 2012, modified to be coupled with CLM -!----------------------------------------------------------------------- - -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_const_mod , only : SHR_CONST_REARTH, SHR_CONST_PI - use shr_sys_mod , only : shr_sys_abort - use RtmVar , only : iulog, barrier_timers, nt_rtm, rtm_tracers - use RunoffMod , only : Tctl, TUnit, TRunoff, TPara, rtmCTL - use RunoffMod , only : SMatP_eroutUp, avsrc_eroutUp, avdst_eroutUp - use RtmSpmd , only : masterproc, mpicom_rof - use perf_mod , only: t_startf, t_stopf - use mct_mod - - implicit none - private - - real(r8), parameter :: TINYVALUE = 1.0e-14_r8 ! double precision variable has a significance of about 16 decimal digits - integer :: nt ! loop indices - real(r8), parameter :: SLOPE1def = 0.1_r8 ! here give it a small value in order to avoid the abrupt change of hydraulic radidus etc. - real(r8) :: sinatanSLOPE1defr ! 1.0/sin(atan(slope1)) - - public Euler - public updatestate_hillslope - public updatestate_subnetwork - public updatestate_mainchannel - public hillsloperouting - public subnetworkrouting - public mainchannelrouting - -!----------------------------------------------------------------------- - -! !PUBLIC MEMBER FUNCTIONS: - contains - -!----------------------------------------------------------------------- - subroutine Euler - ! !DESCRIPTION: solve the ODEs with Euler algorithm - implicit none - - integer :: iunit, m, k, unitUp, cnt, ier !local index - real(r8) :: temp_erout, localDeltaT - real(r8) :: negchan - - !------------------ - ! hillslope - !------------------ - - call t_startf('mosartr_hillslope') - do nt=1,nt_rtm - if (TUnit%euler_calc(nt)) then - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%mask(iunit) > 0) then - call hillslopeRouting(iunit,nt,Tctl%DeltaT) - TRunoff%wh(iunit,nt) = TRunoff%wh(iunit,nt) + TRunoff%dwh(iunit,nt) * Tctl%DeltaT - call UpdateState_hillslope(iunit,nt) - TRunoff%etin(iunit,nt) = (-TRunoff%ehout(iunit,nt) + TRunoff%qsub(iunit,nt)) * TUnit%area(iunit) * TUnit%frac(iunit) - endif - end do - endif - end do - call t_stopf('mosartr_hillslope') - - TRunoff%flow = 0._r8 - TRunoff%erout_prev = 0._r8 - TRunoff%eroutup_avg = 0._r8 - TRunoff%erlat_avg = 0._r8 - negchan = 9999.0_r8 - do m=1,Tctl%DLevelH2R - - !--- accumulate/average erout at prior timestep (used in eroutUp calc) for budget analysis - do nt=1,nt_rtm - if (TUnit%euler_calc(nt)) then - do iunit=rtmCTL%begr,rtmCTL%endr - TRunoff%erout_prev(iunit,nt) = TRunoff%erout_prev(iunit,nt) + TRunoff%erout(iunit,nt) - end do - end if - end do - - !------------------ - ! subnetwork - !------------------ - - call t_startf('mosartr_subnetwork') - TRunoff%erlateral(:,:) = 0._r8 - do nt=1,nt_rtm - if (TUnit%euler_calc(nt)) then - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%mask(iunit) > 0) then - localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_t(iunit) - do k=1,TUnit%numDT_t(iunit) - call subnetworkRouting(iunit,nt,localDeltaT) - TRunoff%wt(iunit,nt) = TRunoff%wt(iunit,nt) + TRunoff%dwt(iunit,nt) * localDeltaT - call UpdateState_subnetwork(iunit,nt) - TRunoff%erlateral(iunit,nt) = TRunoff%erlateral(iunit,nt)-TRunoff%etout(iunit,nt) - end do ! numDT_t - TRunoff%erlateral(iunit,nt) = TRunoff%erlateral(iunit,nt) / TUnit%numDT_t(iunit) - endif - end do ! iunit - endif ! euler_calc - end do ! nt - call t_stopf('mosartr_subnetwork') - - !------------------ - ! upstream interactions - !------------------ - - if (barrier_timers) then - call t_startf('mosartr_SMeroutUp_barrier') - call mpi_barrier(mpicom_rof,ier) - call t_stopf('mosartr_SMeroutUp_barrier') - endif - - call t_startf('mosartr_SMeroutUp') - TRunoff%eroutUp = 0._r8 -#ifdef NO_MCT - do iunit=rtmCTL%begr,rtmCTL%endr - do k=1,TUnit%nUp(iunit) - unitUp = Tunit%iUp(iunit,k) - do nt=1,nt_rtm - TRunoff%eroutUp(iunit,nt) = TRunoff%eroutUp(iunit,nt) + TRunoff%erout(unitUp,nt) - end do - end do - end do -#else - !--- copy erout into avsrc_eroutUp --- - call mct_avect_zero(avsrc_eroutUp) - cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - do nt = 1,nt_rtm - avsrc_eroutUp%rAttr(nt,cnt) = TRunoff%erout(iunit,nt) - enddo - enddo - call mct_avect_zero(avdst_eroutUp) - - call mct_sMat_avMult(avsrc_eroutUp, sMatP_eroutUp, avdst_eroutUp) - - !--- add mapped eroutUp to TRunoff --- - cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - do nt = 1,nt_rtm - TRunoff%eroutUp(iunit,nt) = avdst_eroutUp%rAttr(nt,cnt) - enddo - enddo -#endif - call t_stopf('mosartr_SMeroutUp') - - TRunoff%eroutup_avg = TRunoff%eroutup_avg + TRunoff%eroutUp - TRunoff%erlat_avg = TRunoff%erlat_avg + TRunoff%erlateral - - !------------------ - ! channel routing - !------------------ - - call t_startf('mosartr_chanroute') - do nt=1,nt_rtm - if (TUnit%euler_calc(nt)) then - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%mask(iunit) > 0) then - localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_r(iunit) - temp_erout = 0._r8 - do k=1,TUnit%numDT_r(iunit) - call mainchannelRouting(iunit,nt,localDeltaT) - TRunoff%wr(iunit,nt) = TRunoff%wr(iunit,nt) + TRunoff%dwr(iunit,nt) * localDeltaT -! check for negative channel storage -! if(TRunoff%wr(iunit,1) < -1.e-10) then -! write(iulog,*) 'Negative channel storage! ', iunit, TRunoff%wr(iunit,1) -! call shr_sys_abort('mosart: negative channel storage') -! end if - call UpdateState_mainchannel(iunit,nt) - temp_erout = temp_erout + TRunoff%erout(iunit,nt) ! erout here might be inflow to some downstream subbasin, so treat it differently than erlateral - end do - temp_erout = temp_erout / TUnit%numDT_r(iunit) - TRunoff%erout(iunit,nt) = temp_erout - TRunoff%flow(iunit,nt) = TRunoff%flow(iunit,nt) - TRunoff%erout(iunit,nt) - endif - end do ! iunit - endif ! euler_calc - end do ! nt - negchan = min(negchan, minval(TRunoff%wr(:,:))) - - call t_stopf('mosartr_chanroute') - end do - -! check for negative channel storage - if (negchan < -1.e-10) then - write(iulog,*) 'Warning: Negative channel storage found! ',negchan -! call shr_sys_abort('mosart: negative channel storage') - endif - TRunoff%flow = TRunoff%flow / Tctl%DLevelH2R - TRunoff%erout_prev = TRunoff%erout_prev / Tctl%DLevelH2R - TRunoff%eroutup_avg = TRunoff%eroutup_avg / Tctl%DLevelH2R - TRunoff%erlat_avg = TRunoff%erlat_avg / Tctl%DLevelH2R - - end subroutine Euler - -!----------------------------------------------------------------------- - - subroutine hillslopeRouting(iunit, nt, theDeltaT) - ! !DESCRIPTION: Hillslope routing considering uniform runoff generation across hillslope - implicit none - - integer, intent(in) :: iunit, nt - real(r8), intent(in) :: theDeltaT - -! !TRunoff%ehout(iunit,nt) = -CREHT(TUnit%hslp(iunit), TUnit%nh(iunit), TUnit%Gxr(iunit), TRunoff%yh(iunit,nt)) - TRunoff%ehout(iunit,nt) = -CREHT_nosqrt(TUnit%hslpsqrt(iunit), TUnit%nh(iunit), TUnit%Gxr(iunit), TRunoff%yh(iunit,nt)) - if(TRunoff%ehout(iunit,nt) < 0._r8 .and. & - TRunoff%wh(iunit,nt) + (TRunoff%qsur(iunit,nt) + TRunoff%ehout(iunit,nt)) * theDeltaT < TINYVALUE) then - TRunoff%ehout(iunit,nt) = -(TRunoff%qsur(iunit,nt) + TRunoff%wh(iunit,nt) / theDeltaT) - end if - TRunoff%dwh(iunit,nt) = (TRunoff%qsur(iunit,nt) + TRunoff%ehout(iunit,nt)) - - end subroutine hillslopeRouting - -!----------------------------------------------------------------------- - - subroutine subnetworkRouting(iunit,nt,theDeltaT) - ! !DESCRIPTION: subnetwork channel routing - implicit none - integer, intent(in) :: iunit,nt - real(r8), intent(in) :: theDeltaT - -! !if(TUnit%tlen(iunit) <= 1e100_r8) then ! if no tributaries, not subnetwork channel routing - if(TUnit%tlen(iunit) <= TUnit%hlen(iunit)) then ! if no tributaries, not subnetwork channel routing - TRunoff%etout(iunit,nt) = -TRunoff%etin(iunit,nt) - else -! !TRunoff%vt(iunit,nt) = CRVRMAN(TUnit%tslp(iunit), TUnit%nt(iunit), TRunoff%rt(iunit,nt)) - TRunoff%vt(iunit,nt) = CRVRMAN_nosqrt(TUnit%tslpsqrt(iunit), TUnit%nt(iunit), TRunoff%rt(iunit,nt)) - TRunoff%etout(iunit,nt) = -TRunoff%vt(iunit,nt) * TRunoff%mt(iunit,nt) - if(TRunoff%wt(iunit,nt) + (TRunoff%etin(iunit,nt) + TRunoff%etout(iunit,nt)) * theDeltaT < TINYVALUE) then - TRunoff%etout(iunit,nt) = -(TRunoff%etin(iunit,nt) + TRunoff%wt(iunit,nt)/theDeltaT) - if(TRunoff%mt(iunit,nt) > 0._r8) then - TRunoff%vt(iunit,nt) = -TRunoff%etout(iunit,nt)/TRunoff%mt(iunit,nt) - end if - end if - end if - TRunoff%dwt(iunit,nt) = TRunoff%etin(iunit,nt) + TRunoff%etout(iunit,nt) - -! check stability -! if(TRunoff%vt(iunit,nt) < -TINYVALUE .or. TRunoff%vt(iunit,nt) > 30) then -! write(iulog,*) "Numerical error in subnetworkRouting, ", iunit,nt,TRunoff%vt(iunit,nt) -! end if - - end subroutine subnetworkRouting - -!----------------------------------------------------------------------- - - subroutine mainchannelRouting(iunit, nt, theDeltaT) - ! !DESCRIPTION: main channel routing - implicit none - integer, intent(in) :: iunit, nt - real(r8), intent(in) :: theDeltaT - - if(Tctl%RoutingMethod == 1) then - call Routing_KW(iunit, nt, theDeltaT) - else if(Tctl%RoutingMethod == 2) then - call Routing_MC(iunit, nt, theDeltaT) - else if(Tctl%RoutingMethod == 3) then - call Routing_THREW(iunit, nt, theDeltaT) - else if(Tctl%RoutingMethod == 4) then - call Routing_DW(iunit, nt, theDeltaT) - else - call shr_sys_abort( "mosart: Please check the routing method! There are only 4 methods available." ) - end if - - end subroutine mainchannelRouting - -!----------------------------------------------------------------------- - - subroutine Routing_KW(iunit, nt, theDeltaT) - ! !DESCRIPTION: classic kinematic wave routing method - implicit none - - integer, intent(in) :: iunit, nt - real(r8), intent(in) :: theDeltaT - integer :: k - real(r8) :: temp_gwl, temp_dwr, temp_gwl0 - - ! estimate the inflow from upstream units - TRunoff%erin(iunit,nt) = 0._r8 - -! tcraig, moved this out of the inner main channel loop to before main channel call -! now it's precomputed as TRunoff%eroutUp -! do k=1,TUnit%nUp(iunit) -! TRunoff%erin(iunit,nt) = TRunoff%erin(iunit,nt) - TRunoff%erout(TUnit%iUp(iunit,k),nt) -! end do - TRunoff%erin(iunit,nt) = TRunoff%erin(iunit,nt) - TRunoff%eroutUp(iunit,nt) - - ! estimate the outflow - if(TUnit%rlen(iunit) <= 0._r8) then ! no river network, no channel routing - TRunoff%vr(iunit,nt) = 0._r8 - TRunoff%erout(iunit,nt) = -TRunoff%erin(iunit,nt)-TRunoff%erlateral(iunit,nt) - else - if(TUnit%areaTotal2(iunit)/TUnit%rwidth(iunit)/TUnit%rlen(iunit) > 1e6_r8) then - TRunoff%erout(iunit,nt) = -TRunoff%erin(iunit,nt)-TRunoff%erlateral(iunit,nt) - else -! !TRunoff%vr(iunit,nt) = CRVRMAN(TUnit%rslp(iunit), TUnit%nr(iunit), TRunoff%rr(iunit,nt)) - TRunoff%vr(iunit,nt) = CRVRMAN_nosqrt(TUnit%rslpsqrt(iunit), TUnit%nr(iunit), TRunoff%rr(iunit,nt)) - TRunoff%erout(iunit,nt) = -TRunoff%vr(iunit,nt) * TRunoff%mr(iunit,nt) - if(-TRunoff%erout(iunit,nt) > TINYVALUE .and. TRunoff%wr(iunit,nt) + & - (TRunoff%erlateral(iunit,nt) + TRunoff%erin(iunit,nt) + TRunoff%erout(iunit,nt)) * theDeltaT < TINYVALUE) then - TRunoff%erout(iunit,nt) = -(TRunoff%erlateral(iunit,nt) + TRunoff%erin(iunit,nt) + TRunoff%wr(iunit,nt) / theDeltaT) - if(TRunoff%mr(iunit,nt) > 0._r8) then - TRunoff%vr(iunit,nt) = -TRunoff%erout(iunit,nt) / TRunoff%mr(iunit,nt) - end if - end if - end if - end if - - temp_gwl = TRunoff%qgwl(iunit,nt) * TUnit%area(iunit) * TUnit%frac(iunit) - - TRunoff%dwr(iunit,nt) = TRunoff%erlateral(iunit,nt) + TRunoff%erin(iunit,nt) + TRunoff%erout(iunit,nt) + temp_gwl - - if((TRunoff%wr(iunit,nt)/theDeltaT & - + TRunoff%dwr(iunit,nt)) < -TINYVALUE) then - write(iulog,*) 'mosart: ERROR main channel going negative: ', iunit, nt - write(iulog,*) theDeltaT, TRunoff%wr(iunit,nt), & - TRunoff%wr(iunit,nt)/theDeltaT, TRunoff%dwr(iunit,nt), temp_gwl - write(iulog,*) ' ' - ! call shr_sys_abort('mosart: ERROR main channel going negative') - endif - -! check for stability -! if(TRunoff%vr(iunit,nt) < -TINYVALUE .or. TRunoff%vr(iunit,nt) > 30) then -! write(iulog,*) "Numerical error inRouting_KW, ", iunit,nt,TRunoff%vr(iunit,nt) -! end if - -! check for negative wr -! if(TRunoff%wr(iunit,nt) > 1._r8 .and. (TRunoff%wr(iunit,nt)/theDeltaT + TRunoff%dwr(iunit,nt))/TRunoff%wr(iunit,nt) < -TINYVALUE) then -! write(iulog,*) 'negative wr!', TRunoff%wr(iunit,nt), TRunoff%dwr(iunit,nt), temp_dwr, temp_gwl, temp_gwl0, theDeltaT -! stop -! end if - - end subroutine Routing_KW - -!----------------------------------------------------------------------- - - subroutine Routing_MC(iunit, nt, theDeltaT) - ! !DESCRIPTION: Muskingum-Cunge routing method - implicit none - integer, intent(in) :: iunit, nt - real(r8), intent(in) :: theDeltaT - - end subroutine Routing_MC - -!----------------------------------------------------------------------- - - subroutine Routing_THREW(iunit, nt, theDeltaT) - ! !DESCRIPTION: kinematic wave routing method from THREW model - implicit none - integer, intent(in) :: iunit, nt - real(r8), intent(in) :: theDeltaT - - end subroutine Routing_THREW - -!----------------------------------------------------------------------- - - subroutine Routing_DW(iunit, nt, theDeltaT) - ! !DESCRIPTION: classic diffusion wave routing method - implicit none - integer, intent(in) :: iunit, nt - real(r8), intent(in) :: theDeltaT - - end subroutine Routing_DW - -!----------------------------------------------------------------------- - - subroutine updateState_hillslope(iunit,nt) - ! !DESCRIPTION: update the state variables at hillslope - implicit none - integer, intent(in) :: iunit, nt - - TRunoff%yh(iunit,nt) = TRunoff%wh(iunit,nt) !/ TUnit%area(iunit) / TUnit%frac(iunit) - - end subroutine updateState_hillslope - -!----------------------------------------------------------------------- - - subroutine updateState_subnetwork(iunit,nt) - ! !DESCRIPTION: update the state variables in subnetwork channel - implicit none - integer, intent(in) :: iunit,nt - - if(TUnit%tlen(iunit) > 0._r8 .and. TRunoff%wt(iunit,nt) > 0._r8) then - TRunoff%mt(iunit,nt) = GRMR(TRunoff%wt(iunit,nt), TUnit%tlen(iunit)) - TRunoff%yt(iunit,nt) = GRHT(TRunoff%mt(iunit,nt), TUnit%twidth(iunit)) - TRunoff%pt(iunit,nt) = GRPT(TRunoff%yt(iunit,nt), TUnit%twidth(iunit)) - TRunoff%rt(iunit,nt) = GRRR(TRunoff%mt(iunit,nt), TRunoff%pt(iunit,nt)) - else - TRunoff%mt(iunit,nt) = 0._r8 - TRunoff%yt(iunit,nt) = 0._r8 - TRunoff%pt(iunit,nt) = 0._r8 - TRunoff%rt(iunit,nt) = 0._r8 - end if - end subroutine updateState_subnetwork - -!----------------------------------------------------------------------- - - subroutine updateState_mainchannel(iunit, nt) - ! !DESCRIPTION: update the state variables in main channel - implicit none - integer, intent(in) :: iunit, nt - - if(TUnit%rlen(iunit) > 0._r8 .and. TRunoff%wr(iunit,nt) > 0._r8) then - TRunoff%mr(iunit,nt) = GRMR(TRunoff%wr(iunit,nt), TUnit%rlen(iunit)) - TRunoff%yr(iunit,nt) = GRHR(TRunoff%mr(iunit,nt), TUnit%rwidth(iunit), TUnit%rwidth0(iunit), TUnit%rdepth(iunit)) - TRunoff%pr(iunit,nt) = GRPR(TRunoff%yr(iunit,nt), TUnit%rwidth(iunit), TUnit%rwidth0(iunit), TUnit%rdepth(iunit)) - TRunoff%rr(iunit,nt) = GRRR(TRunoff%mr(iunit,nt), TRunoff%pr(iunit,nt)) - else - TRunoff%mr(iunit,nt) = 0._r8 - TRunoff%yr(iunit,nt) = 0._r8 - TRunoff%pr(iunit,nt) = 0._r8 - TRunoff%rr(iunit,nt) = 0._r8 - end if - end subroutine updateState_mainchannel - -!----------------------------------------------------------------------- - - function CRVRMAN(slp_, n_, rr_) result(v_) - ! Function for calculating channel velocity according to Manning's equation. - implicit none - real(r8), intent(in) :: slp_, n_, rr_ ! slope, manning's roughness coeff., hydraulic radius - real(r8) :: v_ ! v_ is discharge - - real(r8) :: ftemp,vtemp - - if(rr_ <= 0._r8) then - v_ = 0._r8 - else -!tcraig, original code -! ftemp = 2._r8/3._r8 -! v_ = (rr_**ftemp) * sqrt(slp_) / n_ -!tcraig, produces same answer as original in same time -! v_ = (rr_**(2._r8/3._r8)) * sqrt(slp_) / n_ - -!tcraig, this is faster but NOT bit-for-bit - v_ = ((rr_*rr_)**(1._r8/3._r8)) * sqrt(slp_) / n_ - -!debug if (abs(vtemp - v_)/vtemp > 1.0e-14) then -!debug write(iulog,*) 'tcx check crvrman ',vtemp, v_ -!debug endif - end if - return - end function CRVRMAN - -!----------------------------------------------------------------------- - - function CRVRMAN_nosqrt(sqrtslp_, n_, rr_) result(v_) - ! Function for calculating channel velocity according to Manning's equation. - implicit none - real(r8), intent(in) :: sqrtslp_, n_, rr_ ! sqrt(slope), manning's roughness coeff., hydraulic radius - real(r8) :: v_ ! v_ is discharge - - real(r8) :: ftemp, vtemp - - if(rr_ <= 0._r8) then - v_ = 0._r8 - else -!tcraig, original code -! ftemp = 2._r8/3._r8 -! v_ = (rr_**ftemp) * sqrtslp_ / n_ -!tcraig, produces same answer as original in same time -! v_ = (rr_**(2._r8/3._r8)) * sqrtslp_ / n_ - -!tcraig, this is faster but NOT bit-for-bit - v_ = ((rr_*rr_)**(1._r8/3._r8)) * sqrtslp_ / n_ - -!debug if (abs(vtemp - v_)/vtemp > 1.0e-14) then -!debug write(iulog,*) 'tcx check crvrman_nosqrt ',vtemp, v_ -!debug endif - end if - return - end function CRVRMAN_nosqrt - -!----------------------------------------------------------------------- - - function CREHT(hslp_, nh_, Gxr_, yh_) result(eht_) - ! Function for overland from hillslope into the sub-network channels - implicit none - real(r8), intent(in) :: hslp_, nh_, Gxr_, yh_ ! topographic slope, manning's roughness coeff., drainage density, overland flow depth - real(r8) :: eht_ ! velocity, specific discharge - - real(r8) :: vh_ - vh_ = CRVRMAN(hslp_,nh_,yh_) - eht_ = Gxr_*yh_*vh_ - return - end function CREHT - -!----------------------------------------------------------------------- - - function CREHT_nosqrt(sqrthslp_, nh_, Gxr_, yh_) result(eht_) - ! Function for overland from hillslope into the sub-network channels - implicit none - real(r8), intent(in) :: sqrthslp_, nh_, Gxr_, yh_ ! topographic slope, manning's roughness coeff., drainage density, overland flow depth - real(r8) :: eht_ ! velocity, specific discharge - - real(r8) :: vh_ - vh_ = CRVRMAN_nosqrt(sqrthslp_,nh_,yh_) - eht_ = Gxr_*yh_*vh_ - return - end function CREHT_nosqrt - -!----------------------------------------------------------------------- - - function GRMR(wr_, rlen_) result(mr_) - ! Function for estimate wetted channel area - implicit none - real(r8), intent(in) :: wr_, rlen_ ! storage of water, channel length - real(r8) :: mr_ ! wetted channel area - - mr_ = wr_ / rlen_ - return - end function GRMR - -!----------------------------------------------------------------------- - - function GRHT(mt_, twid_) result(ht_) - ! Function for estimating water depth assuming rectangular channel - implicit none - real(r8), intent(in) :: mt_, twid_ ! wetted channel area, channel width - real(r8) :: ht_ ! water depth - - if(mt_ <= TINYVALUE) then - ht_ = 0._r8 - else - ht_ = mt_ / twid_ - end if - return - end function GRHT - -!----------------------------------------------------------------------- - - function GRPT(ht_, twid_) result(pt_) - ! Function for estimating wetted perimeter assuming rectangular channel - implicit none - real(r8), intent(in) :: ht_, twid_ ! water depth, channel width - real(r8) :: pt_ ! wetted perimeter - - if(ht_ <= TINYVALUE) then - pt_ = 0._r8 - else - pt_ = twid_ + 2._r8 * ht_ - end if - return - end function GRPT - -!----------------------------------------------------------------------- - - function GRRR(mr_, pr_) result(rr_) - ! Function for estimating hydraulic radius - implicit none - real(r8), intent(in) :: mr_, pr_ ! wetted area and perimeter - real(r8) :: rr_ ! hydraulic radius - - if(pr_ <= TINYVALUE) then - rr_ = 0._r8 - else - rr_ = mr_ / pr_ - end if - return - end function GRRR - -!----------------------------------------------------------------------- - - function GRHR(mr_, rwidth_, rwidth0_, rdepth_) result(hr_) - ! Function for estimating maximum water depth assuming rectangular channel and tropezoidal flood plain - ! here assuming the channel cross-section consists of three parts, from bottom to up, - ! part 1 is a rectangular with bankfull depth (rdep) and bankfull width (rwid) - ! part 2 is a tropezoidal, bottom width rwid and top width rwid0, height 0.1*((rwid0-rwid)/2), assuming slope is 0.1 - ! part 3 is a rectagular with the width rwid0 - implicit none - real(r8), intent(in) :: mr_, rwidth_, rwidth0_, rdepth_ ! wetted channel area, channel width, flood plain wid, water depth - real(r8) :: hr_ ! water depth - - real(r8) :: SLOPE1 ! slope of flood plain, TO DO - real(r8) :: deltamr_ - - SLOPE1 = SLOPE1def - if(mr_ <= TINYVALUE) then - hr_ = 0._r8 - else - if(mr_ - rdepth_*rwidth_ <= TINYVALUE) then ! not flooded - hr_ = mr_/rwidth_ - else ! if flooded, the find out the equivalent depth - if(mr_ > rdepth_*rwidth_ + (rwidth_ + rwidth0_)*SLOPE1*((rwidth0_-rwidth_)/2._r8)/2._r8 + TINYVALUE) then - deltamr_ = mr_ - rdepth_*rwidth_ - (rwidth_ + rwidth0_)*SLOPE1*((rwidth0_ - rwidth_)/2._r8)/2._r8; - hr_ = rdepth_ + SLOPE1*((rwidth0_ - rwidth_)/2._r8) + deltamr_/(rwidth0_); - else - deltamr_ = mr_ - rdepth_*rwidth_; -! !hr_ = rdepth_ + (-rwidth_+sqrt( rwidth_**2._r8 +4._r8*deltamr_/SLOPE1))*SLOPE1/2._r8 - hr_ = rdepth_ + (-rwidth_+sqrt((rwidth_*rwidth_)+4._r8*deltamr_/SLOPE1))*SLOPE1/2._r8 - end if - end if - end if - return - end function GRHR - -!----------------------------------------------------------------------- - - function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) - ! Function for estimating maximum water depth assuming rectangular channel and tropezoidal flood plain - ! here assuming the channel cross-section consists of three parts, from bottom to up, - ! part 1 is a rectangular with bankfull depth (rdep) and bankfull width (rwid) - ! part 2 is a tropezoidal, bottom width rwid and top width rwid0, height 0.1*((rwid0-rwid)/2), assuming slope is 0.1 - ! part 3 is a rectagular with the width rwid0 - implicit none - real(r8), intent(in) :: hr_, rwidth_, rwidth0_, rdepth_ ! wwater depth, channel width, flood plain wid, water depth - real(r8) :: pr_ ! water depth - - real(r8) :: SLOPE1 ! slope of flood plain, TO DO - real(r8) :: deltahr_ - logical, save :: first_call = .true. - - SLOPE1 = SLOPE1def - if (first_call) then - sinatanSLOPE1defr = 1.0_r8/(sin(atan(SLOPE1def))) - endif - first_call = .false. - - if(hr_ < TINYVALUE) then - pr_ = 0._r8 - else - if(hr_ <= rdepth_ + TINYVALUE) then ! not flooded - pr_ = rwidth_ + 2._r8*hr_ - else - if(hr_ > rdepth_ + ((rwidth0_-rwidth_)/2._r8)*SLOPE1 + TINYVALUE) then - deltahr_ = hr_ - rdepth_ - ((rwidth0_-rwidth_)/2._r8)*SLOPE1 -! !pr_ = rwidth_ + 2._r8*(rdepth_ + ((rwidth0_-rwidth_)/2._r8)*SLOPE1/sin(atan(SLOPE1)) + deltahr_) - pr_ = rwidth_ + 2._r8*(rdepth_ + ((rwidth0_-rwidth_)/2._r8)*SLOPE1*sinatanSLOPE1defr + deltahr_) - else -! !pr_ = rwidth_ + 2._r8*(rdepth_ + (hr_ - rdepth_)/sin(atan(SLOPE1))) - pr_ = rwidth_ + 2._r8*(rdepth_ + (hr_ - rdepth_)*sinatanSLOPE1defr) - end if - end if - end if - return - end function GRPR - -!----------------------------------------------------------------------- - - subroutine createFile(nio, fname) - ! !DESCRIPTION: create a new file. if a file with the same name exists, delete it then create a new one - implicit none - character(len=*), intent(in) :: fname ! file name - integer, intent(in) :: nio !unit of the file to create - - integer :: ios - logical :: filefound - character(len=1000) :: cmd - inquire (file=fname, exist=filefound) - if(filefound) then - !cmd = 'rm '//trim(fname) - !call system(cmd) - open (unit=nio, file=fname, status="replace", action="write", iostat=ios) - else - open (unit=nio, file=fname, status="new", action="write", iostat=ios) - end if - if(ios /= 0) then - call shr_sys_abort( "mosart: cannot create file: "//trim(fname) ) - end if - end subroutine createFile - -!----------------------------------------------------------------------- - - subroutine printTest(nio) - ! !DESCRIPTION: output the simulation results into external files - implicit none - integer, intent(in) :: nio ! unit of the file to print - - integer :: IDlist(1:5) = (/151,537,687,315,2080/) - integer :: ios,ii ! flag of io status - - - write(unit=nio,fmt="(15(e20.11))") TRunoff%etin(IDlist(1),1)/TUnit%area(IDlist(1)), & - TRunoff%erlateral(IDlist(1),1)/TUnit%area(IDlist(1)), TRunoff%flow(IDlist(1),1), & - TRunoff%etin(IDlist(2),1)/TUnit%area(IDlist(2)), TRunoff%erlateral(IDlist(2),1)/TUnit%area(IDlist(2)), & - TRunoff%flow(IDlist(2),1), & - TRunoff%etin(IDlist(3),1)/TUnit%area(IDlist(3)), TRunoff%erlateral(IDlist(3),1)/TUnit%area(IDlist(3)), & - TRunoff%flow(IDlist(3),1), & - TRunoff%etin(IDlist(4),1)/TUnit%area(IDlist(4)), TRunoff%erlateral(IDlist(4),1)/TUnit%area(IDlist(4)), & - TRunoff%flow(IDlist(4),1), & - TRunoff%etin(IDlist(5),1)/TUnit%area(IDlist(5)), TRunoff%erlateral(IDlist(5),1)/TUnit%area(IDlist(5)), & - TRunoff%flow(IDlist(5),1) - !write(unit=nio,fmt="((a10),(e20.11))") theTime, liqWater%flow(ii) - !write(unit=nio,fmt="((a10),6(e20.11))") theTime, liqWater%qsur(ii), liqWater%qsub(ii), liqWater%etin(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%erlateral(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%erin(ii), liqWater%flow(ii) - !if(liqWater%yr(ii) > 0._r8) then - ! write(unit=nio,fmt="((a10),6(e20.11))") theTime, liqWater%mr(ii)/liqWater%yr(ii),liqWater%yr(ii), liqWater%vr(ii), liqWater%erin(ii), liqWater%erout(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%flow(ii) - !else - ! write(unit=nio,fmt="((a10),6(e20.11))") theTime, liqWater%mr(ii)-liqWater%mr(ii),liqWater%yr(ii), liqWater%vr(ii), liqWater%erin(ii), liqWater%erout(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%flow(ii) - !end if - !write(unit=nio,fmt="((a10),7(e20.11))") theTime, liqWater%erlateral(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%wr(ii),liqWater%mr(ii), liqWater%yr(ii), liqWater%pr(ii), liqWater%rr(ii), liqWater%flow(ii) - !write(unit=nio,fmt="((a10),7(e20.11))") theTime, liqWater%yh(ii), liqWater%dwh(ii),liqWater%etin(ii), liqWater%vr(ii), liqWater%erin(ii), liqWater%erout(ii)/(TUnit%area(ii)*TUnit%frac(ii)), liqWater%flow(ii) - - end subroutine printTest - -!----------------------------------------------------------------------- - -end MODULE MOSART_physics_mod - diff --git a/src/riverroute/RtmDateTime.F90 b/src/riverroute/RtmDateTime.F90 deleted file mode 100644 index 7e41a02..0000000 --- a/src/riverroute/RtmDateTime.F90 +++ /dev/null @@ -1,58 +0,0 @@ -module RtmDateTime - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: getdatetime -! -! !INTERFACE: -subroutine getdatetime (cdate, ctime) -! -! !DESCRIPTION: -! A generic Date and Time routine -! -! !USES: - use RtmSpmd, only : mpicom_rof, masterproc, MPI_CHARACTER -! !ARGUMENTS: - implicit none - character(len=8), intent(out) :: cdate !current date - character(len=8), intent(out) :: ctime !current time -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -! -! !LOCAL VARIABLES: -!EOP - character(len=8) :: date !current date - character(len=10) :: time !current time - character(len=5) :: zone !zone - integer, dimension(8) :: values !temporary - integer :: ier !MPI error code -!----------------------------------------------------------------------- - if (masterproc) then - - call date_and_time (date, time, zone, values) - - cdate(1:2) = date(5:6) - cdate(3:3) = '/' - cdate(4:5) = date(7:8) - cdate(6:6) = '/' - cdate(7:8) = date(3:4) - - ctime(1:2) = time(1:2) - ctime(3:3) = ':' - ctime(4:5) = time(3:4) - ctime(6:6) = ':' - ctime(7:8) = time(5:6) - - endif - - call mpi_bcast (cdate,len(cdate),MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (ctime,len(ctime),MPI_CHARACTER, 0, mpicom_rof, ier) - -end subroutine getdatetime - -end module RtmDateTime diff --git a/src/riverroute/RtmFileUtils.F90 b/src/riverroute/RtmFileUtils.F90 deleted file mode 100644 index 3a01acf..0000000 --- a/src/riverroute/RtmFileUtils.F90 +++ /dev/null @@ -1,181 +0,0 @@ -module RtmFileUtils - -!----------------------------------------------------------------------- -! Module containing file I/O utilities -! -! !USES: - use shr_sys_mod , only : shr_sys_abort - use shr_file_mod, only : shr_file_get, shr_file_getUnit, shr_file_freeUnit - use RtmSpmd , only : masterproc - use RtmVar , only : iulog -! -! !PUBLIC TYPES: - implicit none - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: get_filename !Returns filename given full pathname - public :: opnfil !Open local unformatted or formatted file - public :: getfil !Obtain local copy of file - public :: relavu !Close and release Fortran unit no longer in use - public :: getavu !Get next available Fortran unit number -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -! -! !PRIVATE MEMBER FUNCTIONS: None -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- - - character(len=256) function get_filename (fulpath) - - ! !DESCRIPTION: - ! Returns filename given full pathname - ! - ! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: fulpath !full pathname - ! - ! !LOCAL VARIABLES: - integer i !loop index - integer klen !length of fulpath character string - !---------------------------------------------------------- - - klen = len_trim(fulpath) - do i = klen, 1, -1 - if (fulpath(i:i) == '/') go to 10 - end do - i = 0 -10 get_filename = fulpath(i+1:klen) - - end function get_filename - -!------------------------------------------------------------------------ - - subroutine getfil (fulpath, locfn, iflag) - - ! !DESCRIPTION: - ! Obtain local copy of file. First check current working directory, - ! Next check full pathname[fulpath] on disk - ! - ! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: fulpath !Archival or permanent disk full pathname - character(len=*), intent(out) :: locfn !output local file name - integer, intent(in) :: iflag !0=>abort if file not found 1=>do not abort - - ! !LOCAL VARIABLES: - integer i !loop index - integer klen !length of fulpath character string - logical lexist !true if local file exists - !-------------------------------------------------- - - ! get local file name from full name - locfn = get_filename( fulpath ) - if (len_trim(locfn) == 0) then - if (masterproc) write(iulog,*)'(GETFIL): local filename has zero length' - call shr_sys_abort() - else - if (masterproc) write(iulog,*)'(GETFIL): attempting to find local file ', & - trim(locfn) - endif - - ! first check if file is in current working directory. - inquire (file=locfn,exist=lexist) - if (lexist) then - if (masterproc) write(iulog,*) '(GETFIL): using ',trim(locfn), & - ' in current working directory' - RETURN - endif - - ! second check for full pathname on disk - locfn = fulpath - - inquire (file=fulpath,exist=lexist) - if (lexist) then - if (masterproc) write(iulog,*) '(GETFIL): using ',trim(fulpath) - RETURN - else - if (masterproc) write(iulog,*)'(GETFIL): failed getting file from full path: ', fulpath - if (iflag==0) then - call shr_sys_abort ('GETFIL: FAILED to get '//trim(fulpath)) - else - RETURN - endif - endif - - end subroutine getfil - -!------------------------------------------------------------------------ - - subroutine opnfil (locfn, iun, form) - - ! !DESCRIPTION: - ! Open file locfn in unformatted or formatted form on unit iun - ! - ! !ARGUMENTS: - implicit none - character(len=*), intent(in):: locfn !file name - integer, intent(in):: iun !fortran unit number - character(len=1), intent(in):: form !file format: u = unformatted, - - ! !LOCAL VARIABLES: - integer ioe !error return from fortran open - character(len=11) ft !format type: formatted. unformatted - !----------------------------------------------------------- - - if (len_trim(locfn) == 0) then - write(iulog,*)'(OPNFIL): local filename has zero length' - call shr_sys_abort() - endif - if (form=='u' .or. form=='U') then - ft = 'unformatted' - else - ft = 'formatted ' - end if - open (unit=iun,file=locfn,status='unknown',form=ft,iostat=ioe) - if (ioe /= 0) then - write(iulog,*)'(OPNFIL): failed to open file ',trim(locfn), & - & ' on unit ',iun,' ierr=',ioe - call shr_sys_abort() - else if ( masterproc )then - write(iulog,*)'(OPNFIL): Successfully opened file ',trim(locfn), & - & ' on unit= ',iun - end if - - end subroutine opnfil - -!------------------------------------------------------------------------ - - integer function getavu() - - ! !DESCRIPTION: - ! Get next available Fortran unit number. - implicit none - - getavu = shr_file_getunit() - - end function getavu - -!------------------------------------------------------------------------ - - subroutine relavu (iunit) - - ! !DESCRIPTION: - ! Close and release Fortran unit no longer in use! - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: iunit !Fortran unit number - !---------------------------------------------------- - - close(iunit) - call shr_file_freeUnit(iunit) - - end subroutine relavu - -end module RtmFileUtils diff --git a/src/riverroute/RtmHistFile.F90 b/src/riverroute/RtmHistFile.F90 deleted file mode 100644 index 75c5d5b..0000000 --- a/src/riverroute/RtmHistFile.F90 +++ /dev/null @@ -1,1797 +0,0 @@ -module RtmHistFile -!----------------------------------------------------------------------- -! !MODULE: RtmHistFileMod -! -! !DESCRIPTION: -! Module containing methods to for MOSART history file handling. -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_flush, shr_sys_abort - use shr_log_mod , only : errMsg => shr_log_errMsg - use RunoffMod , only : rtmCTL, Tunit - use RtmVar , only : rtmlon, rtmlat, spval, ispval, secspday, frivinp_rtm, & - iulog, nsrest, caseid, inst_suffix, nsrStartup, nsrBranch, & - ctitle, version, hostname, username, conventions, source, & - model_doi_url - use RtmFileUtils , only : get_filename, getfil - use RtmTimeManager, only : get_nstep, get_curr_date, get_curr_time, get_ref_date, & - get_prev_time, get_prev_date, is_last_step, get_step_size - use RtmSpmd , only : masterproc - use RtmIO - use RtmDateTime - - implicit none - save - private - -! -! !PUBLIC TYPES: -! -! Constants -! - integer , public, parameter :: max_tapes = 3 ! max number of history tapes - integer , public, parameter :: max_flds = 1500 ! max number of history fields - integer , public, parameter :: max_namlen = 32 ! maximum number of characters for field name -! -! Counters -! - integer , public :: ntapes = 0 ! index of max history file requested -! -! Namelist -! - integer :: ni - integer, public :: & - rtmhist_ndens(max_tapes) = 1 ! namelist: output density of netcdf history files - integer, public :: & - rtmhist_mfilt(max_tapes) = 30 ! namelist: number of time samples per tape - integer, public :: & - rtmhist_nhtfrq(max_tapes) = (/0, -24, -24/) ! namelist: history write freq(0=monthly) - character(len=1), public :: & - rtmhist_avgflag_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape averaging flag - - ! list of fields to add - character(len=max_namlen+2), public :: rtmhist_fincl1(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fincl2(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fincl3(max_flds) = ' ' - ! - ! time_period_freq variable - ! - character(len=max_namlen+2), public :: time_period_freq = ' ' - - ! list of fields to remove - character(len=max_namlen+2), public :: rtmhist_fexcl1(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fexcl2(max_flds) = ' ' - character(len=max_namlen+2), public :: rtmhist_fexcl3(max_flds) = ' ' - - ! equivalence list of fields to add/remove - character(len=max_namlen+2), public :: fexcl(max_flds,max_tapes) - character(len=max_namlen+2), public :: fincl(max_flds,max_tapes) - -!! Restart -! - logical, private :: if_close(max_tapes) ! true => save history file -! -! !PUBLIC MEMBER FUNCTIONS: - public :: RtmHistAddfld ! Add a field to the master field list - public :: RtmHistPrintflds ! Print summary of master field list - public :: RtmHistHtapesBuild ! Initialize history file handler for initial or continue run - public :: RtmHistUpdateHbuf ! Updates history buffer for all fields and tapes - public :: RtmHistHtapesWrapup ! Write history tape(s) - public :: RtmHistRestart ! Read/write history file restart data -! -! !REVISION HISTORY: -! Created by Mariana Vertenstein -! -! !PRIVATE MEMBER FUNCTIONS: - private :: htapes_fieldlist ! Define the contents of each history file based on namelist - private :: htape_addfld ! Add a field to the active list for a history tape - private :: htape_create ! Define contents of history file t - private :: htape_timeconst ! Write time constant values to history tape - private :: set_hist_filename ! Determine history dataset filenames - private :: list_index ! Find index of field in exclude list - private :: getname ! Retrieve name portion of input "inname" - private :: getflag ! Retrieve flag - private :: max_nFields ! The max number of fields on any tape - -! !PRIVATE TYPES: -! Constants -! - integer, parameter :: max_length_filename = 255 ! max length of a filename. on most linux systems this - ! is 255. But this can't be increased until all hard - ! coded values throughout the i/o stack are updated. - integer, parameter :: max_chars = 255 ! max chars for char variables -! -! Subscript dimensions -! - integer, parameter :: max_subs = 100 ! max number of subscripts - character(len=32) :: subs_name(max_subs) ! name of subscript - integer :: subs_dim(max_subs) ! dimension of subscript -! -! Derived types -! - type field_info - character(len=max_namlen) :: name ! field name - character(len=max_chars) :: long_name ! long name - character(len=max_chars) :: units ! units - integer :: hpindex ! history pointer index - end type field_info - - type master_entry - type (field_info) :: field ! field information - logical :: actflag(max_tapes) ! active/inactive flag - character(len=1) :: avgflag(max_tapes) ! time averaging flag ("X","A","M" or "I",) - end type master_entry - - type history_entry - type (field_info) :: field ! field information - character(len=1) :: avgflag ! time averaging flag - real(r8), pointer :: hbuf(:) ! history buffer (dimensions: dim1d x 1) - integer , pointer :: nacs(:) ! accumulation counter (dimensions: dim1d x 1) - end type history_entry - - type history_tape - integer :: nflds ! number of active fields on tape - integer :: ntimes ! current number of time samples on tape - integer :: mfilt ! maximum number of time samples per tape - integer :: nhtfrq ! number of time samples per tape - integer :: ncprec ! netcdf output precision - logical :: is_endhist ! true => current time step is end of history interval - real(r8) :: begtime ! time at beginning of history averaging interval - type (history_entry) :: hlist(max_flds) ! array of active history tape entries - end type history_tape - - type rtmpoint ! Pointer to real scalar data (1D) - real(r8), pointer :: ptr(:) - end type rtmpoint -!EOP -! -! Pointers -! - integer, parameter :: max_mapflds = 1500 ! Maximum number of fields to track - type (rtmpoint) :: rtmptr(max_mapflds) ! Real scalar data (1D) -! -! Master list: an array of master_entry entities -! - type (master_entry) :: masterlist(max_flds) ! master field list -! -! History tape: an array of history_tape entities (only active fields) -! - type (history_tape) :: tape(max_tapes) ! array history tapes -! -! Namelist input -! -! Counters -! - integer :: nfmaster = 0 ! number of fields in master field list -! -! Other variables -! - character(len=max_length_filename) :: locfnh(max_tapes) ! local history file names - character(len=max_chars) :: locfnhr(max_tapes) ! local history restart file names - logical :: htapes_defined = .false. ! flag indicates history contents have been defined -! -! NetCDF Id's -! - type(file_desc_t), target :: nfid(max_tapes) ! file ids - type(file_desc_t), target :: ncid_hist(max_tapes) ! file ids for history restart files - integer :: time_dimid ! time dimension id - integer :: hist_interval_dimid ! time bounds dimension id - integer :: strlen_dimid ! string dimension id -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- - - subroutine RtmHistPrintflds() - - ! DESCRIPTION: - ! Print summary of master field list. - - ! !ARGUMENTS: - implicit none - - ! !LOCAL VARIABLES: - integer nf - character(len=*),parameter :: subname = 'RTM_hist_printflds' - - if (masterproc) then - write(iulog,*) trim(subname),' : number of master fields = ',nfmaster - write(iulog,*)' ******* MASTER FIELD LIST *******' - do nf = 1,nfmaster - write(iulog,9000)nf, masterlist(nf)%field%name, masterlist(nf)%field%units -9000 format (i5,1x,a32,1x,a16) - end do - call shr_sys_flush(iulog) - end if - - end subroutine RtmHistPrintflds - -!----------------------------------------------------------------------- - - subroutine RtmHistHtapesBuild () - - ! !DESCRIPTION: - ! Initialize ntapes history file for initial or branch run. - - ! !ARGUMENTS: - implicit none - - ! !LOCAL VARIABLES: - integer :: i ! index - integer :: ier ! error code - integer :: t, f ! tape, field indices - integer :: day, sec ! day and seconds from base date - character(len=1) :: avgflag ! lcl equiv of rtmhist_avgflag_pertape(t) - character(len=*),parameter :: subname = 'hist_htapes_build' - !---------------------------------------------------------- - - if (masterproc) then - write(iulog,*) trim(subname),' Initializing MOSART history files' - write(iulog,'(72a1)') ("-",i=1,60) - call shr_sys_flush(iulog) - endif - - ! Override averaging flag for all fields on a particular tape - ! if namelist input so specifies - - do t=1,max_tapes - if (rtmhist_avgflag_pertape(t) /= ' ') then - avgflag = rtmhist_avgflag_pertape(t) - do f = 1,nfmaster - select case (avgflag) - case ('A') - masterlist(f)%avgflag(t) = avgflag - case ('I') - masterlist(f)%avgflag(t) = avgflag - case ('X') - masterlist(f)%avgflag(t) = avgflag - case ('M') - masterlist(f)%avgflag(t) = avgflag - case default - write(iulog,*) trim(subname),' ERROR: unknown avgflag=',avgflag - call shr_sys_abort () - end select - end do - end if - end do - - fincl(:,1) = rtmhist_fincl1(:) - fincl(:,2) = rtmhist_fincl2(:) - fincl(:,3) = rtmhist_fincl3(:) - - fexcl(:,1) = rtmhist_fexcl1(:) - fexcl(:,2) = rtmhist_fexcl2(:) - fexcl(:,3) = rtmhist_fexcl3(:) - - ! Define field list information for all history files. - ! Update ntapes to reflect number of active history files - ! Note - branch runs can have additional auxiliary history files declared - - call htapes_fieldlist() - - ! Set number of time samples in each history file and - ! Note - the following entries will be overwritten by history restart - ! Note - with netcdf, only 1 (ncd_double) and 2 (ncd_float) are allowed - - do t=1,ntapes - tape(t)%ntimes = 0 - tape(t)%nhtfrq = rtmhist_nhtfrq(t) - tape(t)%mfilt = rtmhist_mfilt(t) - if (rtmhist_ndens(t) == 1) then - tape(t)%ncprec = ncd_double - else - tape(t)%ncprec = ncd_float - endif - end do - - ! Set time of beginning of current averaging interval - ! First etermine elapased time since reference date - call get_prev_time(day, sec) - do t=1,ntapes - tape(t)%begtime = day + sec/secspday - end do - - if (masterproc) then - write(iulog,*) trim(subname),' Successfully initialized MOSART history files' - write(iulog,'(72a1)') ("-",i=1,60) - call shr_sys_flush(iulog) - endif - - end subroutine RtmHistHtapesBuild - -!----------------------------------------------------------------------- - - subroutine htapes_fieldlist() - - ! !DESCRIPTION: - ! Define the contents of each history file based on namelist - ! input for initial or branch run, and restart data if a restart run. - ! Use arrays fincl and fexcl to modify default history tape contents. - ! Then sort the result alphanumerically. - - ! !ARGUMENTS: - implicit none - ! - ! !LOCAL VARIABLES: - integer :: t, f ! tape, field indices - integer :: ff ! index into include, exclude and fprec list - character(len=max_namlen) :: name ! field name portion of fincl (i.e. no avgflag separator) - character(len=max_namlen) :: mastername ! name from masterlist field - character(len=1) :: avgflag ! averaging flag - character(len=1) :: prec_acc ! history buffer precision flag - character(len=1) :: prec_wrt ! history buffer write precision flag - type (history_entry) :: tmp ! temporary used for swapping - character(len=*),parameter :: subname = 'htapes_fieldlist' - !--------------------------------------------------------- - - ! First ensure contents of fincl and fexcl are valid names - do t = 1,max_tapes - f = 1 - do while (f < max_flds .and. fincl(f,t) /= ' ') - name = getname (fincl(f,t)) !namelist - do ff = 1,nfmaster - mastername = masterlist(ff)%field%name - if (name == mastername) exit - end do - if (name /= mastername) then - write(iulog,*) trim(subname),' ERROR: ', trim(name), ' in fincl(', f, ') ',& - 'for history tape ',t,' not found' - call shr_sys_abort() - end if - f = f + 1 - end do - - f = 1 - do while (f < max_flds .and. fexcl(f,t) /= ' ') - do ff = 1,nfmaster - mastername = masterlist(ff)%field%name - if (fexcl(f,t) == mastername) exit - end do - if (fexcl(f,t) /= mastername) then - write(iulog,*) trim(subname),' ERROR: ', fexcl(f,t), ' in fexcl(', f, ') ', & - 'for history tape ',t,' not found' - call shr_sys_abort() - end if - f = f + 1 - end do - end do - - tape(:)%nflds = 0 - do t = 1,max_tapes - - ! Loop through the masterlist set of field names and determine if any of those - ! are in the FINCL or FEXCL arrays - ! The call to list_index determines the index in the FINCL or FEXCL arrays - ! that the masterlist field corresponds to - ! Add the field to the tape if specified via namelist (FINCL[1-max_tapes]), - ! or if it is on by default and was not excluded via namelist (FEXCL[1-max_tapes]). - - do f = 1,nfmaster - mastername = masterlist(f)%field%name - call list_index (fincl(1,t), mastername, ff) - if (ff > 0) then - ! if field is in include list, ff > 0 and htape_addfld - ! will not be called for field - avgflag = getflag (fincl(ff,t)) - call htape_addfld (t, f, avgflag) - else - ! find index of field in exclude list - call list_index (fexcl(1,t), mastername, ff) - - ! if field is in exclude list, ff > 0 and htape_addfld - ! will not be called for field - ! if field is not in exclude list, ff =0 and htape_addfld - ! will be called for field (note that htape_addfld will be - ! called below only if field is not in exclude list OR in - ! include list - if (ff == 0 .and. masterlist(f)%actflag(t)) then - call htape_addfld (t, f, ' ') - end if - end if - end do - - ! Specification of tape contents now complete. - ! Sort each list of active entries - - do f = tape(t)%nflds-1,1,-1 - do ff = 1,f - if (tape(t)%hlist(ff)%field%name > tape(t)%hlist(ff+1)%field%name) then - tmp = tape(t)%hlist(ff) - tape(t)%hlist(ff ) = tape(t)%hlist(ff+1) - tape(t)%hlist(ff+1) = tmp - else if (tape(t)%hlist(ff)%field%name == tape(t)%hlist(ff+1)%field%name) then - write(iulog,*) trim(subname),' ERROR: Duplicate field ', & - tape(t)%hlist(ff)%field%name, & - 't,ff,name=',t,ff,tape(t)%hlist(ff+1)%field%name - call shr_sys_abort() - end if - end do - end do - - if (masterproc) then - if (tape(t)%nflds > 0) then - write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds - end if - do f = 1,tape(t)%nflds - write(iulog,*) f,' ',tape(t)%hlist(f)%field%name,' ',tape(t)%hlist(f)%avgflag - end do - call shr_sys_flush(iulog) - end if - end do - - ! Determine total number of active history tapes - - ntapes = 0 - do t = max_tapes,1,-1 - if (tape(t)%nflds > 0) then - ntapes = t - exit - end if - end do - - ! Ensure there are no "holes" in tape specification, i.e. empty tapes. - ! Enabling holes should not be difficult if necessary. - - do t = 1,ntapes - if (tape(t)%nflds == 0) then - write(iulog,*) trim(subname),' ERROR: Tape ',t,' is empty' - call shr_sys_abort() - end if - end do - - ! Check that the number of history files declared does not exceed - ! the maximum allowed. - - if (ntapes > max_tapes) then - write(iulog,*) trim(subname),' ERROR: Too many history files declared, max_tapes=',max_tapes - call shr_sys_abort() - end if - - if (masterproc) then - write(iulog,*) 'There will be a total of ',ntapes,'MOSART history tapes' - do t=1,ntapes - write(iulog,*) - if (rtmhist_nhtfrq(t) == 0) then - write(iulog,*)'MOSART History tape ',t,' write frequency is MONTHLY' - else - write(iulog,*)'MOSART History tape ',t,' write frequency = ',rtmhist_nhtfrq(t) - endif - write(iulog,*)'Number of time samples on MOSART history tape ',t,' is ',rtmhist_mfilt(t) - write(iulog,*)'Output precision on MOSART history tape ',t,'=',rtmhist_ndens(t) - write(iulog,*) - end do - call shr_sys_flush(iulog) - end if - - ! Set flag indicating h-tape contents are now defined - - htapes_defined = .true. - - end subroutine htapes_fieldlist - -!----------------------------------------------------------------------- - - subroutine htape_addfld (t, f, avgflag) - - ! !DESCRIPTION: - ! Add a field to the active list for a history tape. Copy the data from - ! the master field list to the active list for the tape. - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: t ! history tape index - integer, intent(in) :: f ! field index from master field list - character(len=1), intent(in) :: avgflag ! time averaging flag - - ! !LOCAL VARIABLES: - integer :: n ! field index on defined tape - integer :: begrof ! per-proc beginning land runoff index - integer :: endrof ! per-proc ending land runoff index - integer :: numrtm ! total number of rtm cells on all procs - character(len=*),parameter :: subname = 'htape_addfld' - !------------------------------------------------------- - - ! Ensure that it is not to late to add a field to the history tape - if (htapes_defined) then - write(iulog,*) trim(subname),' ERROR: attempt to add field ', & - masterlist(f)%field%name, ' after history files are set' - call shr_sys_abort() - end if - - ! Determine bounds - begrof = rtmCTL%begr - endrof = rtmCTL%endr - numrtm = rtmCTL%numr - - tape(t)%nflds = tape(t)%nflds + 1 - n = tape(t)%nflds - tape(t)%hlist(n)%field = masterlist(f)%field - allocate (tape(t)%hlist(n)%hbuf(begrof:endrof)) - allocate (tape(t)%hlist(n)%nacs(begrof:endrof)) - tape(t)%hlist(n)%hbuf(:) = 0._r8 - tape(t)%hlist(n)%nacs(:) = 0 - - ! Set time averaging flag based on masterlist setting or - ! override the default averaging flag with namelist setting - select case (avgflag) - case (' ') - tape(t)%hlist(n)%avgflag = masterlist(f)%avgflag(t) - case ('A','I','X','M') - tape(t)%hlist(n)%avgflag = avgflag - case default - write(iulog,*) trim(subname),' ERROR: unknown avgflag=', avgflag - call shr_sys_abort() - end select - - end subroutine htape_addfld - -!----------------------------------------------------------------------- - - subroutine RtmHistUpdateHbuf() - - ! !DESCRIPTION: - ! Accumulate (or take min, max, etc. as appropriate) input field - ! into its history buffer for appropriate tapes. - - ! !ARGUMENTS: - implicit none - - ! !LOCAL VARIABLES: - integer :: t ! tape index - integer :: f ! field index - integer :: k ! index - integer :: hpindex ! history pointer index - integer :: begrof,endrof ! beginning and ending indices - character(len=1) :: avgflag ! time averaging flag - real(r8), pointer :: hbuf(:) ! history buffer - integer , pointer :: nacs(:) ! accumulation counter - real(r8), pointer :: field(:) ! 1d pointer field - integer j - character(len=*),parameter :: subname = 'RtmHistUpdateHbuf' - !---------------------------------------------------------- - - begrof = rtmCTL%begr - endrof = rtmCTL%endr - - do t = 1,ntapes - do f = 1,tape(t)%nflds - avgflag = tape(t)%hlist(f)%avgflag - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - hpindex = tape(t)%hlist(f)%field%hpindex - field => rtmptr(hpindex)%ptr - - select case (avgflag) - case ('I') ! Instantaneous - do k = begrof,endrof - if (field(k) /= spval) then - hbuf(k) = field(k) - else - hbuf(k) = spval - end if - nacs(k) = 1 - end do - case ('A') ! Time average - do k = begrof,endrof - if (field(k) /= spval) then - if (nacs(k) == 0) hbuf(k) = 0._r8 - hbuf(k) = hbuf(k) + field(k) - nacs(k) = nacs(k) + 1 - else - if (nacs(k) == 0) hbuf(k) = spval - end if - end do - case ('X') ! Maximum over time - do k = begrof,endrof - if (field(k) /= spval) then - if (nacs(k) == 0) hbuf(k) = -1.e50_r8 - hbuf(k) = max( hbuf(k), field(k) ) - else - if (nacs(k) == 0) hbuf(k) = spval - end if - nacs(k) = 1 - end do - case ('M') ! Minimum over time - do k = begrof,endrof - if (field(k) /= spval) then - if (nacs(k) == 0) hbuf(k) = +1.e50_r8 - hbuf(k) = min( hbuf(k), field(k) ) - else - if (nacs(k) == 0) hbuf(k) = spval - end if - nacs(k) = 1 - end do - case default - write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag - call shr_sys_abort() - end select - end do - end do - - end subroutine RtmHistUpdateHbuf - -!----------------------------------------------------------------------- - - subroutine htape_create (t, histrest) - - ! !DESCRIPTION: - ! Define contents of history file t. Issue the required netcdf - ! wrapper calls to define the history file contents. - ! - ! !USES: - use RtmVar , only: isecspday - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: t ! tape index - logical, intent(in), optional :: histrest ! if creating the history restart file - - ! !LOCAL VARIABLES: - integer :: f ! field index - integer :: p,c,l,n ! indices - integer :: ier ! error code - integer :: dimid ! dimension id temporary - integer :: dim1id(1) ! netCDF dimension id - integer :: dim2id(2) ! netCDF dimension id - integer :: ndims ! dimension counter - integer :: omode ! returned mode from netCDF call - integer :: ncprec ! output netCDF write precision - integer :: ret ! netCDF error status - integer :: numrtm ! total number of rtm cells on all procs - integer :: dtime ! timestep size - integer :: sec_hist_nhtfrq ! rtmhist_nhtfrq converted to seconds - logical :: lhistrest ! local history restart flag - type(file_desc_t), pointer :: lnfid ! local file id - character(len= 8) :: curdate ! current date - character(len= 8) :: curtime ! current time - character(len=256) :: name ! name of attribute - character(len=256) :: units ! units of attribute - character(len=256) :: str ! global attribute string - character(len= 1) :: avgflag ! time averaging flag - character(len=*),parameter :: subname = 'htape_create' - !----------------------------------------------------- - - if ( present(histrest) )then - lhistrest = histrest - else - lhistrest = .false. - end if - - ! Define output write precsion for tape - ncprec = tape(t)%ncprec - if (lhistrest) then - lnfid => ncid_hist(t) - else - lnfid => nfid(t) - endif - - ! Create new netCDF file. It will be in define mode - if ( .not. lhistrest )then - if (masterproc) then - write(iulog,*) trim(subname),' : Opening netcdf htape ', & - trim(locfnh(t)) - call shr_sys_flush(iulog) - end if - call ncd_pio_createfile(lnfid, trim(locfnh(t))) - call ncd_putatt(lnfid, ncd_global, 'title', 'MOSART History file information' ) - call ncd_putatt(lnfid, ncd_global, 'comment', & - "NOTE: None of the variables are weighted by land fraction!" ) - else - if (masterproc) then - write(iulog,*) trim(subname),' : Opening netcdf rhtape ', & - trim(locfnhr(t)) - call shr_sys_flush(iulog) - end if - call ncd_pio_createfile(lnfid, trim(locfnhr(t))) - call ncd_putatt(lnfid, ncd_global, 'title', & - 'MOSART Restart History information, required to continue a simulation' ) - call ncd_putatt(lnfid, ncd_global, 'comment', & - "This entire file NOT needed for startup or branch simulations") - end if - - ! Create global attributes. Attributes are used to store information - ! about the data set. Global attributes are information about the - ! data set as a whole, as opposed to a single variable - - call ncd_putatt(lnfid, ncd_global, 'Conventions', trim(conventions)) - call getdatetime(curdate, curtime) - str = 'created on ' // curdate // ' ' // curtime - call ncd_putatt(lnfid, ncd_global, 'history' , trim(str)) - call ncd_putatt(lnfid, ncd_global, 'source' , trim(source)) - call ncd_putatt(lnfid, ncd_global, 'hostname' , trim(hostname)) - call ncd_putatt(lnfid, ncd_global, 'username' , trim(username)) - call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) - call ncd_putatt(lnfid, ncd_global, 'model_doi_url', trim(model_doi_url)) - - call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) - call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) - - str = get_filename(frivinp_rtm) - call ncd_putatt(lnfid, ncd_global, 'RTM_input_dataset', trim(str)) - - ! - ! add global attribute time_period_freq - ! - if (rtmhist_nhtfrq(t) < 0) then !hour need to convert to seconds - sec_hist_nhtfrq = abs(rtmhist_nhtfrq(t))*3600 - else - sec_hist_nhtfrq = rtmhist_nhtfrq(t) - end if - - dtime = get_step_size() - if (sec_hist_nhtfrq == 0) then !month - time_period_freq = 'month_1' - else if (mod(sec_hist_nhtfrq*dtime,isecspday) == 0) then ! day - write(time_period_freq,999) 'day_',sec_hist_nhtfrq*dtime/isecspday - else if (mod(sec_hist_nhtfrq*dtime,3600) == 0) then ! hour - write(time_period_freq,999) 'hour_',(sec_hist_nhtfrq*dtime)/3600 - else if (mod(sec_hist_nhtfrq*dtime,60) == 0) then ! minute - write(time_period_freq,999) 'minute_',(sec_hist_nhtfrq*dtime)/60 - else ! second - write(time_period_freq,999) 'second_',sec_hist_nhtfrq*dtime - end if -999 format(a,i0) - - call ncd_putatt(lnfid, ncd_global, 'time_period_freq', trim(time_period_freq)) - - ! Define dimensions. - ! Time is an unlimited dimension. Character string is treated as an array of characters. - - ! Global uncompressed dimensions (including non-land points) - numrtm = rtmCTL%numr - call ncd_defdim( lnfid, 'lon', rtmlon , dimid) - call ncd_defdim( lnfid, 'lat', rtmlat , dimid) - call ncd_defdim( lnfid, 'allrof', numrtm , dimid) - - call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) - - if ( .not. lhistrest )then - call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) - call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) - if (masterproc)then - write(iulog,*) trim(subname), & - ' : Successfully defined netcdf history file ',t - call shr_sys_flush(iulog) - end if - else - if (masterproc)then - write(iulog,*) trim(subname), & - ' : Successfully defined netcdf restart history file ',t - call shr_sys_flush(iulog) - end if - end if - - end subroutine htape_create - -!----------------------------------------------------------------------- - - subroutine htape_timeconst(t, mode) - - ! !DESCRIPTION: - ! Write time constant values to primary history tape. - ! !USES: - use RtmTimeManager, only : get_calendar, NO_LEAP_C, GREGORIAN_C - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: t ! tape index - character(len=*), intent(in) :: mode ! 'define' or 'write' - - ! !LOCAL VARIABLES: - integer :: vid,n,i,j,m ! indices - integer :: nstep ! current step - integer :: mcsec ! seconds of current date - integer :: mdcur ! current day - integer :: mscur ! seconds of current day - integer :: mcdate ! current date - integer :: dtime ! timestep size - integer :: yr,mon,day,nbsec ! year,month,day,seconds components of a date - integer :: hours,minutes,secs ! hours,minutes,seconds of hh:mm:ss - character(len= 10) :: basedate ! base date (yyyymmdd) - character(len= 8) :: basesec ! base seconds - character(len= 8) :: cdate ! system date - character(len= 8) :: ctime ! system time - real(r8):: time ! current time - real(r8):: timedata(2) ! time interval boundaries - integer :: dim1id(1) ! netCDF dimension id - integer :: dim2id(2) ! netCDF dimension id - integer :: varid ! netCDF variable id - type(Var_desc_t) :: vardesc ! netCDF variable description - character(len=max_chars) :: long_name ! variable long name - character(len=max_namlen):: varname ! variable name - character(len=max_namlen):: units ! variable units - character(len=max_namlen):: cal ! calendar type from time-manager - character(len=max_namlen):: caldesc ! calendar description to put on file - character(len=256):: str ! global attribute string - integer :: status - character(len=*),parameter :: subname = 'htape_timeconst' - !-------------------------------------------------------- - - ! For define mode -- only do this for first time-sample - if (mode == 'define' .and. tape(t)%ntimes == 1) then - - call get_ref_date(yr, mon, day, nbsec) - nstep = get_nstep() - hours = nbsec / 3600 - minutes = (nbsec - hours*3600) / 60 - secs = (nbsec - hours*3600 - minutes*60) - write(basedate,80) yr,mon,day -80 format(i4.4,'-',i2.2,'-',i2.2) - write(basesec ,90) hours, minutes, secs -90 format(i2.2,':',i2.2,':',i2.2) - - dim1id(1) = time_dimid - str = 'days since ' // basedate // " " // basesec - call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & - long_name='time',units=str) - cal = get_calendar() - if ( trim(cal) == NO_LEAP_C )then - caldesc = "noleap" - else if ( trim(cal) == GREGORIAN_C )then - caldesc = "gregorian" - end if - call ncd_putatt(nfid(t), varid, 'calendar', caldesc) - call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') - - dim1id(1) = time_dimid - call ncd_defvar(nfid(t) , 'mcdate', ncd_int, 1, dim1id , varid, & - long_name = 'current date (YYYYMMDD)') - call ncd_defvar(nfid(t) , 'mcsec' , ncd_int, 1, dim1id , varid, & - long_name = 'current seconds of current date', units='s') - call ncd_defvar(nfid(t) , 'mdcur' , ncd_int, 1, dim1id , varid, & - long_name = 'current day (from base day)') - call ncd_defvar(nfid(t) , 'mscur' , ncd_int, 1, dim1id , varid, & - long_name = 'current seconds of current day') - call ncd_defvar(nfid(t) , 'nstep' , ncd_int, 1, dim1id , varid, & - long_name = 'time step') - - dim2id(1) = hist_interval_dimid; dim2id(2) = time_dimid - call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & - long_name = 'history time interval endpoints') - - dim2id(1) = strlen_dimid; dim2id(2) = time_dimid - call ncd_defvar(nfid(t), 'date_written', ncd_char, 2, dim2id, varid) - call ncd_defvar(nfid(t), 'time_written', ncd_char, 2, dim2id, varid) - - call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, dim1name='lon', & - long_name='runoff coordinate longitude', units='degrees_east', ncid=nfid(t)) - call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, dim1name='lat', & - long_name='runoff coordinate latitude', units='degrees_north', ncid=nfid(t)) - call ncd_defvar(varname='mask', xtype=ncd_int, dim1name='lon', dim2name='lat', & - long_name='runoff mask', units='unitless', ncid=nfid(t), ifill_value=ispval) - call ncd_defvar(varname='area', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & - long_name='runoff grid area', units='m2', ncid=nfid(t), fill_value=spval) - call ncd_defvar(varname='areatotal', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & - long_name='basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) - call ncd_defvar(varname='areatotal2', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & - long_name='computed basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) - - else if (mode == 'write') then - - call get_curr_time (mdcur, mscur) - call get_curr_date (yr, mon, day, mcsec) - mcdate = yr*10000 + mon*100 + day - nstep = get_nstep() - - call ncd_io('mcdate', mcdate, 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('mcsec' , mcsec , 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('mdcur' , mdcur , 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('mscur' , mscur , 'write', nfid(t), nt=tape(t)%ntimes) - call ncd_io('nstep' , nstep , 'write', nfid(t), nt=tape(t)%ntimes) - - time = mdcur + mscur/secspday - call ncd_io('time' , time , 'write', nfid(t), nt=tape(t)%ntimes) - - timedata(1) = tape(t)%begtime - timedata(2) = time - call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) - - call getdatetime (cdate, ctime) - call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) - - call ncd_io('time_written', ctime, 'write', nfid(t), nt=tape(t)%ntimes) - - call ncd_io(varname='lon', data=rtmCTL%rlon, ncid=nfid(t), flag='write') - call ncd_io(varname='lat', data=rtmCTL%rlat, ncid=nfid(t), flag='write') - call ncd_io(flag='write', varname='mask', dim1name='allrof', & - data=rtmCTL%mask, ncid=nfid(t)) - call ncd_io(flag='write', varname='area', dim1name='allrof', & - data=rtmCTL%area, ncid=nfid(t)) - call ncd_io(flag='write', varname='areatotal', dim1name='allrof', & - data=Tunit%areatotal, ncid=nfid(t)) - call ncd_io(flag='write', varname='areatotal2', dim1name='allrof', & - data=Tunit%areatotal2, ncid=nfid(t)) - - endif - - end subroutine htape_timeconst - -!----------------------------------------------------------------------- - - subroutine RtmHistHtapesWrapup( rstwr, nlend ) - - ! DESCRIPTION: - ! Write history tape(s) - ! Determine if next time step is beginning of history interval and if so: - ! increment the current time sample counter, open a new history file - ! and if needed (i.e., when ntim = 1), write history data to current - ! history file, reset field accumulation counters to zero. - ! If primary history file is full or at the last time step of the simulation, - ! write restart dataset and close all history fiels. - ! If history file is full or at the last time step of the simulation: - ! close history file - ! and reset time sample counter to zero if file is full. - ! Daily-averaged data for the first day in September are written on - ! date = 00/09/02 with mscur = 0. - ! Daily-averaged data for the first day in month mm are written on - ! date = yyyy/mm/02 with mscur = 0. - ! Daily-averaged data for the 30th day (last day in September) are written - ! on date = 0000/10/01 mscur = 0. - ! Daily-averaged data for the last day in month mm are written on - ! date = yyyy/mm+1/01 with mscur = 0. - - - ! !ARGUMENTS: - implicit none - logical, intent(in) :: rstwr ! true => write restart file this step - logical, intent(in) :: nlend ! true => end of run on this step - - ! !LOCAL VARIABLES: - integer :: begrof, endrof ! beg and end rof indices - integer :: t,f,k,nt ! indices - integer :: nstep ! current step - integer :: day ! current day (1 -> 31) - integer :: mon ! current month (1 -> 12) - integer :: yr ! current year (0 -> ...) - integer :: mdcur ! current day - integer :: mscur ! seconds of current day - integer :: mcsec ! current time of day [seconds] - integer :: daym1 ! nstep-1 day (1 -> 31) - integer :: monm1 ! nstep-1 month (1 -> 12) - integer :: yrm1 ! nstep-1 year (0 -> ...) - integer :: mcsecm1 ! nstep-1 time of day [seconds] - real(r8):: time ! current time - character(len=256):: str ! global attribute string - character(len=1) :: avgflag ! averaging flag - real(r8), pointer :: histo(:) ! temporary - real(r8), pointer :: hbuf(:) ! history buffer - integer , pointer :: nacs(:) ! accumulation counter - character(len=32) :: avgstr ! time averaging type - character(len=max_chars) :: long_name ! long name - character(len=max_chars) :: units ! units - character(len=max_namlen):: varname ! variable name - character(len=*),parameter :: subname = 'hist_htapes_wrapup' - !----------------------------------------------------------- - - begrof = rtmCTL%begr - endrof = rtmCTL%endr - - ! get current step - nstep = get_nstep() - - ! Set calendar for current time step - call get_curr_date (yr, mon, day, mcsec) - call get_curr_time (mdcur, mscur) - time = mdcur + mscur/secspday - - ! Set calendar for current for previous time step - call get_prev_date (yrm1, monm1, daym1, mcsecm1) - - ! Loop over active history tapes, create new history files if necessary - ! and write data to history files if end of history interval. - do t = 1, ntapes - - ! Determine if end of history interval - tape(t)%is_endhist = .false. - if (tape(t)%nhtfrq==0) then !monthly average - if (mon /= monm1) then - tape(t)%is_endhist = .true. - end if - else - if (mod(nstep,tape(t)%nhtfrq) == 0) then - tape(t)%is_endhist = .true. - end if - end if - - ! If end of history interval - if (tape(t)%is_endhist) then - - ! Normalize by number of accumulations for time averaged case - do f = 1,tape(t)%nflds - avgflag = tape(t)%hlist(f)%avgflag - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - do k = begrof, endrof - if ((avgflag == 'A') .and. nacs(k) /= 0) then - hbuf(k) = hbuf(k) / float(nacs(k)) - end if - end do - end do - - ! Increment current time sample counter. - tape(t)%ntimes = tape(t)%ntimes + 1 - - ! Create history file if appropriate and build time comment - - ! If first time sample, generate unique history file name, open file, - ! define dims, vars, etc. - - if (tape(t)%ntimes == 1) then - locfnh(t) = set_hist_filename (hist_freq=tape(t)%nhtfrq, & - rtmhist_mfilt=tape(t)%mfilt, hist_file=t) - if (masterproc) then - write(iulog,*) trim(subname),' : Creating history file ', trim(locfnh(t)), & - ' at nstep = ',get_nstep() - write(iulog,*)'calling htape_create for file t = ',t - endif - call htape_create (t) - - ! Define time-constant field variables - call htape_timeconst(t, mode='define') - - ! Define model field variables - - do f = 1,tape(t)%nflds - varname = tape(t)%hlist(f)%field%name - long_name = tape(t)%hlist(f)%field%long_name - units = tape(t)%hlist(f)%field%units - avgflag = tape(t)%hlist(f)%avgflag - - select case (avgflag) - case ('A') - avgstr = 'mean' - case ('I') - avgstr = 'instantaneous' - case ('X') - avgstr = 'maximum' - case ('M') - avgstr = 'minimum' - case default - write(iulog,*) trim(subname),& - ' ERROR: unknown time averaging flag (avgflag)=',avgflag - call shr_sys_abort() - end select - call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & - dim1name='lon', dim2name='lat', dim3name='time', & - long_name=long_name, units=units, cell_method=avgstr, & - missing_value=spval, fill_value=spval) - end do - - ! Exit define model - call ncd_enddef(nfid(t)) - - endif - - ! Write time constant history variables - call htape_timeconst(t, mode='write') - - if (masterproc) then - write(iulog,*) - write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & - trim(locfnh(t)),' at nstep = ',get_nstep(), & - ' for history time interval beginning at ', tape(t)%begtime, & - ' and ending at ',time - write(iulog,*) - call shr_sys_flush(iulog) - endif - - ! Update beginning time of next interval - tape(t)%begtime = time - - ! Write history time slice - do f = 1,tape(t)%nflds - varname = tape(t)%hlist(f)%field%name - nt = tape(t)%ntimes - histo => tape(t)%hlist(f)%hbuf - call ncd_io(flag='write', varname=varname, dim1name='allrof', & - data=histo, ncid=nfid(t), nt=nt) - end do - - ! Zero necessary history buffers - do f = 1,tape(t)%nflds - tape(t)%hlist(f)%hbuf(:) = 0._r8 - tape(t)%hlist(f)%nacs(:) = 0 - end do - - end if - - end do ! end loop over history tapes - - ! Close open history files - ! Auxilary files may have been closed and saved off without being full, - ! must reopen the files - - do t = 1, ntapes - if (nlend) then - if_close(t) = .true. - else if (rstwr) then - if_close(t) = .true. - else - if (tape(t)%ntimes == tape(t)%mfilt) then - if_close(t) = .true. - else - if_close(t) = .false. - end if - endif - if (if_close(t)) then - if (tape(t)%ntimes /= 0) then - if (masterproc) then - write(iulog,*) - write(iulog,*) trim(subname),' : Closing local history file ',& - trim(locfnh(t)),' at nstep = ', get_nstep() - write(iulog,*) - endif - call ncd_pio_closefile(nfid(t)) - if ((.not.nlend) .and. (tape(t)%ntimes/=tape(t)%mfilt)) then - call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) - end if - else - if (masterproc) then - write(iulog,*) trim(subname),' : history tape ',t,': no open file to close' - end if - endif - if (tape(t)%ntimes==tape(t)%mfilt) then - tape(t)%ntimes = 0 - end if - endif - end do - - end subroutine RtmHistHtapesWrapup - -!----------------------------------------------------------------------- - - subroutine RtmHistRestart (ncid, flag, rdate) - ! !DESCRIPTION: - ! Read/write history file restart data. - ! If the current history file(s) are not full, file(s) are opened - ! so that subsequent time samples are added until the file is full. - ! A new history file is used on a branch run. - - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file - character(len=*) , intent(in) :: flag !'read' or 'write' - character(len=*) , intent(in), optional :: rdate ! restart file time stamp for name - - ! !LOCAL VARIABLES: - integer :: max_nflds ! max number of fields - integer :: begrof ! per-proc beginning ocean runoff index - integer :: endrof ! per-proc ending ocean runoff index - character(len=max_namlen) :: name ! variable name - character(len=max_namlen) :: name_acc ! accumulator variable name - character(len=max_namlen) :: long_name ! long name of variable - character(len=max_chars) :: long_name_acc ! long name for accumulator - character(len=max_chars) :: units ! units of variable - character(len=max_chars) :: units_acc ! accumulator units - character(len=max_chars) :: fname ! full name of history file - character(len=max_chars) :: locrest(max_tapes) ! local history restart file names - character(len=1) :: hnum ! history file index - type(var_desc_t) :: name_desc ! variable descriptor for name - type(var_desc_t) :: longname_desc ! variable descriptor for long_name - type(var_desc_t) :: units_desc ! variable descriptor for units - type(var_desc_t) :: avgflag_desc ! variable descriptor for avgflag - integer :: status ! error status - integer :: dimid ! dimension ID - integer :: start(2) ! Start array index - integer :: k ! 1d index - integer :: t ! tape index - integer :: f ! field index - integer :: varid ! variable id - integer, allocatable :: itemp2d(:,:) ! 2D temporary - real(r8), pointer :: hbuf(:) ! history buffer - integer , pointer :: nacs(:) ! accumulation counter - character(len=*),parameter :: subname = 'hist_restart_ncd' - !--------------------------------------------------------- - - ! If branch run, initialize file times and return - - if (flag == 'read') then - if (nsrest == nsrBranch) then - do t = 1,ntapes - tape(t)%ntimes = 0 - end do - RETURN - end if - ! If startup run just return - if (nsrest == nsrStartup) then - RETURN - end if - endif - - ! Read history file data only for restart run (not for branch run) - - ! First when writing out and in define mode, create files and define all variables - !================================================ - if (flag == 'define') then - !================================================ - - if (.not. present(rdate)) then - call shr_sys_abort('variable rdate must be present for writing restart files') - end if - - ! - ! On master restart file add ntapes/max_chars dimension - ! and then add the history and history restart filenames - ! - call ncd_defdim( ncid, 'ntapes' , ntapes , dimid) - call ncd_defdim( ncid, 'max_chars' , max_chars , dimid) - - call ncd_defvar(ncid=ncid, varname='locfnh', xtype=ncd_char, & - long_name="History filename", & - comment="This variable NOT needed for startup or branch simulations", & - dim1name='max_chars', dim2name="ntapes" ) - call ncd_defvar(ncid=ncid, varname='locfnhr', xtype=ncd_char, & - long_name="Restart history filename", & - comment="This variable NOT needed for startup or branch simulations", & - dim1name='max_chars', dim2name="ntapes" ) - - ! max_nflds is the maximum number of fields on any tape - ! max_flds is the maximum number possible number of fields - max_nflds = max_nFields() - - ! Loop over tapes - write out namelist information to each restart-history tape - ! only read/write accumulators and counters if needed - - do t = 1,ntapes - ! - ! Create the restart history filename and open it - ! - write(hnum,'(i1.1)') t-1 - locfnhr(t) = "./" // trim(caseid) //".mosart"// trim(inst_suffix) & - // ".rh" // hnum //"."// trim(rdate) //".nc" - call htape_create( t, histrest=.true. ) - ! - ! Add read/write accumultators and counters if needed - ! - if (.not. tape(t)%is_endhist) then - do f = 1,tape(t)%nflds - name = tape(t)%hlist(f)%field%name - long_name = tape(t)%hlist(f)%field%long_name - units = tape(t)%hlist(f)%field%units - name_acc = trim(name) // "_acc" - units_acc = "unitless positive integer" - long_name_acc = trim(long_name) // " accumulator number of samples" - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - - call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & - dim1name='lon', dim2name='lat', & - long_name=trim(long_name), units=trim(units)) - call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & - dim1name='lon', dim2name='lat', & - long_name=trim(long_name_acc), units=trim(units_acc)) - end do - endif - - ! - ! Add namelist information to each restart history tape - ! - call ncd_defdim( ncid_hist(t), 'fname_lenp2' , max_namlen+2, dimid) - call ncd_defdim( ncid_hist(t), 'fname_len' , max_namlen , dimid) - call ncd_defdim( ncid_hist(t), 'len1' , 1 , dimid) - call ncd_defdim( ncid_hist(t), 'scalar' , 1 , dimid) - call ncd_defdim( ncid_hist(t), 'max_chars' , max_chars , dimid) - call ncd_defdim( ncid_hist(t), 'max_nflds' , max_nflds , dimid) - call ncd_defdim( ncid_hist(t), 'max_flds' , max_flds , dimid) - - call ncd_defvar(ncid=ncid_hist(t), varname='nhtfrq', xtype=ncd_int, & - long_name="Frequency of history writes", & - comment="Namelist item", & - units="absolute value of negative is in hours, 0=monthly, positive is time-steps", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='mfilt', xtype=ncd_int, & - long_name="Number of history time samples on a file", units="unitless", & - comment="Namelist item", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='ncprec', xtype=ncd_int, & - long_name="Flag for data precision", flag_values=(/1,2/), & - comment="Namelist item", & - nvalid_range=(/1,2/), & - flag_meanings=(/"single-precision", "double-precision"/), & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='fincl', xtype=ncd_char, & - comment="Namelist item", & - long_name="Fieldnames to include", & - dim1name='fname_lenp2', dim2name='max_flds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='fexcl', xtype=ncd_char, & - comment="Namelist item", & - long_name="Fieldnames to exclude", & - dim1name='fname_lenp2', dim2name='max_flds' ) - - call ncd_defvar(ncid=ncid_hist(t), varname='nflds', xtype=ncd_int, & - long_name="Number of fields on file", units="unitless", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='ntimes', xtype=ncd_int, & - long_name="Number of time steps on file", units="time-step", & - dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='is_endhist', xtype=ncd_log, & - long_name="End of history file", dim1name='scalar') - call ncd_defvar(ncid=ncid_hist(t), varname='begtime', xtype=ncd_double, & - long_name="Beginning time", units="time units", & - dim1name='scalar') - - call ncd_defvar(ncid=ncid_hist(t), varname='hpindex', xtype=ncd_int, & - long_name="History pointer index", units="unitless", & - dim1name='max_nflds' ) - - call ncd_defvar(ncid=ncid_hist(t), varname='avgflag', xtype=ncd_char, & - long_name="Averaging flag", & - units="A=Average, X=Maximum, M=Minimum, I=Instantaneous", & - dim1name='len1', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='name', xtype=ncd_char, & - long_name="Fieldnames", & - dim1name='fname_len', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='long_name', xtype=ncd_char, & - long_name="Long descriptive names for fields", & - dim1name='max_chars', dim2name='max_nflds' ) - call ncd_defvar(ncid=ncid_hist(t), varname='units', xtype=ncd_char, & - long_name="Units for each history field output", & - dim1name='max_chars', dim2name='max_nflds' ) - call ncd_enddef(ncid_hist(t)) - - end do ! end of ntapes loop - - RETURN - - !================================================ - else if (flag == 'write') then - !================================================ - ! Add history filenames to master restart file - do t = 1,ntapes - call ncd_io('locfnh', locfnh(t), 'write', ncid, nt=t) - call ncd_io('locfnhr', locfnhr(t), 'write', ncid, nt=t) - end do - - fincl(:,1) = rtmhist_fincl1(:) - fincl(:,2) = rtmhist_fincl2(:) - fincl(:,3) = rtmhist_fincl3(:) - - fexcl(:,1) = rtmhist_fexcl1(:) - fexcl(:,2) = rtmhist_fexcl2(:) - fexcl(:,3) = rtmhist_fexcl3(:) - - max_nflds = max_nFields() - - start(1)=1 - - - ! Add history namelist data to each history restart tape - allocate(itemp2d(max_nflds,ntapes)) - do t = 1,ntapes - call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) - call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) - call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) - call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) - - call ncd_io(varname='fincl' , data=fincl(:,t) , ncid=ncid_hist(t), flag='write') - call ncd_io(varname='fexcl' , data=fexcl(:,t) , ncid=ncid_hist(t), flag='write') - call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='write') - - itemp2d(:,:) = 0 - do f=1,tape(t)%nflds - itemp2d(f,t) = tape(t)%hlist(f)%field%hpindex - end do - call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') - - call ncd_io('nflds' , tape(t)%nflds, 'write', ncid_hist(t)) - call ncd_io('ntimes', tape(t)%ntimes, 'write', ncid_hist(t)) - call ncd_io('nhtfrq', tape(t)%nhtfrq, 'write', ncid_hist(t)) - call ncd_io('mfilt' , tape(t)%mfilt, 'write', ncid_hist(t)) - call ncd_io('ncprec', tape(t)%ncprec, 'write', ncid_hist(t)) - call ncd_io('begtime', tape(t)%begtime, 'write', ncid_hist(t)) - do f=1,tape(t)%nflds - start(2) = f - call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & - 'write', ncid_hist(t), start ) - call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & - 'write', ncid_hist(t), start ) - call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & - 'write', ncid_hist(t), start ) - call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & - 'write', ncid_hist(t), start ) - end do - end do - deallocate(itemp2d) - - !================================================ - else if (flag == 'read') then - !================================================ - - call ncd_inqdlen(ncid,dimid,ntapes, name='ntapes') - call ncd_io('locfnh', locfnh(1:ntapes), 'read', ncid ) - call ncd_io('locfnhr', locrest(1:ntapes), 'read', ncid ) - do t = 1,ntapes - call strip_null(locrest(t)) - call strip_null(locfnh(t)) - end do - - ! Determine necessary indices - the following is needed if model decomposition - ! is different on restart - begrof = rtmCTL%begr - endrof = rtmCTL%endr - - start(1)=1 - do t = 1,ntapes - call getfil( locrest(t), locfnhr(t), 0 ) - call ncd_pio_openfile (ncid_hist(t), trim(locfnhr(t)), ncd_nowrite) - - if ( t == 1 )then - call ncd_inqdlen(ncid_hist(1),dimid,max_nflds,name='max_nflds') - allocate(itemp2d(max_nflds,ntapes)) - end if - - call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) - call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) - call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) - call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) - - call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='read') - call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='read') - - call ncd_io('nflds', tape(t)%nflds, 'read', ncid_hist(t) ) - call ncd_io('ntimes', tape(t)%ntimes, 'read', ncid_hist(t) ) - call ncd_io('nhtfrq', tape(t)%nhtfrq, 'read', ncid_hist(t) ) - call ncd_io('mfilt', tape(t)%mfilt, 'read', ncid_hist(t) ) - call ncd_io('ncprec', tape(t)%ncprec, 'read', ncid_hist(t) ) - call ncd_io('begtime', tape(t)%begtime,'read', ncid_hist(t) ) - - call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='read') - call ncd_io(varname='hpindex' , data=itemp2d(:,t) , ncid=ncid_hist(t), flag='read') - do f=1,tape(t)%nflds - tape(t)%hlist(f)%field%hpindex = itemp2d(f,t) - end do - - do f=1,tape(t)%nflds - start(2) = f - call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & - 'read', ncid_hist(t), start ) - call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & - 'read', ncid_hist(t), start ) - call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & - 'read', ncid_hist(t), start ) - call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & - 'read', ncid_hist(t), start ) - call strip_null(tape(t)%hlist(f)%field%name) - call strip_null(tape(t)%hlist(f)%field%long_name) - call strip_null(tape(t)%hlist(f)%field%units) - call strip_null(tape(t)%hlist(f)%avgflag) - - allocate (tape(t)%hlist(f)%hbuf(begrof:endrof), & - tape(t)%hlist(f)%nacs(begrof:endrof), stat=status) - if (status /= 0) then - write(iulog,*) trim(subname),' ERROR: allocation error for hbuf,nacs at t,f=',t,f - call shr_sys_abort() - endif - tape(t)%hlist(f)%hbuf(:) = 0._r8 - tape(t)%hlist(f)%nacs(:) = 0 - end do ! end of flds loop - - ! If history file is not full, open it - - if (tape(t)%ntimes /= 0) then - call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) - end if - - end do ! end of tapes loop - - rtmhist_fincl1(:) = fincl(:,1) - rtmhist_fincl2(:) = fincl(:,2) - rtmhist_fincl3(:) = fincl(:,3) - - rtmhist_fexcl1(:) = fexcl(:,1) - rtmhist_fexcl2(:) = fexcl(:,2) - rtmhist_fexcl3(:) = fexcl(:,3) - - if ( allocated(itemp2d) ) deallocate(itemp2d) - - end if - - ! Read/write history file restart data. - ! If the current history file(s) are not full, file(s) are opened - ! so that subsequent time samples are added until the file is full. - ! A new history file is used on a branch run. - - if (flag == 'write') then - - do t = 1,ntapes - if (.not. tape(t)%is_endhist) then - do f = 1,tape(t)%nflds - name = tape(t)%hlist(f)%field%name - name_acc = trim(name) // "_acc" - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - - call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & - dim1name='allrof', data=hbuf) - call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & - dim1name='allrof', data=nacs) - end do - end if ! end of is_endhist block - call ncd_pio_closefile(ncid_hist(t)) - end do ! end of ntapes loop - - else if (flag == 'read') then - - ! Read history restart information if history files are not full - do t = 1,ntapes - if (.not. tape(t)%is_endhist) then - do f = 1,tape(t)%nflds - name = tape(t)%hlist(f)%field%name - name_acc = trim(name) // "_acc" - nacs => tape(t)%hlist(f)%nacs - hbuf => tape(t)%hlist(f)%hbuf - - call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & - dim1name='allrof', data=hbuf) - call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & - dim1name='allrof', data=nacs) - end do - end if - call ncd_pio_closefile(ncid_hist(t)) - end do - - end if - - end subroutine RtmHistRestart - -!----------------------------------------------------------------------- - - integer function max_nFields() - - ! DESCRIPTION: - ! Get the maximum number of fields on all tapes. - - ! ARGUMENTS: - implicit none - - ! LOCAL VARIABLES: - integer :: t ! index - character(len=*),parameter :: subname = 'max_nFields' - - max_nFields = 0 - do t = 1,ntapes - max_nFields = max(max_nFields, tape(t)%nflds) - end do - - end function max_nFields - -!----------------------------------------------------------------------- - - character(len=max_namlen) function getname (inname) - - ! DESCRIPTION: - ! Retrieve name portion of inname. If an averaging flag separater character - ! is present (:) in inname, lop it off. - - ! ARGUMENTS: - implicit none - character(len=*), intent(in) :: inname - - integer :: length - integer :: i - character(len=*),parameter :: subname = 'getname' - - length = len (inname) - if (length < max_namlen .or. length > max_namlen+2) then - write(iulog,*) trim(subname),' ERROR: bad length=',length - call shr_sys_abort() - end if - - getname = ' ' - do i = 1,max_namlen - if (inname(i:i) == ':') exit - getname(i:i) = inname(i:i) - end do - - end function getname - -!----------------------------------------------------------------------- - - character(len=1) function getflag (inname) - - ! DESCRIPTION: - ! Retrieve flag portion of inname. If an averaging flag separater character - ! is present (:) in inname, return the character after it as the flag - - ! ARGUMENTS: - implicit none - character(len=*) inname ! character string - - ! LOCAL VARIABLES: - integer :: length ! length of inname - integer :: i ! loop index - character(len=*),parameter :: subname = 'getflag' - - length = len (inname) - if (length < max_namlen .or. length > max_namlen+2) then - write(iulog,*) trim(subname),' ERROR: bad length=',length - call shr_sys_abort() - end if - - getflag = ' ' - do i = 1,length - if (inname(i:i) == ':') then - getflag = inname(i+1:i+1) - exit - end if - end do - - end function getflag - -!----------------------------------------------------------------------- - - subroutine list_index (list, name, index) - - ! ARGUMENTS: - implicit none - character(len=*), intent(in) :: list(max_flds) ! input list of names, possibly ":" delimited - character(len=max_namlen), intent(in) :: name ! name to be searched for - integer, intent(out) :: index ! index of "name" in "list" - - ! !LOCAL VARIABLES: - character(len=max_namlen) :: listname ! input name with ":" stripped off. - integer f ! field index - character(len=*),parameter :: subname = 'list_index' - - ! Only list items - index = 0 - do f=1,max_flds - listname = getname (list(f)) - if (listname == ' ') exit - if (listname == name) then - index = f - exit - end if - end do - - end subroutine list_index - -!----------------------------------------------------------------------- - - character(len=max_length_filename) function set_hist_filename (hist_freq, rtmhist_mfilt, hist_file) - - ! Determine history dataset filenames. - - ! !ARGUMENTS: - implicit none - integer, intent(in) :: hist_freq !history file frequency - integer, intent(in) :: rtmhist_mfilt !history file number of time-samples - integer, intent(in) :: hist_file !history file index - - ! !LOCAL VARIABLES: - character(len=256) :: cdate !date char string - character(len= 1) :: hist_index !p,1 or 2 (currently) - integer :: day !day (1 -> 31) - integer :: mon !month (1 -> 12) - integer :: yr !year (0 -> ...) - integer :: sec !seconds into current day - integer :: filename_length - character(len=*),parameter :: subname = 'set_hist_filename' - - if (hist_freq == 0 .and. rtmhist_mfilt == 1) then !monthly - call get_prev_date (yr, mon, day, sec) - write(cdate,'(i4.4,"-",i2.2)') yr,mon - else !other - call get_curr_date (yr, mon, day, sec) - write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec - endif - write(hist_index,'(i1.1)') hist_file - 1 - set_hist_filename = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//& - ".h"//hist_index//"."//trim(cdate)//".nc" - - ! check to see if the concatenated filename exceeded the - ! length. Simplest way to do this is ensure that the file - ! extension is '.nc'. - filename_length = len_trim(set_hist_filename) - if (set_hist_filename(filename_length-2:filename_length) /= '.nc') then - write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & - ' : expected file extension ".nc", received extension "', & - set_hist_filename(filename_length-2:filename_length), '"' - write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & - ' : filename : "', set_hist_filename, '"' - write(iulog, '(a,a,a,i3,a,i3)') 'ERROR: ', subname, & - ' Did the constructed filename exceed the maximum length? : filename length = ', & - filename_length, ', max length = ', max_length_filename - call shr_sys_abort(errMsg(__FILE__, __LINE__)) - end if - end function set_hist_filename - -!------------------------------------------------------------------------ - - subroutine RtmHistAddfld (fname, units, avgflag, long_name, ptr_rof, default) - - ! Initialize a single level history field. - - ! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: fname ! field name - character(len=*), intent(in) :: units ! units of field - character(len=1), intent(in) :: avgflag ! time averaging flag - character(len=*), intent(in) :: long_name ! long name of field - real(r8) , pointer :: ptr_rof(:) ! pointer to channel runoff - character(len=*), optional, intent(in) :: default ! if set to 'inactive, - ! field will not appear on primary tape - - ! !LOCAL VARIABLES: - integer :: n ! loop index - integer :: f ! masterlist index - integer :: hpindex ! history buffer pointer index - logical :: found ! flag indicates field found in masterlist - integer, save :: lastindex = 1 - character(len=*),parameter :: subname = 'RtmHistAddfld' - !------------------------------------------------------ - - ! History buffer pointer - - hpindex = lastindex - rtmptr(hpindex)%ptr => ptr_rof - lastindex = lastindex + 1 - if (lastindex > max_mapflds) then - write(iulog,*) trim(subname),' ERROR: ',& - ' lastindex = ',lastindex,' greater than max_mapflds= ',max_mapflds - call shr_sys_abort() - endif - - ! Add field to masterlist - - if (fname == ' ') then - write(iulog,*) trim(subname),' ERROR: blank field name not allowed' - call shr_sys_abort() - end if - do n = 1,nfmaster - if (masterlist(n)%field%name == fname) then - write(iulog,*) trim(subname),' ERROR:', fname, ' already on list' - call shr_sys_abort() - end if - end do - nfmaster = nfmaster + 1 - f = nfmaster - if (nfmaster > max_flds) then - write(iulog,*) trim(subname),' ERROR: too many fields for primary history file ', & - '-- max_flds,nfmaster=', max_flds, nfmaster - call shr_sys_abort() - end if - masterlist(f)%field%name = fname - masterlist(f)%field%long_name = long_name - masterlist(f)%field%units = units - masterlist(f)%field%hpindex = hpindex - - ! The next two fields are only in master field list, NOT in runtime active field list - ! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE FLAG SET TO FALSE - masterlist(f)%avgflag(:) = avgflag - masterlist(f)%actflag(:) = .false. - - if (present(default)) then - if (trim(default) == 'inactive') return - endif - - ! Look through master list for input field name. - ! When found, set active flag for that tape to true. - found = .false. - do f = 1,nfmaster - if (trim(fname) == trim(masterlist(f)%field%name)) then - masterlist(f)%actflag(1) = .true. - found = .true. - exit - end if - end do - if (.not. found) then - write(iulog,*) trim(subname),' ERROR: field=', fname, ' not found' - call shr_sys_abort() - end if - - end subroutine RtmHistAddfld - -!----------------------------------------------------------------------- - - subroutine strip_null(str) - character(len=*), intent(inout) :: str - integer :: i - do i=1,len(str) - if(ichar(str(i:i))==0) str(i:i)=' ' - end do - end subroutine strip_null - -end module RtmHistFile diff --git a/src/riverroute/RtmHistFlds.F90 b/src/riverroute/RtmHistFlds.F90 deleted file mode 100644 index 8550930..0000000 --- a/src/riverroute/RtmHistFlds.F90 +++ /dev/null @@ -1,186 +0,0 @@ -module RtmHistFlds - -!----------------------------------------------------------------------- -! !DESCRIPTION: -! Module containing initialization of RTM history fields and files -! This is the module that the user must modify in order to add new -! history fields or modify defaults associated with existing history -! fields. -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use RunoffMod , only : rtmCTL - use RtmHistFile , only : RtmHistAddfld, RtmHistPrintflds - use RtmVar , only : nt_rtm, rtm_tracers - - implicit none -! -! !PUBLIC MEMBER FUNCTIONS: - public :: RtmHistFldsInit - public :: RtmHistFldsSet -! -!------------------------------------------------------------------------ - -contains - -!----------------------------------------------------------------------- - - subroutine RtmHistFldsInit() - - !------------------------------------------------------- - ! DESCRIPTION: - ! Build master field list of all possible fields in a history file. - ! Each field has associated with it a ``long\_name'' netcdf attribute that - ! describes what the field is, and a ``units'' attribute. A subroutine is - ! called to add each field to the masterlist. - ! - ! ARGUMENTS: - implicit none - !------------------------------------------------------- - - call RtmHistAddfld (fname='RIVER_DISCHARGE_OVER_LAND'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART river basin flow: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runofflnd_nt1, default='active') - - call RtmHistAddfld (fname='RIVER_DISCHARGE_OVER_LAND'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART river basin flow: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runofflnd_nt2, default='active') - - call RtmHistAddfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART river discharge into ocean: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runoffocn_nt1, default='inactive') - - call RtmHistAddfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART river discharge into ocean: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runoffocn_nt2, default='inactive') - - call RtmHistAddfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART total discharge into ocean: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runofftot_nt1, default='active') - - call RtmHistAddfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART total discharge into ocean: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runofftot_nt2, default='active') - - call RtmHistAddfld (fname='DIRECT_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%runoffdir_nt1, default='active') - - call RtmHistAddfld (fname='DIRECT_DISCHARGE_TO_OCEAN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%runoffdir_nt2, default='active') - - call RtmHistAddfld (fname='STORAGE'//'_'//trim(rtm_tracers(1)), units='m3', & - avgflag='A', long_name='MOSART storage: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%volr_nt1, default='inactive') - - call RtmHistAddfld (fname='STORAGE'//'_'//trim(rtm_tracers(2)), units='m3', & - avgflag='A', long_name='MOSART storage: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%volr_nt2, default='inactive') - - call RtmHistAddfld (fname='STORAGE_MCH', units='m3', & - avgflag='A', long_name='MOSART main channelstorage', & - ptr_rof=rtmCTL%volr_mch, default='inactive') - - call RtmHistAddfld (fname='DVOLRDT_LND'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART land change in storage: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%dvolrdtlnd_nt1, default='inactive') - - call RtmHistAddfld (fname='DVOLRDT_LND'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART land change in storage: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%dvolrdtlnd_nt2, default='inactive') - - call RtmHistAddfld (fname='DVOLRDT_OCN'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART ocean change of storage: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%dvolrdtocn_nt1, default='inactive') - - call RtmHistAddfld (fname='DVOLRDT_OCN'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART ocean change of storage: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%dvolrdtocn_nt2, default='inactive') - - call RtmHistAddfld (fname='QSUR'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART input surface runoff: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%qsur_nt1, default='inactive') - - call RtmHistAddfld (fname='QSUR'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART input surface runoff: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%qsur_nt2, default='inactive') - - call RtmHistAddfld (fname='QSUB'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART input subsurface runoff: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%qsub_nt1, default='inactive') - - call RtmHistAddfld (fname='QSUB'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART input subsurface runoff: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%qsub_nt2, default='inactive') - - call RtmHistAddfld (fname='QGWL'//'_'//trim(rtm_tracers(1)), units='m3/s', & - avgflag='A', long_name='MOSART input GWL runoff: '//trim(rtm_tracers(1)), & - ptr_rof=rtmCTL%qgwl_nt1, default='inactive') - - call RtmHistAddfld (fname='QGWL'//'_'//trim(rtm_tracers(2)), units='m3/s', & - avgflag='A', long_name='MOSART input GWL runoff: '//trim(rtm_tracers(2)), & - ptr_rof=rtmCTL%qgwl_nt2, default='inactive') - - call RtmHistAddfld (fname='QIRRIG_FROM_COUPLER', units='m3/s', & - avgflag='A', long_name='Amount of water used for irrigation (total flux received from coupler)', & - ptr_rof=rtmCTL%qirrig, default='inactive') - - call RtmHistAddfld (fname='QIRRIG_ACTUAL', units='m3/s', & - avgflag='A', long_name='Actual irrigation (if limited by river storage)', & - ptr_rof=rtmCTL%qirrig_actual, default='inactive') - - ! Print masterlist of history fields - - call RtmHistPrintflds() - - end subroutine RtmHistFldsInit - -!----------------------------------------------------------------------- - - subroutine RtmHistFldsSet() - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Set mosart history fields as 1d poitner arrays - ! - implicit none - !----------------------------------------------------------------------- - - ! Currently only have two tracers - - rtmCTL%runofflnd_nt1(:) = rtmCTL%runofflnd(:,1) - rtmCTL%runofflnd_nt2(:) = rtmCTL%runofflnd(:,2) - - rtmCTL%runoffocn_nt1(:) = rtmCTL%runoffocn(:,1) - rtmCTL%runoffocn_nt2(:) = rtmCTL%runoffocn(:,2) - - rtmCTL%runofftot_nt1(:) = rtmCTL%runofftot(:,1) - rtmCTL%runofftot_nt2(:) = rtmCTL%runofftot(:,2) - - rtmCTL%runoffdir_nt1(:) = rtmCTL%direct(:,1) - rtmCTL%runoffdir_nt2(:) = rtmCTL%direct(:,2) - - rtmCTL%dvolrdtlnd_nt1(:) = rtmCTL%dvolrdtlnd(:,1) - rtmCTL%dvolrdtlnd_nt2(:) = rtmCTL%dvolrdtlnd(:,2) - - rtmCTL%dvolrdtocn_nt1(:) = rtmCTL%dvolrdtocn(:,1) - rtmCTL%dvolrdtocn_nt2(:) = rtmCTL%dvolrdtocn(:,2) - - rtmCTL%volr_nt1(:) = rtmCTL%volr(:,1) - rtmCTL%volr_nt2(:) = rtmCTL%volr(:,2) - rtmCTL%volr_mch(:) = rtmCTL%wr(:,1) - - rtmCTL%qsub_nt1(:) = rtmCTL%qsub(:,1) - rtmCTL%qsub_nt2(:) = rtmCTL%qsub(:,2) - - rtmCTL%qsur_nt1(:) = rtmCTL%qsur(:,1) - rtmCTL%qsur_nt2(:) = rtmCTL%qsur(:,2) - - rtmCTL%qgwl_nt1(:) = rtmCTL%qgwl(:,1) - rtmCTL%qgwl_nt2(:) = rtmCTL%qgwl(:,2) - - end subroutine RtmHistFldsSet - - -end module RtmHistFlds diff --git a/src/riverroute/RtmIO.F90 b/src/riverroute/RtmIO.F90 deleted file mode 100644 index 3e676ba..0000000 --- a/src/riverroute/RtmIO.F90 +++ /dev/null @@ -1,1945 +0,0 @@ -module RtmIO - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: RtmIO -! -! !DESCRIPTION: -! Generic interfaces to write fields to netcdf files for RTM -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8, i8=>shr_kind_i8, shr_kind_cl, r4=>shr_kind_r4 - use shr_sys_mod , only : shr_sys_flush, shr_sys_abort - use shr_file_mod , only : shr_file_getunit, shr_file_freeunit - use RtmFileUtils , only : getavu, relavu - use RtmSpmd , only : masterproc, mpicom_rof, iam, npes, rofid - use RunoffMod , only : rtmCTL - use RtmVar , only : spval, ispval, iulog - use perf_mod , only : t_startf, t_stopf - use mct_mod - use pio - -! !PUBLIC TYPES: - implicit none - private - save -! -! !PUBLIC MEMBER FUNCTIONS: -! - public :: check_var ! determine if variable is on netcdf file - public :: check_dim ! validity check on dimension - public :: ncd_pio_openfile ! open a file - public :: ncd_pio_createfile ! create a new file - public :: ncd_pio_closefile ! close a file - public :: ncd_pio_init ! called from rtm_comp - public :: ncd_enddef ! end define mode - public :: ncd_putatt ! put attribute - public :: ncd_defdim ! define dimension - public :: ncd_inqdid ! inquire dimension id - public :: ncd_inqdname ! inquire dimension name - public :: ncd_inqdlen ! inquire dimension length - public :: ncd_inqfdims ! inquire file dimnesions - public :: ncd_defvar ! define variables - public :: ncd_inqvid ! inquire variable id - public :: ncd_inqvname ! inquire variable name - public :: ncd_inqvdims ! inquire variable ndims - public :: ncd_inqvdids ! inquire variable dimids - public :: ncd_io ! write local data - - integer,parameter,public :: ncd_int = pio_int - integer,parameter,public :: ncd_log =-pio_int - integer,parameter,public :: ncd_float = pio_real - integer,parameter,public :: ncd_double = pio_double - integer,parameter,public :: ncd_char = pio_char - integer,parameter,public :: ncd_global = pio_global - integer,parameter,public :: ncd_write = pio_write - integer,parameter,public :: ncd_nowrite = pio_nowrite - integer,parameter,public :: ncd_clobber = pio_clobber - integer,parameter,public :: ncd_noclobber = pio_noclobber - integer,parameter,public :: ncd_nofill = pio_nofill - integer,parameter,public :: ncd_unlimited = pio_unlimited - - ! PIO types needed for ncdio_pio interface calls - public file_desc_t - public var_desc_t - public io_desc_t -! -! !REVISION HISTORY: -! -! -! !PRIVATE MEMBER FUNCTIONS: -! - - interface ncd_putatt - module procedure ncd_putatt_int - module procedure ncd_putatt_real - module procedure ncd_putatt_char - end interface - - interface ncd_defvar - module procedure ncd_defvar_bynf - module procedure ncd_defvar_bygrid - end interface - - interface ncd_io - ! global scalar - module procedure ncd_io_log_var0_nf - module procedure ncd_io_int_var0_nf - module procedure ncd_io_real_var0_nf - - ! global 1d - module procedure ncd_io_log_var1_nf - module procedure ncd_io_int_var1_nf - module procedure ncd_io_real_var1_nf - module procedure ncd_io_char_var1_nf - module procedure ncd_io_char_varn_strt_nf - - ! global 2d - module procedure ncd_io_int_var2_nf - module procedure ncd_io_real_var2_nf - module procedure ncd_io_char_var2_nf - - ! local 1d - module procedure ncd_io_log_var1 - module procedure ncd_io_int_var1 - module procedure ncd_io_real_var1 - end interface - - private :: ncd_getiodesc ! obtain iodesc - - integer,parameter,private :: debug = 0 ! local debug level - - integer , parameter , public :: max_string_len = 256 ! length of strings - real(r8), parameter , public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields - - integer :: io_type, io_format - - type(iosystem_desc_t), pointer, public :: pio_subsystem - - type iodesc_plus_type - character(len=64) :: name - type(IO_desc_t) :: iodesc - integer :: type - integer :: ndims - integer :: dims(4) - integer :: dimids(4) - end type iodesc_plus_type - integer,parameter ,private :: max_iodesc = 100 - integer ,private :: num_iodesc = 0 - type(iodesc_plus_type) ,private, target :: iodesc_list(max_iodesc) - -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- - - subroutine ncd_pio_init() - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Initial PIO - ! - ! !USES: - use shr_pio_mod, only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat - ! !ARGUMENTS: - implicit none - ! !LOCAL VARIABLES: - character(len=*),parameter :: subname='ncd_pio_init' ! subroutine name - !----------------------------------------------------------------------- - - PIO_subsystem => shr_pio_getiosys(ROFID) - io_type = shr_pio_getiotype(ROFID) - io_format = shr_pio_getioformat(ROFID) - - end subroutine ncd_pio_init - -!----------------------------------------------------------------------- - - subroutine ncd_pio_openfile(file, fname, mode) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Open a NetCDF PIO file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: file ! Output PIO file handle - character(len=*) , intent(in) :: fname ! Input filename to open - integer , intent(in) :: mode ! file mode - ! !LOCAL VARIABLES: - integer :: ierr - character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name - !----------------------------------------------------------------------- - - ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) - - if(ierr/= PIO_NOERR) then - call shr_sys_abort(subname//'ERROR: Failed to open file') - else if(pio_iotask_rank(pio_subsystem)==0 .and. masterproc) then - write(iulog,*) 'Opened existing file ', trim(fname), file%fh - end if - - end subroutine ncd_pio_openfile - -!----------------------------------------------------------------------- - - subroutine ncd_pio_closefile(file) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Close a NetCDF PIO file - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: file ! PIO file handle to close - !----------------------------------------------------------------------- - - call pio_closefile(file) - - end subroutine ncd_pio_closefile - -!----------------------------------------------------------------------- - - subroutine ncd_pio_createfile(file, fname) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Create a new NetCDF file with PIO - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: file ! PIO file descriptor - character(len=*), intent(in) :: fname ! File name to create - ! !LOCAL VARIABLES: - integer :: ierr - integer :: iomode - character(len=*),parameter :: subname='ncd_pio_createfile' ! subroutine name - !----------------------------------------------------------------------- - - - iomode = PIO_CLOBBER - if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then - iomode = ior(iomode, io_format) - endif - ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) - - if(ierr/= PIO_NOERR) then - call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) - else if(pio_iotask_rank(pio_subsystem)==0 .and. masterproc) then - write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh - end if - - end subroutine ncd_pio_createfile - -!----------------------------------------------------------------------- - - subroutine check_var(ncid, varname, vardesc, readvar, print_err ) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Check if variable is on netcdf file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor - character(len=*) , intent(in) :: varname ! Varible name to check - type(Var_desc_t) , intent(out) :: vardesc ! Output variable descriptor - logical , intent(out) :: readvar ! If variable exists or not - logical, optional, intent(in) :: print_err ! If should print about error - ! !LOCAL VARIABLES: - integer :: ret ! return value - logical :: log_err ! if should log error - character(len=*),parameter :: subname='check_var' ! subroutine name - !----------------------------------------------------------------------- - - - if ( present(print_err) )then - log_err = print_err - else - log_err = .true. - end if - readvar = .true. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ret = PIO_inq_varid (ncid, varname, vardesc) - if (ret /= PIO_noerr) then - readvar = .false. - if (masterproc .and. log_err) & - write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' - end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - - end subroutine check_var - -!----------------------------------------------------------------------- - - subroutine check_dim(ncid, dimname, value) - - ! !DESCRIPTION: - ! Validity check on dimension - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(in) :: ncid ! PIO file handle - character(len=*), intent(in) :: dimname ! Dimension name - integer, intent(in) :: value ! Expected dimension size - ! !LOCAL VARIABLES: - integer :: dimid, dimlen ! temporaries - integer :: status ! error code - character(len=*),parameter :: subname='check_dim' ! subroutine name - !----------------------------------------------------------------------- - - status = pio_inq_dimid (ncid, trim(dimname), dimid) - status = pio_inq_dimlen (ncid, dimid, dimlen) - if (dimlen /= value) then - write(iulog,*) subname//' ERROR: mismatch of input dimension ',dimlen, & - ' with expected value ',value,' for variable ',trim(dimname) - call shr_sys_abort() - end if - - end subroutine check_dim - -!----------------------------------------------------------------------- - - subroutine ncd_enddef(ncid) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! enddef netcdf file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - ! !LOCAL VARIABLES: - integer :: status ! error status - character(len=*),parameter :: subname='ncd_enddef' ! subroutine name - !----------------------------------------------------------------------- - - status = PIO_enddef(ncid) - - end subroutine ncd_enddef - - !----------------------------------------------------------------------- - - subroutine ncd_inqdid(ncid,name,dimid,dimexist) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire on a dimension id - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: name ! dimension name - integer , intent(out):: dimid ! dimension id - logical,optional, intent(out):: dimexist ! if this dimension exists or not - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - if ( present(dimexist) )then - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - end if - status = PIO_inq_dimid(ncid,name,dimid) - if ( present(dimexist) )then - if ( status == PIO_NOERR)then - dimexist = .true. - else - dimexist = .false. - end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - end if - - end subroutine ncd_inqdid - -!----------------------------------------------------------------------- - - subroutine ncd_inqdlen(ncid,dimid,len,name) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! enddef netcdf file - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - integer , intent(inout) :: dimid ! dimension id - integer , intent(out) :: len ! dimension len - character(len=*), optional, intent(in) :: name ! dimension name - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - if ( present(name) )then - call ncd_inqdid(ncid,name,dimid) - end if - len = -1 - status = PIO_inq_dimlen(ncid,dimid,len) - - end subroutine ncd_inqdlen - -!----------------------------------------------------------------------- - - subroutine ncd_inqdname(ncid,dimid,dname) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire dim name - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - integer , intent(in) :: dimid ! dimension id - character(len=*) , intent(out):: dname ! dimension name - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = PIO_inq_dimname(ncid,dimid,dname) - - end subroutine ncd_inqdname - -!----------------------------------------------------------------------- - - subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) - - !----------------------------------------------------------------------- - ! !ARGUMENTS: - type(file_desc_t), intent(inout):: ncid - logical , intent(out) :: isgrid2d - integer , intent(out) :: ni - integer , intent(out) :: nj - integer , intent(out) :: ns - ! !LOCAL VARIABLES: - integer :: dimid ! netCDF id - integer :: ier ! error status - character(len=32) :: subname = 'surfrd_filedims' ! subroutine name - !----------------------------------------------------------------------- - - ni = 0 - nj = 0 - - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ier = pio_inq_dimid (ncid, 'lon', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) - ier = pio_inq_dimid (ncid, 'lat', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) - - ier = pio_inq_dimid (ncid, 'lsmlon', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) - ier = pio_inq_dimid (ncid, 'lsmlat', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) - - ier = pio_inq_dimid (ncid, 'ni', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) - ier = pio_inq_dimid (ncid, 'nj', dimid) - if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) - - ier = pio_inq_dimid (ncid, 'gridcell', dimid) - if (ier == PIO_NOERR) then - ier = pio_inq_dimlen(ncid, dimid, ni) - if (ier == PIO_NOERR) nj = 1 - end if - - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - - if (ni == 0 .or. nj == 0) then - write(iulog,*) trim(subname),' ERROR: ni,nj = ',ni,nj,' cannot be zero ' - call shr_sys_abort() - end if - - if (nj == 1) then - isgrid2d = .false. - else - isgrid2d = .true. - end if - - ns = ni*nj - - end subroutine ncd_inqfdims - -!----------------------------------------------------------------------- - - subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Inquire on a variable ID - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: name ! variable name - integer , intent(out) :: varid ! variable id - type(Var_desc_t) , intent(out) :: vardesc ! variable descriptor - logical, optional, intent(out) :: readvar ! does variable exist - ! !LOCAL VARIABLES: - integer :: ret ! return code - character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name - !----------------------------------------------------------------------- - - if (present(readvar)) then - readvar = .false. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ret = PIO_inq_varid(ncid,name,vardesc) - if (ret /= PIO_noerr) then - if (masterproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' - readvar = .false. - else - readvar = .true. - end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - else - ret = PIO_inq_varid(ncid,name,vardesc) - endif - varid = vardesc%varid - - end subroutine ncd_inqvid - -!----------------------------------------------------------------------- - - subroutine ncd_inqvdims(ncid,ndims,vardesc) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire variable dimensions - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - integer , intent(out) :: ndims ! variable ndims - type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - ndims = -1 - status = PIO_inq_varndims(ncid,vardesc,ndims) - - end subroutine ncd_inqvdims - -!----------------------------------------------------------------------- - - subroutine ncd_inqvname(ncid,varid,vname,vardesc) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire variable name - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - integer , intent(in) :: varid ! variable id - character(len=*) , intent(out) :: vname ! variable vname - type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - vname = '' - status = PIO_inq_varname(ncid,vardesc,vname) - - end subroutine ncd_inqvname - -!----------------------------------------------------------------------- - - subroutine ncd_inqvdids(ncid,dids,vardesc) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! inquire variable dimension ids - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(in) :: ncid ! netcdf file id - integer ,intent(out) :: dids(:) ! variable dids - type(Var_desc_t),intent(inout):: vardesc ! variable descriptor - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - dids = -1 - status = PIO_inq_vardimid(ncid,vardesc,dids) - - end subroutine ncd_inqvdids - -!----------------------------------------------------------------------- - subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! put integer attributes - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - integer ,intent(in) :: varid ! netcdf var id - character(len=*) ,intent(in) :: attrib ! netcdf attrib - integer ,intent(in) :: value ! netcdf attrib value - integer,optional ,intent(in) :: xtype ! netcdf data type - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = PIO_put_att(ncid,varid,trim(attrib),value) - - end subroutine ncd_putatt_int - -!----------------------------------------------------------------------- - - subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! put character attributes - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - integer ,intent(in) :: varid ! netcdf var id - character(len=*) ,intent(in) :: attrib ! netcdf attrib - character(len=*) ,intent(in) :: value ! netcdf attrib value - integer,optional ,intent(in) :: xtype ! netcdf data type - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = PIO_put_att(ncid,varid,trim(attrib),value) - - end subroutine ncd_putatt_char - -!----------------------------------------------------------------------- - - subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! put real attributes - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - integer ,intent(in) :: varid ! netcdf var id - character(len=*) ,intent(in) :: attrib ! netcdf attrib - real(r8) ,intent(in) :: value ! netcdf attrib value - integer ,intent(in) :: xtype ! netcdf data type - ! - ! !LOCAL VARIABLES: - integer :: status - real(r4) :: value4 - !----------------------------------------------------------------------- - - value4 = real(value, kind=r4) - - if (xtype == pio_double) then - status = PIO_put_att(ncid,varid,trim(attrib),value) - else - status = PIO_put_att(ncid,varid,trim(attrib),value4) - endif - - end subroutine ncd_putatt_real - -!----------------------------------------------------------------------- - - subroutine ncd_defdim(ncid,attrib,value,dimid) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! define dimension - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(in) :: ncid ! netcdf file id - character(len=*) , intent(in) :: attrib ! netcdf attrib - integer , intent(in) :: value ! netcdf attrib value - integer , intent(out):: dimid ! netcdf dimension id - ! - ! !LOCAL VARIABLES: - integer :: status - !----------------------------------------------------------------------- - - status = pio_def_dim(ncid,attrib,value,dimid) - - end subroutine ncd_defdim - -!----------------------------------------------------------------------- - - subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & - long_name, units, cell_method, missing_value, fill_value, & - imissing_value, ifill_value, comment, flag_meanings, & - flag_values, nvalid_range ) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Define a netcdf variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: varname ! variable name - integer , intent(in) :: xtype ! external type - integer , intent(in) :: ndims ! number of dims - integer , intent(inout) :: varid ! returned var id - integer , intent(in), optional :: dimid(:) ! dimids - character(len=*) , intent(in), optional :: long_name ! attribute - character(len=*) , intent(in), optional :: units ! attribute - character(len=*) , intent(in), optional :: cell_method ! attribute - character(len=*) , intent(in), optional :: comment ! attribute - character(len=*) , intent(in), optional :: flag_meanings(:) ! attribute - real(r8) , intent(in), optional :: missing_value ! attribute for real - real(r8) , intent(in), optional :: fill_value ! attribute for real - integer , intent(in), optional :: imissing_value ! attribute for int - integer , intent(in), optional :: ifill_value ! attribute for int - integer , intent(in), optional :: flag_values(:) ! attribute for int - integer , intent(in), optional :: nvalid_range(2) ! attribute for int - - ! - ! !LOCAL VARIABLES: - integer :: n ! indices - integer :: ldimid(4) ! local dimid - integer :: dimid0(1) ! local dimid - integer :: status ! error status - integer :: lxtype ! local external type (in case logical variable) - type(var_desc_t) :: vardesc ! local vardesc - character(len=255) :: dimname ! temporary - character(len=256) :: str ! temporary - character(len=*),parameter :: subname='ncd_defvar_bynf' ! subroutine name - !----------------------------------------------------------------------- - - varid = -1 - - dimid0 = 0 - ldimid = 0 - if (present(dimid)) then - ldimid(1:ndims) = dimid(1:ndims) - else ! ndims must be zero if dimid not present - if (ndims /= 0) then - write(iulog,*) subname//' ERROR: dimid not supplied and ndims ne 0 ',trim(varname),ndims - call shr_sys_abort() - endif - endif - - if ( xtype == ncd_log )then - lxtype = ncd_int - else - lxtype = xtype - end if - if (masterproc .and. debug > 1) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - write(iulog,*) subname//' ',trim(varname),lxtype,ndims,ldimid(1:ndims) - endif - - if (ndims > 0) then - status = pio_inq_dimname(ncid,ldimid(ndims),dimname) - end if - - ! Define variable - if (present(dimid)) then - status = PIO_def_var(ncid,trim(varname),lxtype,dimid(1:ndims),vardesc) - else - status = PIO_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) - endif - varid = vardesc%varid - - ! - ! Add attributes - ! - if (present(long_name)) then - call ncd_putatt(ncid, varid, 'long_name', trim(long_name)) - end if - if (present(flag_values)) then - status = PIO_put_att(ncid,varid,'flag_values',flag_values) - if ( .not. present(flag_meanings)) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_values set -- but not flag_meanings" ) - end if - end if - if (present(flag_meanings)) then - if ( .not. present(flag_values)) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_meanings set -- but not flag_values" ) - end if - if ( size(flag_values) /= size(flag_meanings) ) then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_meanings and flag_values dimension different") - end if - str = flag_meanings(1) - do n = 1, size(flag_meanings) - if ( index(flag_meanings(n), ' ') /= 0 )then - write(iulog,*) 'Error in defining variable = ', trim(varname) - call shr_sys_abort( subname//" ERROR:: flag_meanings has an invalid space in it" ) - end if - if ( n > 1 ) str = trim(str)//" "//flag_meanings(n) - end do - status = PIO_put_att(ncid,varid,'flag_meanings', trim(str) ) - end if - if (present(comment)) then - call ncd_putatt(ncid, varid, 'comment', trim(comment)) - end if - if (present(units)) then - call ncd_putatt(ncid, varid, 'units', trim(units)) - end if - if (present(cell_method)) then - str = 'time: ' // trim(cell_method) - call ncd_putatt(ncid, varid, 'cell_methods', trim(str)) - end if - if (present(fill_value)) then - call ncd_putatt(ncid, varid, '_FillValue', fill_value, lxtype) - end if - if (present(missing_value)) then - call ncd_putatt(ncid, varid, 'missing_value', missing_value, lxtype) - end if - if (present(ifill_value)) then - call ncd_putatt(ncid, varid, '_FillValue', ifill_value, lxtype) - end if - if (present(imissing_value)) then - call ncd_putatt(ncid, varid, 'missing_value', imissing_value, lxtype) - end if - if (present(nvalid_range)) then - status = PIO_put_att(ncid,varid,'valid_range', nvalid_range ) - end if - if ( xtype == ncd_log )then - status = PIO_put_att(ncid,varid,'flag_values', (/0, 1/) ) - status = PIO_put_att(ncid,varid,'flag_meanings', "FALSE TRUE" ) - status = PIO_put_att(ncid,varid,'valid_range', (/0, 1/) ) - end if - - end subroutine ncd_defvar_bynf - -!----------------------------------------------------------------------- - - subroutine ncd_defvar_bygrid(ncid, varname, xtype, & - dim1name, dim2name, dim3name, dim4name, dim5name, & - long_name, units, cell_method, missing_value, fill_value, & - imissing_value, ifill_value, comment, & - flag_meanings, flag_values, nvalid_range ) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Define a netcdf variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: varname ! variable name - integer , intent(in) :: xtype ! external type - character(len=*), intent(in), optional :: dim1name ! dimension name - character(len=*), intent(in), optional :: dim2name ! dimension name - character(len=*), intent(in), optional :: dim3name ! dimension name - character(len=*), intent(in), optional :: dim4name ! dimension name - character(len=*), intent(in), optional :: dim5name ! dimension name - character(len=*), intent(in), optional :: long_name ! attribute - character(len=*), intent(in), optional :: units ! attribute - character(len=*), intent(in), optional :: cell_method ! attribute - character(len=*), intent(in), optional :: comment ! attribute - character(len=*), intent(in), optional :: flag_meanings(:) ! attribute - real(r8) , intent(in), optional :: missing_value ! attribute for real - real(r8) , intent(in), optional :: fill_value ! attribute for real - integer , intent(in), optional :: imissing_value ! attribute for int - integer , intent(in), optional :: ifill_value ! attribute for int - integer , intent(in), optional :: flag_values(:) ! attribute for int - integer , intent(in), optional :: nvalid_range(2) ! attribute for int - ! - ! !REVISION HISTORY: - ! - ! - ! !LOCAL VARIABLES: - !EOP - integer :: n ! indices - integer :: ndims ! dimension counter - integer :: dimid(5) ! dimension ids - integer :: varid ! variable id - integer :: itmp ! temporary - character(len=256) :: str ! temporary - character(len=*),parameter :: subname='ncd_defvar_bygrid' ! subroutine name - !----------------------------------------------------------------------- - - dimid(:) = 0 - - ! Determine dimension ids for variable - - if (present(dim1name)) call ncd_inqdid(ncid, dim1name, dimid(1)) - if (present(dim2name)) call ncd_inqdid(ncid, dim2name, dimid(2)) - if (present(dim3name)) call ncd_inqdid(ncid, dim3name, dimid(3)) - if (present(dim4name)) call ncd_inqdid(ncid, dim4name, dimid(4)) - if (present(dim5name)) call ncd_inqdid(ncid, dim5name, dimid(5)) - - ! Permute dim1 and dim2 if necessary - - ! Define variable - - ndims = 0 - if (present(dim1name)) then - do n = 1, size(dimid) - if (dimid(n) /= 0) ndims = ndims + 1 - end do - end if - - call ncd_defvar_bynf(ncid,varname,xtype,ndims,dimid,varid, & - long_name=long_name, units=units, cell_method=cell_method, & - missing_value=missing_value, fill_value=fill_value, & - imissing_value=imissing_value, ifill_value=ifill_value, & - comment=comment, flag_meanings=flag_meanings, & - flag_values=flag_values, nvalid_range=nvalid_range ) - - end subroutine ncd_defvar_bygrid - -!------------------------------------------------------------------------ - - subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - logical , intent(inout) :: data ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(1), count(1) ! output bounds - integer :: status ! error code - integer :: idata ! raw integer data - logical :: varpresent ! if true, variable is on tape - integer :: temp(1) ! temporary - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_log_var0_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, idata) - if ( idata == 0 )then - data = .false. - else if ( idata == 1 )then - data = .true. - else - call shr_sys_abort( subname// & - ' ERROR: bad integer value for logical data' ) - end if - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if ( data )then - temp(1) = 1 - else - temp(1) = 0 - end if - if (present(nt)) then - start(1) = nt - count(1) = 1 - status = pio_put_var(ncid, varid, start, count, temp) - else - status = pio_put_var(ncid, varid, temp(1)) - end if - - - endif ! flag - - end subroutine ncd_io_log_var0_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_int_var0_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , intent(inout) :: data ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(1), count(1) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - integer :: temp(1) ! temporary - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_int_var0_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if (present(nt)) then - start(1) = nt - count(1) = 1 - temp(1) = data - status = pio_put_var(ncid, varid, start, count, temp) - else - status = pio_put_var(ncid, varid, data) - end if - - endif ! flag - - end subroutine ncd_io_int_var0_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_real_var0_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global real variable - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - real(r8) , intent(inout) :: data ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(1), count(1) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - real(r8):: temp(1) ! temporary - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_real_var0_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, vardesc, data) - endif - if (present(readvar)) readvar = varpresent - - else if (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if (present(nt)) then - start(1) = nt - count(1) = 1 - temp(1) = data - status = pio_put_var(ncid, varid, start, count, temp) - else - status = pio_put_var(ncid, varid, data) - end if - - endif ! flag - - end subroutine ncd_io_real_var0_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_int_var1_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , intent(inout) :: data(:) ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(2), count(2) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_int_var1_nf' - integer :: ndims - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - count(1) = size(data) - start(2) = nt - count(2) = 1 - ndims = 2 - else - start(1) = 1 - count(1) = size(data) - start(2) = 1 - count(2) = 1 - ndims = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) - - endif ! flag - - end subroutine ncd_io_int_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_log_var1_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - logical , intent(inout) :: data(:) ! raw data - logical, optional, intent(out) :: readvar ! was var read? - integer, optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(2), count(2) ! output bounds - integer :: status ! error code - integer, pointer :: idata(:) ! Temporary integer data to send to file - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_log_var1_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - allocate( idata(size(data)) ) - status = pio_get_var(ncid, varid, idata) - data = (idata == 1) - if ( any(idata /= 0 .and. idata /= 1) )then - call shr_sys_abort(subname//'ERROR: read in bad integer value(s) for logical data') - end if - deallocate( idata ) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - count(1) = size(data) - start(2) = nt - count(2) = 1 - else - start(1) = 1 - count(1) = size(data) - start(2) = 1 - count(2) = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - allocate( idata(size(data)) ) - where( data ) - idata = 1 - elsewhere - idata = 0 - end where - status = pio_put_var(ncid, varid, start, count, idata) - deallocate( idata ) - - endif ! flag - - end subroutine ncd_io_log_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_real_var1_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global real array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - real(r8) , intent(inout) :: data(:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(2), count(2) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_real_var1_nf' - integer :: ndims - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - start(2) = nt - count(1) = size(data) - count(2) = 1 - ndims = 2 - else - start(1) = 1 - start(2) = 1 - count(1) = size(data) - count(2) = 1 - ndims = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) - - endif ! flag - - end subroutine ncd_io_real_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_char_var1_nf(varname, data, flag, ncid, readvar, nt ) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global char array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - character(len=*) , intent(inout) :: data ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: m ! indices - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - character(len=1) :: tmpString(255)! temp for manipulating output string - type(var_desc_t) :: vardesc ! local vardesc pointer - character(len=*),parameter :: subname='ncd_io_char_var1_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - - if (present(nt)) then - status = pio_put_var(ncid, varid, (/1,nt/), ival=data) - else - status = pio_put_var(ncid, varid, data ) - end if - - endif ! flag - - end subroutine ncd_io_char_var1_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_int_var2_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global integer 2D array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , intent(inout) :: data(:,:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(3), count(3) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - logical :: found ! if true, found lat/lon dims on file - character(len=*),parameter :: subname='ncd_io_int_var2_nf' - integer :: ndims - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - start(2) = 1 - start(3) = nt - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - ndims = 3 - else - start(1) = 1 - start(2) = 1 - start(3) = 1 - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - ndims = 2 - end if - call ncd_inqvid(ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) - - endif - - end subroutine ncd_io_int_var2_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_real_var2_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global real 2D array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - character(len=*), intent(in) :: varname ! variable name - real(r8) , intent(inout) :: data(:,:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(3), count(3) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - logical :: found ! if true, found lat/lon dims on file - character(len=*),parameter :: subname='ncd_io_real_var2_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - if (present(nt)) then - start(1) = 1 - start(2) = 1 - start(3) = nt - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - else - start(1) = 1 - start(2) = 1 - start(3) = 1 - count(1) = size(data, dim=1) - count(2) = size(data, dim=2) - count(3) = 1 - end if - call ncd_inqvid (ncid, varname, varid, vardesc) - status = pio_put_var(ncid, varid, start, count, data) - - endif - - end subroutine ncd_io_real_var2_nf - -!------------------------------------------------------------------------ - - subroutine ncd_io_char_var2_nf(varname, data, flag, ncid, readvar, nt) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! netcdf I/O of global character array - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - character(len=*), intent(in) :: varname ! variable name - character(len=*), intent(inout) :: data(:) ! raw data - logical , optional, intent(out):: readvar ! was var read? - integer , optional, intent(in) :: nt ! time sample index - ! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: start(3), count(3) ! output bounds - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: vname ! variable error checking - type(var_desc_t) :: vardesc ! local vardesc pointer - logical :: found ! if true, found lat/lon dims on file - character(len=*),parameter :: subname='ncd_io_char_var2_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - data = ' ' - status = pio_get_var(ncid, varid, data) - endif - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid (ncid, varname, varid, vardesc) - if (present(nt)) then - start(1) = 1 - start(2) = 1 - start(3) = nt - count(1) = size(data) - count(2) = len(data) - count(3) = 1 - status = pio_put_var(ncid, varid, start, count, data) - else - status = pio_put_var(ncid, varid, data) - end if - - endif - - end subroutine ncd_io_char_var2_nf - - !------------------------------------------------------------------------ - !BOP - ! - ! !IROUTINE: ncd_io_char_varn_strt_nf - ! - ! !INTERFACE: - subroutine ncd_io_char_varn_strt_nf(vardesc, data, flag, ncid, & - start ) - ! - ! !DESCRIPTION: - ! netcdf I/O of global character array with start indices input - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - type(var_desc_t), intent(in) :: vardesc ! local vardesc pointer - character(len=*), intent(inout) :: data ! raw data for this index - integer , intent(in) :: start(:) ! output bounds - ! - ! !REVISION HISTORY: - ! - ! - ! !LOCAL VARIABLES: - !EOP - integer :: status ! error code - character(len=*),parameter :: subname='ncd_io_char_varn_strt_nf' - !----------------------------------------------------------------------- - - if (flag == 'read') then - status = pio_get_var(ncid, vardesc, start, data ) - elseif (flag == 'write') then - status = pio_put_var(ncid, vardesc, start, data ) - endif - - end subroutine ncd_io_char_varn_strt_nf - -!----------------------------------------------------------------------- - - subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! I/O for 1d integer field - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - integer , pointer :: data(:) ! local decomposition data - character(len=*) , intent(in) :: dim1name ! dimension name - integer , optional, intent(in) :: nt ! time sample index - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary - integer :: n ! index - integer :: iodnum ! iodesc num in list - integer :: varid ! varid - integer :: ndims ! ndims for var - integer :: ndims_iod ! ndims iodesc for var - integer :: dims(4) ! dim sizes - integer :: dids(4) ! dim ids - integer :: start(3) ! netcdf start index - integer :: count(3) ! netcdf count index - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - integer :: xtype ! netcdf data type - integer , pointer :: compDOF(:) - type(iodesc_plus_type) , pointer :: iodesc_plus - type(var_desc_t) :: vardesc - character(len=*),parameter :: subname='ncd_io_int_var1' ! subroutine name - !----------------------------------------------------------------------- - - if (masterproc .and. debug > 1) then - write(iulog,*) subname//' ',trim(flag),' ',trim(varname),' ',trim(dim1name) - end if - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) - end if - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid(ncid, varname ,varid, vardesc) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=ispval) - - else - - if (masterproc) then - write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) - call shr_sys_abort() - endif - - endif - - end subroutine ncd_io_int_var1 - -!----------------------------------------------------------------------- - - subroutine ncd_io_log_var1(varname, data, dim1name, & - flag, ncid, nt, readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! I/O for 1d integer field - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf file id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - character(len=*) , intent(in) :: varname ! variable name - logical , pointer :: data(:) ! local decomposition data - character(len=*) , intent(in) :: dim1name ! dimension name - integer , optional, intent(in) :: nt ! time sample index - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary - integer :: n ! index - integer :: iodnum ! iodesc num in list - integer :: varid ! varid - integer :: ndims ! ndims for var - integer :: ndims_iod ! ndims iodesc for var - integer :: dims(4) ! dim sizes - integer :: dids(4) ! dim ids - integer :: start(3) ! netcdf start index - integer :: count(3) ! netcdf count index - integer :: status ! error code - integer, pointer :: idata(:) ! Temporary integer data to send to file - logical :: varpresent ! if true, variable is on tape - integer :: xtype ! netcdf data type - integer , pointer :: compDOF(:) - type(iodesc_plus_type) , pointer :: iodesc_plus - type(var_desc_t) :: vardesc - character(len=*),parameter :: subname='ncd_io_log_var1' ! subroutine name - !----------------------------------------------------------------------- - - if (masterproc .and. debug > 1) then - write(iulog,*) subname//' ',trim(flag),' ',trim(varname) - end if - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - allocate( idata(size(data)) ) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status) - data = (idata == 1) - if ( any(idata /= 0 .and. idata /= 1) )then - call shr_sys_abort( subname//' ERROR: read in bad integer value(s) for logical data' ) - end if - deallocate( idata ) - end if - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid(ncid, varname ,varid, vardesc) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) - end if - allocate( idata(size(data)) ) - where( data ) - idata = 1 - elsewhere - idata = 0 - end where - call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status, fillval=0) - deallocate( idata ) - - else - - if (masterproc) then - write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) - call shr_sys_abort() - endif - - endif - - end subroutine ncd_io_log_var1 - -!----------------------------------------------------------------------- - - subroutine ncd_io_real_var1(varname, data, dim1name, & - flag, ncid, nt, readvar) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! I/O for 1d real field - ! - ! !ARGUMENTS: - implicit none - type(file_desc_t),intent(inout) :: ncid ! netcdf file id - character(len=*), intent(in) :: flag ! 'read' or 'write' - character(len=*), intent(in) :: varname ! variable name - real(r8) , pointer :: data(:) ! local decomposition data - character(len=*), intent(in) :: dim1name ! dimension name - integer , optional, intent(in) :: nt ! time sample index - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - ! !LOCAL VARIABLES: - character(len=32) :: dimname ! temporary - integer :: iodnum ! iodesc num in list - integer :: varid ! varid - integer :: ndims ! ndims for var - integer :: ndims_iod ! ndims iodesc for var - integer :: n ! index - integer :: dims(4) ! dim sizes - integer :: dids(4) ! dim ids - integer :: start(3) ! netcdf start index - integer :: count(3) ! netcdf count index - integer :: status ! error code - logical :: varpresent ! if true, variable is on tape - integer :: xtype ! netcdf data type - integer , pointer :: compDOF(:) - type(iodesc_plus_type) , pointer :: iodesc_plus - type(var_desc_t) :: vardesc - character(len=*),parameter :: subname='ncd_io_real_var1' ! subroutine name - !----------------------------------------------------------------------- - - if (masterproc .and. debug > 1) then - write(iulog,*) trim(subname),' ',trim(flag),' ',trim(varname) - endif - - if (flag == 'read') then - - call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) - if (varpresent) then - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid,vardesc, dids) - status = pio_inq_vartype(ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid, vardesc, int(nt,kind=PIO_Offset_kind)) - end if - call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) - end if - if (present(readvar)) readvar = varpresent - - elseif (flag == 'write') then - - call ncd_inqvid(ncid, varname ,varid, vardesc) - status = pio_inq_varndims(ncid, vardesc, ndims) - status = pio_inq_vardimid(ncid, vardesc, dids) - status = pio_inq_vartype (ncid, vardesc, xtype) - status = pio_inq_dimname(ncid,dids(ndims),dimname) - if ('time' == trim(dimname)) then - ndims_iod = ndims - 1 - else - ndims_iod = ndims - end if - do n = 1,ndims_iod - status = pio_inq_dimlen(ncid,dids(n),dims(n)) - enddo - call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & - xtype, iodnum) - iodesc_plus => iodesc_list(iodnum) - if (present(nt)) then - call pio_setframe(ncid,vardesc, int(nt,kind=PIO_Offset_kind)) - end if - if(xtype == ncd_float) then - call shr_sys_abort( subname//' error: Attempt to write out single-precision data which is current NOT implemented (see issue #18)' ) - else - call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=spval) - endif - else - - if (masterproc) then - write(iulog,*) subname,' error: unsupported flag ',trim(flag) - call shr_sys_abort() - endif - - endif - - end subroutine ncd_io_real_var1 - -!------------------------------------------------------------------------ - - subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) - - !------------------------------------------------------------------------ - ! !DESCRIPTION: - ! Returns an index to an io descriptor - ! - ! !ARGUMENTS: - type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor - integer , intent(in) :: ndims ! ndims for var - integer , intent(in) :: dims(:) ! dim sizes - integer , intent(in) :: dimids(:) ! dim ids - integer , intent(in) :: xtype ! file external type - integer , intent(out) :: iodnum ! iodesc num in list - ! !LOCAL VARIABLES: - integer :: k,m,n,cnt ! indices - integer :: lsize ! local size - integer :: gsize ! global size - integer :: status ! error status - logical :: found ! true => found created iodescriptor - integer :: ndims_file ! temporary - character(len=64) dimname_file ! dimension name on file - character(len=64) dimname_iodesc ! dimension name from io descriptor - integer, pointer :: compDOF(:) - character(len=32) :: subname = 'ncd_getiodesc' - !------------------------------------------------------------------------ - - ! Determining if need to create a new io descriptor - - n = 1 - found = .false. - do while (n <= num_iodesc .and. .not.found) - if (ndims == iodesc_list(n)%ndims .and. xtype == iodesc_list(n)%type) then - found = .true. - ! First found implies that dimension sizes are the same - do m = 1,ndims - if (dims(m) /= iodesc_list(n)%dims(m)) then - found = .false. - endif - enddo - ! If found - then also check that dimension names are equal - - ! dimension ids in iodescriptor are only used to query dimension - ! names associated with that iodescriptor - if (found) then - do m = 1,ndims - status = PIO_inq_dimname(ncid,dimids(m),dimname_file) - status = PIO_inquire(ncid, ndimensions=ndims_file) - if (iodesc_list(n)%dimids(m) > ndims_file) then - found = .false. - exit - else - status = PIO_inq_dimname(ncid,iodesc_list(n)%dimids(m),dimname_iodesc) - if (trim(dimname_file) .ne. trim(dimname_iodesc)) then - found = .false. - exit - end if - end if - end do - end if - if (found) then - iodnum = n - if (iodnum > num_iodesc) then - write(iulog,*) trim(subname),' ERROR: iodnum out of range ',iodnum,num_iodesc - call shr_sys_abort() - endif - RETURN - endif - endif - n = n + 1 - enddo - - ! Creating a new io descriptor - - if (ndims > 0) then - num_iodesc = num_iodesc + 1 - if (num_iodesc > max_iodesc) then - write(iulog,*) trim(subname),' ERROR num_iodesc gt max_iodesc ',max_iodesc - call shr_sys_abort() - endif - iodnum = num_iodesc - if (masterproc .and. debug > 1) then - write(iulog,*) trim(subname),' creating iodesc at iodnum,ndims,dims(1:ndims),xtype',& - iodnum,ndims,dims(1:ndims),xtype - endif - end if - - ! Initialize the decomposition for PIO - - gsize = rtmCTL%numr - lsize = rtmCTL%lnumr - allocate(compDOF(lsize)) - cnt = 0 - do m = rtmCTL%begr, rtmCTL%endr - cnt = cnt + 1 - compDOF(cnt) = rtmCTL%gindex(m) - enddo - if (debug > 1) then - do m = 0,npes-1 - if (iam == m) then - write(iulog,*) trim(subname),' sizes1 = ',iam,gsize,lsize,npes - write(iulog,*) trim(subname),' compDOF = ',iam,size(compDOF),minval(compDOF),maxval(compDOF) - call shr_sys_flush(iulog) - endif - call mpi_barrier(mpicom_rof,status) - enddo - endif - call pio_initdecomp(pio_subsystem, xTYPE, dims(1:ndims), compDOF, iodesc_list(iodnum)%iodesc) - deallocate(compDOF) - - iodesc_list(iodnum)%type = xtype - iodesc_list(iodnum)%ndims = ndims - iodesc_list(iodnum)%dims = 0 - iodesc_list(iodnum)%dims(1:ndims) = dims(1:ndims) - iodesc_list(iodnum)%dimids(1:ndims) = dimids(1:ndims) - - - end subroutine ncd_getiodesc - -end module RtmIO diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 deleted file mode 100644 index c597256..0000000 --- a/src/riverroute/RtmMod.F90 +++ /dev/null @@ -1,2844 +0,0 @@ -module RtmMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: RtmMod -! -! !DESCRIPTION: -! Mosart Routing Model -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_flush - use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_CDAY - use RtmVar , only : nt_rtm, rtm_tracers - use RtmSpmd , only : masterproc, npes, iam, mpicom_rof, ROFID, mastertask, & - MPI_REAL8,MPI_INTEGER,MPI_CHARACTER,MPI_LOGICAL,MPI_MAX - use RtmVar , only : re, spval, rtmlon, rtmlat, iulog, ice_runoff, & - frivinp_rtm, finidat_rtm, nrevsn_rtm, & - nsrContinue, nsrBranch, nsrStartup, nsrest, & - inst_index, inst_suffix, inst_name, & - smat_option, decomp_option, & - bypass_routing_option, qgwl_runoff_option, & - barrier_timers - use RtmFileUtils , only : getfil, getavu, relavu - use RtmTimeManager , only : timemgr_init, get_nstep, get_curr_date - use RtmHistFlds , only : RtmHistFldsInit, RtmHistFldsSet - use RtmHistFile , only : RtmHistUpdateHbuf, RtmHistHtapesWrapup, RtmHistHtapesBuild, & - rtmhist_ndens, rtmhist_mfilt, rtmhist_nhtfrq, & - rtmhist_avgflag_pertape, rtmhist_avgflag_pertape, & - rtmhist_fincl1, rtmhist_fincl2, rtmhist_fincl3, & - rtmhist_fexcl1, rtmhist_fexcl2, rtmhist_fexcl3, & - max_tapes, max_namlen - use RtmRestFile , only : RtmRestTimeManager, RtmRestGetFile, RtmRestFileRead, & - RtmRestFileWrite, RtmRestFileName - use RunoffMod , only : RunoffInit, rtmCTL, Tctl, Tunit, TRunoff, Tpara, & - gsmap_r, & - SMatP_dnstrm, avsrc_dnstrm, avdst_dnstrm, & - SMatP_direct, avsrc_direct, avdst_direct, & - SMatP_eroutUp, avsrc_eroutUp, avdst_eroutUp - use MOSART_physics_mod, only : Euler - use MOSART_physics_mod, only : updatestate_hillslope, updatestate_subnetwork, & - updatestate_mainchannel - use RtmIO - use mct_mod - use perf_mod - use pio -! -! !PUBLIC TYPES: - implicit none - private -! -! !PUBLIC MEMBER FUNCTIONS: - public Rtminit_namelist ! Initialize MOSART grid - public Rtmini ! Initialize MOSART grid - public Rtmrun ! River routing model -! -! !REVISION HISTORY: -! Author: Sam Levis -! -! !PRIVATE MEMBER FUNCTIONS: - private :: RtmFloodInit - -! !PRIVATE TYPES: - -! MOSART tracers - character(len=256) :: rtm_trstr ! tracer string - -! MOSART namelists - integer, save :: coupling_period ! mosart coupling period - integer, save :: delt_mosart ! mosart internal timestep (->nsub) - -! MOSART constants - real(r8) :: cfl_scale = 1.0_r8 ! cfl scale factor, must be <= 1.0 - real(r8) :: river_depth_minimum = 1.e-4 ! gridcell average minimum river depth [m] - -!global (glo) - integer , pointer :: ID0_global(:) ! local ID index - integer , pointer :: dnID_global(:) ! downstream ID based on ID0 - real(r8), pointer :: area_global(:) ! area - integer , pointer :: IDkey(:) ! translation key from ID to gindex - -!local (gdc) - real(r8), save, pointer :: evel(:,:) ! effective tracer velocity (m/s) - real(r8), save, pointer :: flow(:,:) ! mosart flow (m3/s) - real(r8), save, pointer :: erout_prev(:,:) ! erout previous timestep (m3/s) - real(r8), save, pointer :: eroutup_avg(:,:)! eroutup average over coupling period (m3/s) - real(r8), save, pointer :: erlat_avg(:,:) ! erlateral average over coupling period (m3/s) - -! global MOSART grid - real(r8),pointer :: rlatc(:) ! latitude of 1d grid cell (deg) - real(r8),pointer :: rlonc(:) ! longitude of 1d grid cell (deg) - real(r8),pointer :: rlats(:) ! latitude of 1d south grid cell edge (deg) - real(r8),pointer :: rlatn(:) ! latitude of 1d north grid cell edge (deg) - real(r8),pointer :: rlonw(:) ! longitude of 1d west grid cell edge (deg) - real(r8),pointer :: rlone(:) ! longitude of 1d east grid cell edge (deg) - - logical :: do_rtmflood - - character(len=256) :: nlfilename_rof = 'mosart_in' -! -!EOP -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: Rtminit_namelist -! -! !INTERFACE: - subroutine Rtminit_namelist(flood_active) -! -! !DESCRIPTION: -! Read and distribute mosart namelist -! -! !USES: -! -! !ARGUMENTS: - implicit none - logical, intent(out) :: flood_active -! -! !CALLED FROM: -! subroutine initialize in module initializeMod -! -! !REVISION HISTORY: -! Author: Sam Levis -! Update: T Craig, Dec 2006 -! Update: J Edwards, Jun 2022 -! -! -! !LOCAL VARIABLES: -!EOP - integer :: i - integer :: ier ! error code - integer :: unitn ! unit for namelist file - logical :: lexist ! File exists - character(len= 7) :: runtyp(4) ! run type - character(len=*),parameter :: subname = '(Rtminit_namelist) ' -!----------------------------------------------------------------------- - - !------------------------------------------------------- - ! Read in mosart namelist - !------------------------------------------------------- - - namelist /mosart_inparm / ice_runoff, do_rtmflood, & - frivinp_rtm, finidat_rtm, nrevsn_rtm, coupling_period, & - rtmhist_ndens, rtmhist_mfilt, rtmhist_nhtfrq, & - rtmhist_fincl1, rtmhist_fincl2, rtmhist_fincl3, & - rtmhist_fexcl1, rtmhist_fexcl2, rtmhist_fexcl3, & - rtmhist_avgflag_pertape, decomp_option, & - bypass_routing_option, qgwl_runoff_option, & - smat_option, delt_mosart - - ! Preset values - do_rtmflood = .false. - ice_runoff = .true. - finidat_rtm = ' ' - nrevsn_rtm = ' ' - coupling_period = -1 - delt_mosart = 3600 - decomp_option = 'basin' - bypass_routing_option = 'direct_in_place' - qgwl_runoff_option = 'threshold' - smat_option = 'opt' - - nlfilename_rof = "mosart_in" // trim(inst_suffix) - inquire (file = trim(nlfilename_rof), exist = lexist) - if ( .not. lexist ) then - write(iulog,*) subname // ' ERROR: nlfilename_rof does NOT exist:'& - //trim(nlfilename_rof) - call shr_sys_abort(trim(subname)//' ERROR nlfilename_rof does not exist') - end if - if (masterproc) then - unitn = getavu() - write(iulog,*) 'Read in mosart_inparm namelist from: ', trim(nlfilename_rof) - open( unitn, file=trim(nlfilename_rof), status='old' ) - ier = 1 - do while ( ier /= 0 ) - read(unitn, mosart_inparm, iostat=ier) - if (ier < 0) then - call shr_sys_abort( subname//' encountered end-of-file on mosart_inparm read' ) - endif - end do - call relavu( unitn ) - end if - - call mpi_bcast (coupling_period, 1, MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (delt_mosart , 1, MPI_INTEGER, 0, mpicom_rof, ier) - - call mpi_bcast (finidat_rtm , len(finidat_rtm) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (frivinp_rtm , len(frivinp_rtm) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (nrevsn_rtm , len(nrevsn_rtm) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (decomp_option, len(decomp_option), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (smat_option , len(smat_option) , MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (bypass_routing_option, len(bypass_routing_option), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (qgwl_runoff_option, len(qgwl_runoff_option), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (do_rtmflood, 1, MPI_LOGICAL, 0, mpicom_rof, ier) - call mpi_bcast (ice_runoff, 1, MPI_LOGICAL, 0, mpicom_rof, ier) - - call mpi_bcast (rtmhist_nhtfrq, size(rtmhist_nhtfrq), MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_mfilt , size(rtmhist_mfilt) , MPI_INTEGER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_ndens , size(rtmhist_ndens) , MPI_INTEGER, 0, mpicom_rof, ier) - - call mpi_bcast (rtmhist_fexcl1, (max_namlen+2)*size(rtmhist_fexcl1), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fexcl2, (max_namlen+2)*size(rtmhist_fexcl2), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fexcl3, (max_namlen+2)*size(rtmhist_fexcl3), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fincl1, (max_namlen+2)*size(rtmhist_fincl1), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fincl2, (max_namlen+2)*size(rtmhist_fincl2), MPI_CHARACTER, 0, mpicom_rof, ier) - call mpi_bcast (rtmhist_fincl3, (max_namlen+2)*size(rtmhist_fincl3), MPI_CHARACTER, 0, mpicom_rof, ier) - - call mpi_bcast (rtmhist_avgflag_pertape, size(rtmhist_avgflag_pertape), MPI_CHARACTER, 0, mpicom_rof, ier) - - runtyp(:) = 'missing' - runtyp(nsrStartup + 1) = 'initial' - runtyp(nsrContinue + 1) = 'restart' - runtyp(nsrBranch + 1) = 'branch ' - - if (masterproc) then - write(iulog,*) 'define run:' - write(iulog,*) ' run type = ',runtyp(nsrest+1) - !write(iulog,*) ' case title = ',trim(ctitle) - !write(iulog,*) ' username = ',trim(username) - !write(iulog,*) ' hostname = ',trim(hostname) - write(iulog,*) ' coupling_period = ',coupling_period - write(iulog,*) ' delt_mosart = ',delt_mosart - write(iulog,*) ' decomp option = ',trim(decomp_option) - write(iulog,*) ' bypass_routing option = ',trim(bypass_routing_option) - write(iulog,*) ' qgwl runoff option = ',trim(qgwl_runoff_option) - write(iulog,*) ' smat option = ',trim(smat_option) - if (nsrest == nsrStartup .and. finidat_rtm /= ' ') then - write(iulog,*) ' MOSART initial data = ',trim(finidat_rtm) - end if - endif - - flood_active = do_rtmflood - - if (frivinp_rtm == ' ') then - call shr_sys_abort( subname//' ERROR: frivinp_rtm NOT set' ) - else - if (masterproc) then - write(iulog,*) ' MOSART river data = ',trim(frivinp_rtm) - endif - end if - - if (trim(bypass_routing_option) == 'direct_to_outlet') then - if (trim(qgwl_runoff_option) == 'threshold') then - call shr_sys_abort( subname//' ERROR: qgwl_runoff_option can NOT be threshold if bypass_routing_option==direct_to_outlet' ) - end if - else if (trim(bypass_routing_option) == 'none') then - if (trim(qgwl_runoff_option) /= 'all') then - call shr_sys_abort( subname//' ERROR: qgwl_runoff_option can only be all if bypass_routing_option==none' ) - end if - end if - - if (coupling_period <= 0) then - write(iulog,*) subname,' ERROR MOSART coupling_period invalid',coupling_period - call shr_sys_abort( subname//' ERROR: coupling_period invalid' ) - endif - - if (delt_mosart <= 0) then - write(iulog,*) subname,' ERROR MOSART delt_mosart invalid',delt_mosart - call shr_sys_abort( subname//' ERROR: delt_mosart invalid' ) - endif - - do i = 1, max_tapes - if (rtmhist_nhtfrq(i) == 0) then - rtmhist_mfilt(i) = 1 - else if (rtmhist_nhtfrq(i) < 0) then - rtmhist_nhtfrq(i) = nint(-rtmhist_nhtfrq(i)*SHR_CONST_CDAY/(24._r8*coupling_period)) - endif - end do - end subroutine Rtminit_namelist -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: Rtmini -! -! !INTERFACE: - subroutine Rtmini - -! -! !DESCRIPTION: -! Initialize MOSART grid, mask, decomp -! -! !USES: -! -! !ARGUMENTS: - implicit none -! -! !CALLED FROM: -! subroutine initialize in module initializeMod -! -! !REVISION HISTORY: -! Author: Sam Levis -! Update: T Craig, Dec 2006 -! Update: J Edwards, Jun 2022 -! -! -! !LOCAL VARIABLES: - - real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) - real(r8) :: effvel(nt_rtm) ! downstream velocity (m/s) - integer ,pointer :: rgdc2glo(:) ! temporary for initialization - integer ,pointer :: rglo2gdc(:) ! temporary for initialization - type(file_desc_t) :: ncid ! netcdf file id - integer :: dimid ! netcdf dimension identifier - real(r8) :: lrtmarea ! tmp local sum of area - integer :: cnt, lsize, gsize ! counter - - real(r8) :: deg2rad ! pi/180 - integer :: g, n, i, j, nr, nt ! iterators - integer :: nl,nloops ! used for decomp search - character(len=256):: fnamer ! name of netcdf restart file - character(len=256):: pnamer ! full pathname of netcdf restart file - character(len=256):: locfn ! local file name - integer :: ier - real(r8),allocatable :: tempr(:,:) ! temporary buffer - integer ,allocatable :: itempr(:,:) ! temporary buffer - logical :: found ! flag - integer :: numr ! tot num of roff pts on all pes - integer :: pid,np,npmin,npmax,npint ! log loop control - integer :: nmos,nmos_chk ! number of mosart points - integer :: nout,nout_chk ! number of basin with outlets - integer :: nbas,nbas_chk ! number of basin/ocean points - integer :: nrof,nrof_chk ! num of active mosart points - integer :: maxrtm ! max num of rtms per pe for decomp - integer :: minbas,maxbas ! used for decomp search - real(r8) :: edgen ! North edge of the direction file - real(r8) :: edgee ! East edge of the direction file - real(r8) :: edges ! South edge of the direction file - real(r8) :: edgew ! West edge of the direction file - real(r8) :: dx,dx1,dx2,dx3 ! lon dist. betn grid cells (m) - real(r8) :: dy ! lat dist. betn grid cells (m) - integer :: igrow,igcol,iwgt ! mct field indices - type(mct_avect) :: avtmp, avtmpG ! temporary avects - type(mct_sMat) :: sMat ! temporary sparse matrix, needed for sMatP - character(len=16384) :: rList ! list of fields for SM multiply - integer :: baspe ! pe with min number of mosart cells - integer ,pointer :: gmask(:) ! global mask - integer ,allocatable :: idxocn(:) ! downstream ocean outlet cell - integer ,allocatable :: nupstrm(:) ! number of upstream cells including own cell - integer ,allocatable :: pocn(:) ! pe number assigned to basin - integer ,allocatable :: nop(:) ! number of gridcells on a pe - integer ,allocatable :: nba(:) ! number of basins on each pe - integer ,allocatable :: nrs(:) ! begr on each pe - integer ,allocatable :: basin(:) ! basin to mosart mapping - integer ,allocatable :: gindex(:) ! global index -#ifdef NDEBUG - integer,parameter :: dbug = 0 ! 0 = none, 1=normal, 2=much, 3=max -#else - integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max -#endif - character(len=*),parameter :: subname = '(Rtmini) ' - !------------------------------------------------------- - ! Initialize MOSART time manager - !------------------------------------------------------- - - ! Intiialize MOSART pio - call ncd_pio_init() - - ! Obtain restart file if appropriate - if ((nsrest == nsrStartup .and. finidat_rtm /= ' ') .or. & - (nsrest == nsrContinue) .or. & - (nsrest == nsrBranch )) then - call RtmRestGetfile( file=fnamer, path=pnamer ) - endif - - ! Initialize time manager - if (nsrest == nsrStartup) then - call timemgr_init(dtime_in=coupling_period) - else - call RtmRestTimeManager(file=fnamer) - end if - - !------------------------------------------------------- - ! Initialize rtm_trstr - !------------------------------------------------------- - - rtm_trstr = trim(rtm_tracers(1)) - do n = 2,nt_rtm - rtm_trstr = trim(rtm_trstr)//':'//trim(rtm_tracers(n)) - enddo - if (masterproc) then - write(iulog,*)'MOSART tracers = ',nt_rtm,trim(rtm_trstr) - end if - - !------------------------------------------------------- - ! Read input data (river direction file) - !------------------------------------------------------- - - ! Useful constants and initial values - deg2rad = SHR_CONST_PI / 180._r8 - - call t_startf('mosarti_grid') - - call getfil(frivinp_rtm, locfn, 0 ) - if (masterproc) then - write(iulog,*) 'Read in MOSART file name: ',trim(frivinp_rtm) - call shr_sys_flush(iulog) - endif - - call ncd_pio_openfile (ncid, trim(locfn), 0) - call ncd_inqdid(ncid,'lon',dimid) - call ncd_inqdlen(ncid,dimid,rtmlon) - call ncd_inqdid(ncid,'lat',dimid) - call ncd_inqdlen(ncid,dimid,rtmlat) - - if (masterproc) then - write(iulog,*) 'Values for rtmlon/rtmlat: ',rtmlon,rtmlat - write(iulog,*) 'Successfully read MOSART dimensions' - call shr_sys_flush(iulog) - endif - - ! Allocate variables - allocate(rlonc(rtmlon), rlatc(rtmlat), & - rlonw(rtmlon), rlone(rtmlon), & - rlats(rtmlat), rlatn(rtmlat), & - rtmCTL%rlon(rtmlon), & - rtmCTL%rlat(rtmlat), & - stat=ier) - if (ier /= 0) then - write(iulog,*) subname,' : Allocation ERROR for rlon' - call shr_sys_abort(subname//' ERROR alloc for rlon') - end if - - ! reading the routing parameters - allocate ( & - ID0_global(rtmlon*rtmlat), area_global(rtmlon*rtmlat), & - dnID_global(rtmlon*rtmlat), & - stat=ier) - if (ier /= 0) then - write(iulog,*) subname, ' : Allocation error for ID0_global' - call shr_sys_abort(subname//' ERROR alloc for ID0') - end if - - allocate(tempr(rtmlon,rtmlat)) - allocate(itempr(rtmlon,rtmlat)) - - call ncd_io(ncid=ncid, varname='longxy', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read MOSART longitudes') - if (masterproc) write(iulog,*) 'Read longxy ',minval(tempr),maxval(tempr) - do i=1,rtmlon - rtmCTL%rlon(i) = tempr(i,1) - rlonc(i) = tempr(i,1) - enddo - if (masterproc) write(iulog,*) 'rlonc ',minval(rlonc),maxval(rlonc) - - call ncd_io(ncid=ncid, varname='latixy', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read MOSART latitudes') - if (masterproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) - do j=1,rtmlat - rtmCTL%rlat(j) = tempr(1,j) - rlatc(j) = tempr(1,j) - end do - if (masterproc) write(iulog,*) 'rlatc ',minval(rlatc),maxval(rlatc) - - call ncd_io(ncid=ncid, varname='area', flag='read', data=tempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read MOSART area') - if (masterproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) - do j=1,rtmlat - do i=1,rtmlon - n = (j-1)*rtmlon + i - area_global(n) = tempr(i,j) - end do - end do - if (masterproc) write(iulog,*) 'area ',minval(tempr),maxval(tempr) - - call ncd_io(ncid=ncid, varname='ID', flag='read', data=itempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read MOSART ID') - if (masterproc) write(iulog,*) 'Read ID ',minval(itempr),maxval(itempr) - do j=1,rtmlat - do i=1,rtmlon - n = (j-1)*rtmlon + i - ID0_global(n) = itempr(i,j) - end do - end do - if (masterproc) write(iulog,*) 'ID ',minval(itempr),maxval(itempr) - - call ncd_io(ncid=ncid, varname='dnID', flag='read', data=itempr, readvar=found) - if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read MOSART dnID') - if (masterproc) write(iulog,*) 'Read dnID ',minval(itempr),maxval(itempr) - do j=1,rtmlat - do i=1,rtmlon - n = (j-1)*rtmlon + i - dnID_global(n) = itempr(i,j) - end do - end do - if (masterproc) write(iulog,*) 'dnID ',minval(itempr),maxval(itempr) - - deallocate(tempr) - deallocate(itempr) - - call ncd_pio_closefile(ncid) - - !------------------------------------------------------- - ! RESET dnID indices based on ID0 - ! rename the dnID values to be consistent with global grid indexing. - ! where 1 = lower left of grid and rtmlon*rtmlat is upper right. - ! ID0 is the "key", modify dnID based on that. keep the IDkey around - ! for as long as needed. This is a key that translates the ID0 value - ! to the gindex value. compute the key, then apply the key to dnID_global. - ! As part of this, check that each value of ID0 is unique and within - ! the range of 1 to rtmlon*rtmlat. - !------------------------------------------------------- - - allocate(IDkey(rtmlon*rtmlat)) - IDkey = 0 - do n=1,rtmlon*rtmlat - if (ID0_global(n) < 0 .or. ID0_global(n) > rtmlon*rtmlat) then - write(iulog,*) subname,' ERROR ID0 out of range',n,ID0_global(n) - call shr_sys_abort(subname//' ERROR error ID0 out of range') - endif - if (IDkey(ID0_global(n)) /= 0) then - write(iulog,*) subname,' ERROR ID0 value occurs twice',n,ID0_global(n) - call shr_sys_abort(subname//' ERROR ID0 value occurs twice') - endif - IDkey(ID0_global(n)) = n - enddo - if (minval(IDkey) < 1) then - write(iulog,*) subname,' ERROR IDkey incomplete' - call shr_sys_abort(subname//' ERROR IDkey incomplete') - endif - do n=1,rtmlon*rtmlat - if (dnID_global(n) > 0 .and. dnID_global(n) <= rtmlon*rtmlat) then - if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= rtmlon*rtmlat) then - dnID_global(n) = IDkey(dnID_global(n)) - else - write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) - call shr_sys_abort(subname//' ERROR bad IDkey') - endif - endif - enddo - deallocate(ID0_global) - - !------------------------------------------------------- - ! Derive gridbox edges - !------------------------------------------------------- - - ! assuming equispaced grid, calculate edges from rtmlat/rtmlon - ! w/o assuming a global grid - edgen = maxval(rlatc) + 0.5*abs(rlatc(1) - rlatc(2)) - edges = minval(rlatc) - 0.5*abs(rlatc(1) - rlatc(2)) - edgee = maxval(rlonc) + 0.5*abs(rlonc(1) - rlonc(2)) - edgew = minval(rlonc) - 0.5*abs(rlonc(1) - rlonc(2)) - - if ( edgen .ne. 90._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edgen = ', edgen - end if - if ( edges .ne. -90._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edges = ', edges - end if - if ( edgee .ne. 180._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edgee = ', edgee - end if - if ( edgew .ne.-180._r8 )then - if ( masterproc ) write(iulog,*) 'Regional grid: edgew = ', edgew - end if - - ! Set edge latitudes (assumes latitudes are constant for a given longitude) - rlats(:) = edges - rlatn(:) = edgen - do j = 2, rtmlat - if (rlatc(2) > rlatc(1)) then ! South to North grid - rlats(j) = (rlatc(j-1) + rlatc(j)) / 2._r8 - rlatn(j-1) = rlats(j) - else ! North to South grid - rlatn(j) = (rlatc(j-1) + rlatc(j)) / 2._r8 - rlats(j-1) = rlatn(j) - end if - end do - - ! Set edge longitudes - rlonw(:) = edgew - rlone(:) = edgee - dx = (edgee - edgew) / rtmlon - do i = 2, rtmlon - rlonw(i) = rlonw(i) + (i-1)*dx - rlone(i-1) = rlonw(i) - end do - call t_stopf ('mosarti_grid') - - !------------------------------------------------------- - ! Determine mosart ocn/land mask (global, all procs) - !------------------------------------------------------- - - call t_startf('mosarti_decomp') - - allocate (gmask(rtmlon*rtmlat), stat=ier) - if (ier /= 0) then - write(iulog,*) subname, ' : Allocation ERROR for gmask' - call shr_sys_abort(subname//' ERROR alloc for gmask') - end if - - ! 1=land, - ! 2=ocean, - ! 3=ocean outlet from land - - gmask = 2 ! assume ocean point - do n=1,rtmlon*rtmlat ! mark all downstream points as outlet - nr = dnID_global(n) - if ((nr > 0) .and. (nr <= rtmlon*rtmlat)) then - gmask(nr) = 3 ! <- nr - end if - enddo - do n=1,rtmlon*rtmlat ! now mark all points with downstream points as land - nr = dnID_global(n) - if ((nr > 0) .and. (nr <= rtmlon*rtmlat)) then - gmask(n) = 1 ! <- n - end if - enddo - - !------------------------------------------------------- - ! Compute total number of basins and runoff points - !------------------------------------------------------- - - nbas = 0 - nrof = 0 - nout = 0 - nmos = 0 - do nr=1,rtmlon*rtmlat - if (gmask(nr) == 3) then - nout = nout + 1 - nbas = nbas + 1 - nmos = nmos + 1 - nrof = nrof + 1 - elseif (gmask(nr) == 2) then - nbas = nbas + 1 - nrof = nrof + 1 - elseif (gmask(nr) == 1) then - nmos = nmos + 1 - nrof = nrof + 1 - endif - enddo - if (masterproc) then - write(iulog,*) 'Number of outlet basins = ',nout - write(iulog,*) 'Number of total basins = ',nbas - write(iulog,*) 'Number of mosart points = ',nmos - write(iulog,*) 'Number of runoff points = ',nrof - endif - - !------------------------------------------------------- - ! Compute river basins, actually compute ocean outlet gridcell - !------------------------------------------------------- - - ! idxocn = final downstream cell, index is global 1d ocean gridcell - ! nupstrm = number of source gridcells upstream including self - - allocate(idxocn(rtmlon*rtmlat),nupstrm(rtmlon*rtmlat),stat=ier) - if (ier /= 0) then - write(iulog,*) subname,' : Allocation ERROR for ',& - 'idxocn,nupstrm' - call shr_sys_abort(subname//' ERROR alloc for idxocn nupstrm') - end if - - call t_startf('mosarti_dec_basins') - idxocn = 0 - nupstrm = 0 - do nr=1,rtmlon*rtmlat - n = nr - if (abs(gmask(n)) == 1) then ! land - g = 0 - do while (abs(gmask(n)) == 1 .and. g < rtmlon*rtmlat) ! follow downstream - nupstrm(n) = nupstrm(n) + 1 - n = dnID_global(n) - g = g + 1 - end do - if (gmask(n) == 3) then ! found ocean outlet - nupstrm(n) = nupstrm(n) + 1 ! one more land cell for n - idxocn(nr) = n ! set ocean outlet or nr to n - elseif (abs(gmask(n)) == 1) then ! no ocean outlet, warn user, ignore cell - write(iulog,*) subname,' ERROR closed basin found', & - g,nr,gmask(nr),dnID_global(nr), & - n,gmask(n),dnID_global(n) - call shr_sys_abort(subname//' ERROR closed basin found') - elseif (gmask(n) == 2) then - write(iulog,*) subname,' ERROR found invalid ocean cell ',nr - call shr_sys_abort(subname//' ERROR found invalid ocean cell') - else - write(iulog,*) subname,' ERROR downstream cell is unknown', & - g,nr,gmask(nr),dnID_global(nr), & - n,gmask(n),dnID_global(n) - call shr_sys_abort(subname//' ERROR downstream cell is unknown') - endif - elseif (gmask(n) >= 2) then ! ocean, give to self - nupstrm(n) = nupstrm(n) + 1 - idxocn(nr) = n - endif - enddo - call t_stopf('mosarti_dec_basins') - - ! check - - nbas_chk = 0 - nrof_chk = 0 - do nr=1,rtmlon*rtmlat -! !if (masterproc) write(iulog,*) 'nupstrm check ',nr,gmask(nr),nupstrm(nr),idxocn(nr) - if (gmask(nr) >= 2 .and. nupstrm(nr) > 0) then - nbas_chk = nbas_chk + 1 - nrof_chk = nrof_chk + nupstrm(nr) - endif - enddo - - if (nbas_chk /= nbas .or. nrof_chk /= nrof) then - write(iulog,*) subname,' ERROR nbas nrof check',nbas,nbas_chk,nrof,nrof_chk - call shr_sys_abort(subname//' ERROR nbas nrof check') - endif - - !------------------------------------------------------- - !--- Now allocate those basins to pes - !------------------------------------------------------- - - call t_startf('mosarti_dec_distr') - - !--- this is the heart of the decomp, need to set pocn and nop by the end of this - !--- pocn is the pe that gets the basin associated with ocean outlet nr - !--- nop is a running count of the number of mosart cells/pe - - allocate(pocn(rtmlon*rtmlat), & !global mosart array - nop(0:npes-1), & - nba(0:npes-1)) - - pocn = -99 - nop = 0 - nba = 0 - - if (trim(decomp_option) == 'basin') then - baspe = 0 - maxrtm = int(float(nrof)/float(npes)*0.445) + 1 - nloops = 3 - minbas = nrof - do nl=1,nloops - maxbas = minbas - 1 - minbas = maxval(nupstrm)/(2**nl) - if (nl == nloops) minbas = min(minbas,1) - do nr=1,rtmlon*rtmlat - if (gmask(nr) >= 2 .and. nupstrm(nr) > 0 .and. nupstrm(nr) >= minbas .and. nupstrm(nr) <= maxbas) then - ! Decomp options - ! find min pe (implemented but scales poorly) - ! use increasing thresholds (implemented, ok load balance for l2r or calc) - ! distribute basins using above methods but work from max to min basin size - ! - !-------------- - ! find min pe - ! baspe = 0 - ! do n = 1,npes-1 - ! if (nop(n) < nop(baspe)) baspe = n - ! enddo - !-------------- - ! find next pe below maxrtm threshhold and increment - do while (nop(baspe) > maxrtm) - baspe = baspe + 1 - if (baspe > npes-1) then - baspe = 0 - maxrtm = max(maxrtm*1.5, maxrtm+1.0) ! 3 loop, .445 and 1.5 chosen carefully - endif - enddo - !-------------- - if (baspe > npes-1 .or. baspe < 0) then - write(iulog,*) 'ERROR in decomp for MOSART ',nr,npes,baspe - call shr_sys_abort('ERROR mosart decomp') - endif - nop(baspe) = nop(baspe) + nupstrm(nr) - nba(baspe) = nba(baspe) + 1 - pocn(nr) = baspe - endif - enddo ! nr - enddo ! nl - - ! set pocn for land cells, was set for ocean above - do nr=1,rtmlon*rtmlat - if (idxocn(nr) > 0) then - pocn(nr) = pocn(idxocn(nr)) - if (pocn(nr) < 0 .or. pocn(nr) > npes-1) then - write(iulog,*) subname,' ERROR pocn lnd setting ',& - nr,idxocn(nr),idxocn(idxocn(nr)),pocn(idxocn(nr)),pocn(nr),npes - call shr_sys_abort(subname//' ERROR pocn lnd') - endif - endif - enddo - - elseif (trim(decomp_option) == '1d') then - ! distribute active points in 1d fashion to pes - ! baspe is the pe assignment - ! maxrtm is the maximum number of points to assign to each pe - baspe = 0 - maxrtm = (nrof-1)/npes + 1 - do nr=1,rtmlon*rtmlat - if (gmask(nr) >= 1) then - pocn(nr) = baspe - nop(baspe) = nop(baspe) + 1 - if (nop(baspe) >= maxrtm) then - baspe = (mod(baspe+1,npes)) - if (baspe < 0 .or. baspe > npes-1) then - write(iulog,*) subname,' ERROR basepe ',baspe,npes - call shr_sys_abort(subname//' ERROR pocn lnd') - endif - endif - endif - enddo - - elseif (trim(decomp_option) == 'roundrobin') then - ! distribute active points in roundrobin fashion to pes - ! baspe is the pe assignment - ! maxrtm is the maximum number of points to assign to each pe - baspe = 0 - do nr=1,rtmlon*rtmlat - if (gmask(nr) >= 1) then - pocn(nr) = baspe - nop(baspe) = nop(baspe) + 1 - baspe = (mod(baspe+1,npes)) - if (baspe < 0 .or. baspe > npes-1) then - write(iulog,*) subname,' ERROR basepe ',baspe,npes - call shr_sys_abort(subname//' ERROR pocn lnd') - endif - endif - enddo - - else - write(iulog,*) subname,' ERROR decomp option unknown ',trim(decomp_option) - call shr_sys_abort(subname//' ERROR pocn lnd') - endif ! decomp_option - - if (masterproc) then - write(iulog,*) 'MOSART cells and basins total = ',nrof,nbas - write(iulog,*) 'MOSART cells per basin avg/max = ',nrof/nbas,maxval(nupstrm) - write(iulog,*) 'MOSART cells per pe min/max = ',minval(nop),maxval(nop) - write(iulog,*) 'MOSART basins per pe min/max = ',minval(nba),maxval(nba) - endif - - deallocate(nupstrm) - - !------------------------------------------------------- - !--- Count and distribute cells to rglo2gdc - !------------------------------------------------------- - - rtmCTL%numr = 0 - rtmCTL%lnumr = 0 - - do n = 0,npes-1 - if (iam == n) then - rtmCTL%begr = rtmCTL%numr + 1 - endif - rtmCTL%numr = rtmCTL%numr + nop(n) - if (iam == n) then - rtmCTL%lnumr = rtmCTL%lnumr + nop(n) - rtmCTL%endr = rtmCTL%begr + rtmCTL%lnumr - 1 - endif - enddo - - allocate(rglo2gdc(rtmlon*rtmlat), & !global mosart array - nrs(0:npes-1)) - nrs = 0 - rglo2gdc = 0 - - ! nrs is begr on each pe - nrs(0) = 1 - do n = 1,npes-1 - nrs(n) = nrs(n-1) + nop(n-1) - enddo - - ! reuse nba for nop-like counter here - ! pocn -99 is unused cell - nba = 0 - do nr = 1,rtmlon*rtmlat - if (pocn(nr) >= 0) then - rglo2gdc(nr) = nrs(pocn(nr)) + nba(pocn(nr)) - nba(pocn(nr)) = nba(pocn(nr)) + 1 - endif - enddo - do n = 0,npes-1 - if (nba(n) /= nop(n)) then - write(iulog,*) subname,' ERROR mosart cell count ',n,nba(n),nop(n) - call shr_sys_abort(subname//' ERROR mosart cell count') - endif - enddo - - deallocate(nop,nba,nrs) - deallocate(pocn) - call t_stopf('mosarti_dec_distr') - - !------------------------------------------------------- - !--- adjust area estimation from DRT algorithm for those outlet grids - !--- useful for grid-based representation only - !--- need to compute areas where they are not defined in input file - !------------------------------------------------------- - - do n=1,rtmlon*rtmlat - if (area_global(n) <= 0._r8) then - i = mod(n-1,rtmlon) + 1 - j = (n-1)/rtmlon + 1 - dx = (rlone(i) - rlonw(i)) * deg2rad - dy = sin(rlatn(j)*deg2rad) - sin(rlats(j)*deg2rad) - area_global(n) = abs(1.e6_r8 * dx*dy*re*re) - if (masterproc .and. area_global(n) <= 0) then - write(iulog,*) 'Warning! Zero area for unit ', n, area_global(n),dx,dy,re - end if - end if - end do - - call t_stopf('mosarti_decomp') - - !------------------------------------------------------- - !--- Write per-processor runoff bounds depending on dbug level - !------------------------------------------------------- - - call t_startf('mosarti_print') - - call shr_sys_flush(iulog) - if (masterproc) then - write(iulog,*) 'total runoff cells numr = ',rtmCTL%numr - endif - call shr_sys_flush(iulog) - call mpi_barrier(mpicom_rof,ier) - npmin = 0 - npmax = npes-1 - npint = 1 - if (dbug == 0) then - npmax = 0 - elseif (dbug == 1) then - npmax = min(npes-1,4) - elseif (dbug == 2) then - npint = npes/8 - elseif (dbug == 3) then - npint = 1 - endif - do np = npmin,npmax,npint - pid = np - if (dbug == 1) then - if (np == 2) pid=npes/2-1 - if (np == 3) pid=npes-2 - if (np == 4) pid=npes-1 - endif - pid = max(pid,0) - pid = min(pid,npes-1) - if (iam == pid) then - write(iulog,'(2a,i9,a,i9,a,i9,a,i9)') & - 'MOSART decomp info',' proc = ',iam, & - ' begr = ',rtmCTL%begr,& - ' endr = ',rtmCTL%endr, & - ' numr = ',rtmCTL%lnumr - endif - call shr_sys_flush(iulog) - call mpi_barrier(mpicom_rof,ier) - enddo - - call t_stopf('mosarti_print') - - !------------------------------------------------------- - ! Allocate local flux variables - !------------------------------------------------------- - - call t_startf('mosarti_vars') - - allocate (evel (rtmCTL%begr:rtmCTL%endr,nt_rtm), & - flow (rtmCTL%begr:rtmCTL%endr,nt_rtm), & - erout_prev(rtmCTL%begr:rtmCTL%endr,nt_rtm), & - eroutup_avg(rtmCTL%begr:rtmCTL%endr,nt_rtm), & - erlat_avg(rtmCTL%begr:rtmCTL%endr,nt_rtm), & - stat=ier) - if (ier /= 0) then - write(iulog,*) subname,' Allocation ERROR for flow' - call shr_sys_abort(subname//' Allocationt ERROR flow') - end if - flow(:,:) = 0._r8 - erout_prev(:,:) = 0._r8 - eroutup_avg(:,:) = 0._r8 - erlat_avg(:,:) = 0._r8 - - !------------------------------------------------------- - ! Allocate runoff datatype - !------------------------------------------------------- - - call RunoffInit(rtmCTL%begr, rtmCTL%endr, rtmCTL%numr) - - !------------------------------------------------------- - ! Initialize mosart flood - rtmCTL%fthresh and evel - !------------------------------------------------------- - - if (do_rtmflood) then - write(iulog,*) subname,' Flood not validated in this version, abort' - call shr_sys_abort(subname//' Flood feature unavailable') - call RtmFloodInit (frivinp_rtm, rtmCTL%begr, rtmCTL%endr, rtmCTL%fthresh, evel) - else - effvel(:) = effvel0 ! downstream velocity (m/s) - rtmCTL%fthresh(:) = abs(spval) - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - evel(nr,nt) = effvel(nt) - enddo - enddo - end if - - !------------------------------------------------------- - ! Initialize runoff data type - !------------------------------------------------------- - - allocate(rgdc2glo(rtmCTL%numr), stat=ier) - if (ier /= 0) then - write(iulog,*) subname,' ERROR allocation of rgdc2glo' - call shr_sys_abort(subname//' ERROR allocate of rgdc2glo') - end if - - ! Set map from local to global index space - numr = 0 - do j = 1,rtmlat - do i = 1,rtmlon - n = (j-1)*rtmlon + i - nr = rglo2gdc(n) - if (nr > 0) then - numr = numr + 1 - rgdc2glo(nr) = n - endif - end do - end do - if (numr /= rtmCTL%numr) then - write(iulog,*) subname,'ERROR numr and rtmCTL%numr are different ',numr,rtmCTL%numr - call shr_sys_abort(subname//' ERROR numr') - endif - - ! Determine runoff datatype variables - lrtmarea = 0.0_r8 - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - rtmCTL%gindex(nr) = rgdc2glo(nr) - rtmCTL%mask(nr) = gmask(rgdc2glo(nr)) - n = rgdc2glo(nr) - i = mod(n-1,rtmlon) + 1 - j = (n-1)/rtmlon + 1 - if (n <= 0 .or. n > rtmlon*rtmlat) then - write(iulog,*) subname,' ERROR gdc2glo, nr,ng= ',nr,n - call shr_sys_abort(subname//' ERROR gdc2glo values') - endif - rtmCTL%lonc(nr) = rtmCTL%rlon(i) - rtmCTL%latc(nr) = rtmCTL%rlat(j) - - rtmCTL%outletg(nr) = idxocn(n) - rtmCTL%area(nr) = area_global(n) - lrtmarea = lrtmarea + rtmCTL%area(nr) - if (dnID_global(n) <= 0) then - rtmCTL%dsig(nr) = 0 - else - if (rglo2gdc(dnID_global(n)) == 0) then - write(iulog,*) subname,' ERROR glo2gdc dnID_global ',& - nr,n,dnID_global(n),rglo2gdc(dnID_global(n)) - call shr_sys_abort(subname//' ERROT glo2gdc dnID_global') - endif - cnt = cnt + 1 - rtmCTL%dsig(nr) = dnID_global(n) - endif - enddo - deallocate(gmask) - deallocate(rglo2gdc) - deallocate(rgdc2glo) - deallocate (dnID_global,area_global) - deallocate(idxocn) - call shr_mpi_sum(lrtmarea,rtmCTL%totarea,mpicom_rof,'mosart totarea',all=.true.) - if (masterproc) write(iulog,*) subname,' earth area ',4.0_r8*shr_const_pi*1.0e6_r8*re*re - if (masterproc) write(iulog,*) subname,' MOSART area ',rtmCTL%totarea - if (minval(rtmCTL%mask) < 1) then - write(iulog,*) subname,'ERROR rtmCTL mask lt 1 ',minval(rtmCTL%mask),maxval(rtmCTL%mask) - call shr_sys_abort(subname//' ERROR rtmCTL mask') - endif - - - !------------------------------------------------------- - ! Compute Sparse Matrix for downstream advection - !------------------------------------------------------- - - lsize = rtmCTL%lnumr - gsize = rtmlon*rtmlat - allocate(gindex(lsize)) - do nr = rtmCTL%begr,rtmCTL%endr - gindex(nr-rtmCTL%begr+1) = rtmCTL%gindex(nr) - enddo - call mct_gsMap_init( gsMap_r, gindex, mpicom_rof, ROFID, lsize, gsize ) - deallocate(gindex) - - if (smat_option == 'opt') then - ! distributed smat initialization - ! mct_sMat_init must be given the number of rows and columns that - ! would be in the full matrix. Nrows= size of output vector=nb. - ! Ncols = size of input vector = na. - - cnt = 0 - do nr=rtmCTL%begr,rtmCTL%endr - if(rtmCTL%dsig(nr) > 0) cnt = cnt + 1 - enddo - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - if (rtmCTL%dsig(nr) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = rtmCTL%dsig(nr) - sMat%data%iAttr(igcol,cnt) = rtmCTL%gindex(nr) - endif - enddo - - call mct_sMatP_Init(sMatP_dnstrm, sMat, gsMap_r, gsMap_r, 0, mpicom_rof, ROFID) - - elseif (smat_option == 'Xonly' .or. smat_option == 'Yonly') then - - ! root initialization - - call mct_aVect_init(avtmp,rList='f1:f2',lsize=lsize) - call mct_aVect_zero(avtmp) - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avtmp%rAttr(1,cnt) = rtmCTL%gindex(nr) - avtmp%rAttr(2,cnt) = rtmCTL%dsig(nr) - enddo - call mct_avect_gather(avtmp,avtmpG,gsmap_r,mastertask,mpicom_rof) - if (masterproc) then - cnt = 0 - do n = 1,rtmlon*rtmlat - if (avtmpG%rAttr(2,n) > 0) then - cnt = cnt + 1 - endif - enddo - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - - cnt = 0 - do n = 1,rtmlon*rtmlat - if (avtmpG%rAttr(2,n) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = avtmpG%rAttr(2,n) - sMat%data%iAttr(igcol,cnt) = avtmpG%rAttr(1,n) - endif - enddo - call mct_avect_clean(avtmpG) - else - call mct_sMat_init(sMat,1,1,1) - endif - call mct_avect_clean(avtmp) - - call mct_sMatP_Init(sMatP_dnstrm, sMat, gsMap_r, gsMap_r, smat_option, 0, mpicom_rof, ROFID) - - else - - write(iulog,*) trim(subname),' MOSART ERROR: invalid smat_option '//trim(smat_option) - call shr_sys_abort(trim(subname)//' ERROR invald smat option') - - endif - - ! initialize the AVs to go with sMatP - write(rList,'(a,i3.3)') 'tr',1 - do nt = 2,nt_rtm - write(rList,'(a,i3.3)') trim(rList)//':tr',nt - enddo - if (masterproc) write(iulog,*) trim(subname),' MOSART initialize avect ',trim(rList) - call mct_aVect_init(avsrc_dnstrm,rList=rList,lsize=rtmCTL%lnumr) - call mct_aVect_init(avdst_dnstrm,rList=rList,lsize=rtmCTL%lnumr) - - lsize = mct_smat_gNumEl(sMatP_dnstrm%Matrix,mpicom_rof) - if (masterproc) write(iulog,*) subname," Done initializing SmatP_dnstrm, nElements = ",lsize - - ! keep only sMatP - call mct_sMat_clean(sMat) - - !------------------------------------------------------- - ! Compute Sparse Matrix for direct to outlet transfer - ! reuse gsmap_r - !------------------------------------------------------- - - lsize = rtmCTL%lnumr - gsize = rtmlon*rtmlat - - if (smat_option == 'opt') then - ! distributed smat initialization - ! mct_sMat_init must be given the number of rows and columns that - ! would be in the full matrix. Nrows= size of output vector=nb. - ! Ncols = size of input vector = na. - - cnt = rtmCTL%endr - rtmCTL%begr + 1 - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - if (rtmCTL%outletg(nr) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = rtmCTL%outletg(nr) - sMat%data%iAttr(igcol,cnt) = rtmCTL%gindex(nr) - else - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = rtmCTL%gindex(nr) - sMat%data%iAttr(igcol,cnt) = rtmCTL%gindex(nr) - endif - enddo - if (cnt /= rtmCTL%endr - rtmCTL%begr + 1) then - write(iulog,*) trim(subname),' MOSART ERROR: smat cnt1 ',cnt,rtmCTL%endr-rtmCTL%begr+1 - call shr_sys_abort(trim(subname)//' ERROR smat cnt1') - endif - - call mct_sMatP_Init(sMatP_direct, sMat, gsMap_r, gsMap_r, 0, mpicom_rof, ROFID) - - elseif (smat_option == 'Xonly' .or. smat_option == 'Yonly') then - - ! root initialization - - call mct_aVect_init(avtmp,rList='f1:f2',lsize=lsize) - call mct_aVect_zero(avtmp) - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avtmp%rAttr(1,cnt) = rtmCTL%gindex(nr) - avtmp%rAttr(2,cnt) = rtmCTL%outletg(nr) - enddo - call mct_avect_gather(avtmp,avtmpG,gsmap_r,mastertask,mpicom_rof) - if (masterproc) then - - cnt = rtmlon*rtmlat - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - - cnt = 0 - do n = 1,rtmlon*rtmlat - if (avtmpG%rAttr(2,n) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = avtmpG%rAttr(2,n) - sMat%data%iAttr(igcol,cnt) = avtmpG%rAttr(1,n) - else - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = avtmpG%rAttr(1,n) - sMat%data%iAttr(igcol,cnt) = avtmpG%rAttr(1,n) - endif - enddo - if (cnt /= rtmlon*rtmlat) then - write(iulog,*) trim(subname),' MOSART ERROR: smat cnt2 ',cnt,rtmlon*rtmlat - call shr_sys_abort(trim(subname)//' ERROR smat cnt2') - endif - call mct_avect_clean(avtmpG) - else - call mct_sMat_init(sMat,1,1,1) - endif - call mct_avect_clean(avtmp) - - call mct_sMatP_Init(sMatP_direct, sMat, gsMap_r, gsMap_r, smat_option, 0, mpicom_rof, ROFID) - - else - - write(iulog,*) trim(subname),' MOSART ERROR: invalid smat_option '//trim(smat_option) - call shr_sys_abort(trim(subname)//' ERROR invald smat option') - - endif - - ! initialize the AVs to go with sMatP - write(rList,'(a,i3.3)') 'tr',1 - do nt = 2,nt_rtm - write(rList,'(a,i3.3)') trim(rList)//':tr',nt - enddo - if ( masterproc ) write(iulog,*) trim(subname),' MOSART initialize avect ',trim(rList) - call mct_aVect_init(avsrc_direct,rList=rList,lsize=rtmCTL%lnumr) - call mct_aVect_init(avdst_direct,rList=rList,lsize=rtmCTL%lnumr) - - lsize = mct_smat_gNumEl(sMatP_direct%Matrix,mpicom_rof) - if (masterproc) write(iulog,*) subname," Done initializing SmatP_direct, nElements = ",lsize - - ! keep only sMatP - call mct_sMat_clean(sMat) - - !------------------------------------------------------- - ! Compute timestep and subcycling number - !------------------------------------------------------- - - call t_stopf('mosarti_vars') - - !------------------------------------------------------- - ! Initialize mosart - !------------------------------------------------------- - - call t_startf('mosarti_mosart_init') - - !=== initialize MOSART related variables -! if (masterproc) write(iulog,*) ' call mosart_init' -! if (masterproc) call shr_sys_flush(iulog) - call MOSART_init() - - call t_stopf('mosarti_mosart_init') - - !------------------------------------------------------- - ! Read restart/initial info - !------------------------------------------------------- - - call t_startf('mosarti_restart') - -! if (masterproc) write(iulog,*) ' call RtmRestFileRead' -! if (masterproc) call shr_sys_flush(iulog) - - ! The call below opens and closes the file - if ((nsrest == nsrStartup .and. finidat_rtm /= ' ') .or. & - (nsrest == nsrContinue) .or. & - (nsrest == nsrBranch )) then - call RtmRestFileRead( file=fnamer ) - !write(iulog,*) ' MOSART init file is read' - TRunoff%wh = rtmCTL%wh - TRunoff%wt = rtmCTL%wt - TRunoff%wr = rtmCTL%wr - TRunoff%erout= rtmCTL%erout - else -! do nt = 1,nt_rtm -! do nr = rtmCTL%begr,rtmCTL%endr -! TRunoff%wh(nr,nt) = rtmCTL%area(nr) * river_depth_minimum * 1.e-10_r8 -! TRunoff%wt(nr,nt) = rtmCTL%area(nr) * river_depth_minimum * 1.e-8_r8 -! TRunoff%wr(nr,nt) = rtmCTL%area(nr) * river_depth_minimum * 10._r8 -! enddo -! enddo - endif - - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - call UpdateState_hillslope(nr,nt) - call UpdateState_subnetwork(nr,nt) - call UpdateState_mainchannel(nr,nt) - rtmCTL%volr(nr,nt) = (TRunoff%wt(nr,nt) + TRunoff%wr(nr,nt) + & - TRunoff%wh(nr,nt)*rtmCTL%area(nr)) - enddo - enddo - - call t_stopf('mosarti_restart') - - !------------------------------------------------------- - ! Initialize mosart history handler and fields - !------------------------------------------------------- - - call t_startf('mosarti_histinit') - -! if (masterproc) write(iulog,*) ' call RtmHistFldsInit' -! if (masterproc) call shr_sys_flush(iulog) - - call RtmHistFldsInit() - if (nsrest==nsrStartup .or. nsrest==nsrBranch) then - call RtmHistHtapesBuild() - end if - call RtmHistFldsSet() - - if (masterproc) write(iulog,*) subname,' done' - if (masterproc) call shr_sys_flush(iulog) - - call t_stopf('mosarti_histinit') - - end subroutine Rtmini - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: Rtmrun -! -! !INTERFACE: - subroutine Rtmrun(rstwr,nlend,rdate) -! -! !DESCRIPTION: -! River routing model -! -! !USES: -! -! !ARGUMENTS: - implicit none - logical , intent(in) :: rstwr ! true => write restart file this step) - logical , intent(in) :: nlend ! true => end of run on this step - character(len=*), intent(in) :: rdate ! restart file time stamp for name -! -! !CALLED FROM: -! subroutine RtmMap in this module -! -! !REVISION HISTORY: -! Author: Sam Levis -! -! -! !LOCAL VARIABLES: -!EOP - integer :: i, j, n, nr, ns, nt, n2, nf ! indices - real(r8) :: budget_terms(30,nt_rtm) ! BUDGET terms - ! BUDGET terms 1-10 are for volumes (m3) - ! BUDGET terms 11-30 are for flows (m3/s) - real(r8) :: budget_input, budget_output, budget_volume, budget_total, & - budget_euler, budget_eroutlag - real(r8),save :: budget_accum(nt_rtm) ! BUDGET accumulator over run - integer ,save :: budget_accum_cnt ! counter for budget_accum - real(r8) :: budget_global(30,nt_rtm) ! global budget sum - logical :: budget_check ! do global budget check - real(r8) :: volr_init ! temporary storage to compute dvolrdt - real(r8),parameter :: budget_tolerance = 1.0e-6 ! budget tolerance, m3/day - logical :: abort ! abort flag - real(r8) :: sum1,sum2 - integer :: yr, mon, day, ymd, tod ! time information - integer :: nsub ! subcyling for cfl - real(r8) :: delt ! delt associated with subcycling - real(r8) :: delt_coupling ! real value of coupling_period - integer , save :: nsub_save ! previous nsub - real(r8), save :: delt_save ! previous delt - logical , save :: first_call = .true. ! first time flag (for backwards compatibility) - character(len=256) :: filer ! restart file name - integer :: cnt ! counter for gridcells - integer :: ier ! error code - -! parameters used in negative runoff partitioning algorithm - real(r8) :: river_volume_minimum ! gridcell area multiplied by average river_depth_minimum [m3] - real(r8) :: qgwl_volume ! volume of runoff during time step [m3] - real(r8) :: irrig_volume ! volume of irrigation demand during time step [m3] - - character(len=*),parameter :: subname = '(Rtmrun) ' -!----------------------------------------------------------------------- - - call t_startf('mosartr_tot') - call shr_sys_flush(iulog) - - call get_curr_date(yr, mon, day, tod) - ymd = yr*10000 + mon*100 + day - if (tod == 0 .and. masterproc) then - write(iulog,*) ' ' - write(iulog,'(2a,i10,i6)') trim(subname),' model date is',ymd,tod - endif - - delt_coupling = coupling_period*1.0_r8 - if (first_call) then - budget_accum = 0._r8 - budget_accum_cnt = 0 - delt_save = delt_mosart - if (masterproc) write(iulog,'(2a,g20.12)') trim(subname),' MOSART coupling period ',delt_coupling - end if - - budget_check = .false. - if (day == 1 .and. mon == 1) budget_check = .true. - if (tod == 0) budget_check = .true. - budget_terms = 0._r8 - - flow = 0._r8 - erout_prev = 0._r8 - eroutup_avg = 0._r8 - erlat_avg = 0._r8 - rtmCTL%runoff = 0._r8 - rtmCTL%direct = 0._r8 - rtmCTL%flood = 0._r8 - rtmCTL%qirrig_actual = 0._r8 - rtmCTL%runofflnd = spval - rtmCTL%runoffocn = spval - rtmCTL%dvolrdt = 0._r8 - rtmCTL%dvolrdtlnd = spval - rtmCTL%dvolrdtocn = spval - - ! BUDGET - ! BUDGET terms 1-10 are for volumes (m3) - ! BUDGET terms 11-30 are for flows (m3/s) -! if (budget_check) then - call t_startf('mosartr_budget') - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - budget_terms( 1,nt) = budget_terms( 1,nt) + rtmCTL%volr(nr,nt) - budget_terms( 3,nt) = budget_terms( 3,nt) + TRunoff%wt(nr,nt) - budget_terms( 5,nt) = budget_terms( 5,nt) + TRunoff%wr(nr,nt) - budget_terms( 7,nt) = budget_terms( 7,nt) + TRunoff%wh(nr,nt)*rtmCTL%area(nr) - budget_terms(13,nt) = budget_terms(13,nt) + rtmCTL%qsur(nr,nt) - budget_terms(14,nt) = budget_terms(14,nt) + rtmCTL%qsub(nr,nt) - budget_terms(15,nt) = budget_terms(15,nt) + rtmCTL%qgwl(nr,nt) - budget_terms(17,nt) = budget_terms(17,nt) + rtmCTL%qsur(nr,nt) & - + rtmCTL%qsub(nr,nt)+ rtmCTL%qgwl(nr,nt) - if (nt==1) then - budget_terms(16,nt) = budget_terms(16,nt) + rtmCTL%qirrig(nr) - budget_terms(17,nt) = budget_terms(17,nt) + rtmCTL%qirrig(nr) - endif - enddo - enddo - call t_stopf('mosartr_budget') -! endif - - ! data for euler solver, in m3/s here - do nr = rtmCTL%begr,rtmCTL%endr - do nt = 1,nt_rtm - TRunoff%qsur(nr,nt) = rtmCTL%qsur(nr,nt) - TRunoff%qsub(nr,nt) = rtmCTL%qsub(nr,nt) - TRunoff%qgwl(nr,nt) = rtmCTL%qgwl(nr,nt) - enddo - enddo - - !----------------------------------- - ! Compute irrigation flux based on demand from clm - ! Must be calculated before volr is updated to be consistent with lnd - ! Just consider land points and only remove liquid water - !----------------------------------- - - call t_startf('mosartr_irrig') - nt = 1 - rtmCTL%qirrig_actual = 0._r8 - do nr = rtmCTL%begr,rtmCTL%endr - - ! calculate volume of irrigation flux during timestep - irrig_volume = -rtmCTL%qirrig(nr) * coupling_period - - ! compare irrig_volume to main channel storage; - ! add overage to subsurface runoff - if(irrig_volume > TRunoff%wr(nr,nt)) then - rtmCTL%qsub(nr,nt) = rtmCTL%qsub(nr,nt) & - + (TRunoff%wr(nr,nt) - irrig_volume) / coupling_period - TRunoff%qsub(nr,nt) = rtmCTL%qsub(nr,nt) - irrig_volume = TRunoff%wr(nr,nt) - endif - -!scs: how to deal with sink points / river outlets? -! if (rtmCTL%mask(nr) == 1) then - - ! actual irrigation rate [m3/s] - ! i.e. the rate actually removed from the main channel - ! if irrig_volume is greater than TRunoff%wr - rtmCTL%qirrig_actual(nr) = - irrig_volume / coupling_period - - ! remove irrigation from wr (main channel) - TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) - irrig_volume - - - -!scs endif - enddo - call t_stopf('mosartr_irrig') - - - !----------------------------------- - ! Compute flood - ! Remove water from mosart and send back to clm - ! Just consider land points and only remove liquid water - ! rtmCTL%flood is m3/s here - !----------------------------------- - - call t_startf('mosartr_flood') - nt = 1 - rtmCTL%flood = 0._r8 - do nr = rtmCTL%begr,rtmCTL%endr - ! initialize rtmCTL%flood to zero - if (rtmCTL%mask(nr) == 1) then - if (rtmCTL%volr(nr,nt) > rtmCTL%fthresh(nr)) then - ! determine flux that is sent back to the land - ! this is in m3/s - rtmCTL%flood(nr) = & - (rtmCTL%volr(nr,nt)-rtmCTL%fthresh(nr)) / (delt_coupling) - - ! rtmCTL%flood will be sent back to land - so must subtract this - ! from the input runoff from land - ! tcraig, comment - this seems like an odd approach, you - ! might create negative forcing. why not take it out of - ! the volr directly? it's also odd to compute this - ! at the initial time of the time loop. why not do - ! it at the end or even during the run loop as the - ! new volume is computed. fluxout depends on volr, so - ! how this is implemented does impact the solution. - TRunoff%qsur(nr,nt) = TRunoff%qsur(nr,nt) - rtmCTL%flood(nr) - endif - endif - enddo - call t_stopf('mosartr_flood') - - !----------------------------------------------------- - ! DIRECT sMAT transfer to outlet point using sMat - ! Remember to subtract water from TRunoff forcing - !----------------------------------------------------- - - if (barrier_timers) then - call t_startf('mosartr_SMdirect_barrier') - call mpi_barrier(mpicom_rof,ier) - call t_stopf ('mosartr_SMdirect_barrier') - endif - - call t_startf('mosartr_SMdirect') - !--- copy direct transfer fields to AV - !--- convert kg/m2s to m3/s - call mct_avect_zero(avsrc_direct) - - !----------------------------------------------------- - !--- all frozen runoff passed direct to outlet - !----------------------------------------------------- - nt = 2 - ! set euler_calc = false for frozen runoff - TUnit%euler_calc(nt) = .false. - - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avsrc_direct%rAttr(nt,cnt) = TRunoff%qsur(nr,nt)& - +TRunoff%qsub(nr,nt)+TRunoff%qgwl(nr,nt) - TRunoff%qsur(nr,nt) = 0._r8 - TRunoff%qsub(nr,nt) = 0._r8 - TRunoff%qgwl(nr,nt) = 0._r8 - enddo - - call mct_avect_zero(avdst_direct) - - call mct_sMat_avMult(avsrc_direct, sMatP_direct, avdst_direct) - - !--- copy direct transfer water from AV to output field --- - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + avdst_direct%rAttr(nt,cnt) - enddo - - !----------------------------------------------------- - !--- direct to outlet qgwl - !----------------------------------------------------- - !-- liquid runoff components - if (trim(bypass_routing_option) == 'direct_to_outlet') then - nt = 1 - - !--- copy direct transfer fields to AV - !--- convert kg/m2s to m3/s - call mct_avect_zero(avsrc_direct) - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - if (trim(qgwl_runoff_option) == 'all') then - avsrc_direct%rAttr(nt,cnt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 - else if (trim(qgwl_runoff_option) == 'negative') then - if(TRunoff%qgwl(nr,nt) < 0._r8) then - avsrc_direct%rAttr(nt,cnt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 - endif - endif - enddo - call mct_avect_zero(avdst_direct) - - call mct_sMat_avMult(avsrc_direct, sMatP_direct, avdst_direct) - - !--- copy direct transfer water from AV to output field --- - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + avdst_direct%rAttr(nt,cnt) - enddo - endif - - !----------------------------------------------------- - !--- direct in place qgwl - !----------------------------------------------------- - - if (trim(bypass_routing_option) == 'direct_in_place') then - nt = 1 - do nr = rtmCTL%begr,rtmCTL%endr - - if (trim(qgwl_runoff_option) == 'all') then - rtmCTL%direct(nr,nt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 - else if (trim(qgwl_runoff_option) == 'negative') then - if(TRunoff%qgwl(nr,nt) < 0._r8) then - rtmCTL%direct(nr,nt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 - endif - else if (trim(qgwl_runoff_option) == 'threshold') then - ! --- calculate volume of qgwl flux during timestep - qgwl_volume = TRunoff%qgwl(nr,nt) * rtmCTL%area(nr) * coupling_period - river_volume_minimum = river_depth_minimum * rtmCTL%area(nr) - ! if qgwl is negative, and adding it to the main channel - ! would bring main channel storage below a threshold, - ! send qgwl directly to ocean - if (((qgwl_volume + TRunoff%wr(nr,nt)) < river_volume_minimum) & - .and. (TRunoff%qgwl(nr,nt) < 0._r8)) then - rtmCTL%direct(nr,nt) = TRunoff%qgwl(nr,nt) - TRunoff%qgwl(nr,nt) = 0._r8 - endif - endif - enddo - endif - - !------------------------------------------------------- - !--- add other direct terms, e.g. inputs outside of - !--- mosart mask, negative qsur - !------------------------------------------------------- - - if (trim(bypass_routing_option) == 'direct_in_place') then - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - - if (TRunoff%qsub(nr,nt) < 0._r8) then - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + TRunoff%qsub(nr,nt) - TRunoff%qsub(nr,nt) = 0._r8 - endif - - if (TRunoff%qsur(nr,nt) < 0._r8) then - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + TRunoff%qsur(nr,nt) - TRunoff%qsur(nr,nt) = 0._r8 - endif - - if (TUnit%mask(nr) > 0) then - ! mosart euler - else - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + & - TRunoff%qsub(nr,nt) + & - TRunoff%qsur(nr,nt) + & - TRunoff%qgwl(nr,nt) - TRunoff%qsub(nr,nt) = 0._r8 - TRunoff%qsur(nr,nt) = 0._r8 - TRunoff%qgwl(nr,nt) = 0._r8 - endif - enddo - enddo - endif - - if (trim(bypass_routing_option) == 'direct_to_outlet') then - call mct_avect_zero(avsrc_direct) - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - do nt = 1,nt_rtm - !---- negative qsub water, remove from TRunoff --- - if (TRunoff%qsub(nr,nt) < 0._r8) then - avsrc_direct%rAttr(nt,cnt) = avsrc_direct%rAttr(nt,cnt) & - + TRunoff%qsub(nr,nt) - TRunoff%qsub(nr,nt) = 0._r8 - endif - - !---- negative qsur water, remove from TRunoff --- - if (TRunoff%qsur(nr,nt) < 0._r8) then - avsrc_direct%rAttr(nt,cnt) = avsrc_direct%rAttr(nt,cnt) & - + TRunoff%qsur(nr,nt) - TRunoff%qsur(nr,nt) = 0._r8 - endif - - !---- water outside the basin --- - !---- *** DO NOT TURN THIS ONE OFF, conservation will fail *** --- - if (TUnit%mask(nr) > 0) then - ! mosart euler - else - avsrc_direct%rAttr(nt,cnt) = avsrc_direct%rAttr(nt,cnt) + & - TRunoff%qsub(nr,nt) + & - TRunoff%qsur(nr,nt) + & - TRunoff%qgwl(nr,nt) - TRunoff%qsub(nr,nt) = 0._r8 - TRunoff%qsur(nr,nt) = 0._r8 - TRunoff%qgwl(nr,nt) = 0._r8 - endif - enddo - enddo - call mct_avect_zero(avdst_direct) - - call mct_sMat_avMult(avsrc_direct, sMatP_direct, avdst_direct) - - !--- copy direct transfer water from AV to output field --- - cnt = 0 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - do nt = 1,nt_rtm - rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + avdst_direct%rAttr(nt,cnt) - enddo - enddo - endif - call t_stopf('mosartr_SMdirect') - - !----------------------------------- - ! MOSART Subcycling - !----------------------------------- - - call t_startf('mosartr_subcycling') - - if (first_call .and. masterproc) then - do nt = 1,nt_rtm - write(iulog,'(2a,i6,l4)') trim(subname),' euler_calc for nt = ',nt,TUnit%euler_calc(nt) - enddo - endif - - nsub = coupling_period/delt_mosart - if (nsub*delt_mosart < coupling_period) then - nsub = nsub + 1 - end if - delt = delt_coupling/float(nsub) - if (delt /= delt_save) then - if (masterproc) then - write(iulog,'(2a,2g20.12,2i12)') trim(subname),' MOSART delt update from/to',delt_save,delt,nsub_save,nsub - end if - endif - - nsub_save = nsub - delt_save = delt - Tctl%DeltaT = delt - - !----------------------------------- - ! mosart euler solver - ! --- convert TRunoff fields from m3/s to m/s before calling Euler - !----------------------------------- - -! if (budget_check) then - call t_startf('mosartr_budget') - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - budget_terms(20,nt) = budget_terms(20,nt) + TRunoff%qsur(nr,nt) & - + TRunoff%qsub(nr,nt) + TRunoff%qgwl(nr,nt) - budget_terms(29,nt) = budget_terms(29,nt) + TRunoff%qgwl(nr,nt) - enddo - enddo - call t_stopf('mosartr_budget') -! endif - - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - TRunoff%qsur(nr,nt) = TRunoff%qsur(nr,nt) / rtmCTL%area(nr) - TRunoff%qsub(nr,nt) = TRunoff%qsub(nr,nt) / rtmCTL%area(nr) - TRunoff%qgwl(nr,nt) = TRunoff%qgwl(nr,nt) / rtmCTL%area(nr) - enddo - enddo - - do ns = 1,nsub - - call t_startf('mosartr_euler') - call Euler() - call t_stopf('mosartr_euler') - -! tcraig - NOT using this now, but leave it here in case it's useful in the future -! for some runoff terms. -! !----------------------------------- -! ! downstream advection using sMat -! !----------------------------------- -! -! if (barrier_timers) then -! call t_startf('mosartr_SMdnstrm_barrier') -! call mpi_barrier(mpicom_rof,ier) -! call t_stopf ('mosartr_SMdnstrm_barrier') -! endif -! -! call t_startf('mosartr_SMdnstrm') -! -! !--- copy fluxout into avsrc_dnstrm --- -! cnt = 0 -! do n = rtmCTL%begr,rtmCTL%endr -! cnt = cnt + 1 -! do nt = 1,nt_rtm -! avsrc_dnstrm%rAttr(nt,cnt) = fluxout(n,nt) -! enddo -! enddo -! call mct_avect_zero(avdst_dnstrm) -! -! call mct_sMat_avMult(avsrc_dnstrm, sMatP_dnstrm, avdst_dnstrm) -! -! !--- add mapped fluxout to sfluxin --- -! cnt = 0 -! sfluxin = 0._r8 -! do n = rtmCTL%begr,rtmCTL%endr -! cnt = cnt + 1 -! do nt = 1,nt_rtm -! sfluxin(n,nt) = sfluxin(n,nt) + avdst_dnstrm%rAttr(nt,cnt) -! enddo -! enddo -! call t_stopf('mosartr_SMdnstrm') - - !----------------------------------- - ! accumulate local flow field - !----------------------------------- - - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - flow(nr,nt) = flow(nr,nt) + TRunoff%flow(nr,nt) - erout_prev(nr,nt) = erout_prev(nr,nt) + TRunoff%erout_prev(nr,nt) - eroutup_avg(nr,nt) = eroutup_avg(nr,nt) + TRunoff%eroutup_avg(nr,nt) - erlat_avg(nr,nt) = erlat_avg(nr,nt) + TRunoff%erlat_avg(nr,nt) - enddo - enddo - - enddo ! nsub - - !----------------------------------- - ! average flow over subcycling - !----------------------------------- - - flow = flow / float(nsub) - erout_prev = erout_prev / float(nsub) - eroutup_avg = eroutup_avg / float(nsub) - erlat_avg = erlat_avg / float(nsub) - - !----------------------------------- - ! update states when subsycling completed - !----------------------------------- - - rtmCTL%wh = TRunoff%wh - rtmCTL%wt = TRunoff%wt - rtmCTL%wr = TRunoff%wr - rtmCTL%erout = TRunoff%erout - - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - volr_init = rtmCTL%volr(nr,nt) - rtmCTL%volr(nr,nt) = (TRunoff%wt(nr,nt) + TRunoff%wr(nr,nt) + & - TRunoff%wh(nr,nt)*rtmCTL%area(nr)) - rtmCTL%dvolrdt(nr,nt) = (rtmCTL%volr(nr,nt) - volr_init) / delt_coupling - rtmCTL%runoff(nr,nt) = flow(nr,nt) - - rtmCTL%runofftot(nr,nt) = rtmCTL%direct(nr,nt) - if (rtmCTL%mask(nr) == 1) then - rtmCTL%runofflnd(nr,nt) = rtmCTL%runoff(nr,nt) - rtmCTL%dvolrdtlnd(nr,nt)= rtmCTL%dvolrdt(nr,nt) - elseif (rtmCTL%mask(nr) >= 2) then - rtmCTL%runoffocn(nr,nt) = rtmCTL%runoff(nr,nt) - rtmCTL%runofftot(nr,nt) = rtmCTL%runofftot(nr,nt) + rtmCTL%runoff(nr,nt) - rtmCTL%dvolrdtocn(nr,nt)= rtmCTL%dvolrdt(nr,nt) - endif - enddo - enddo - - call t_stopf('mosartr_subcycling') - - !----------------------------------- - ! BUDGET - !----------------------------------- - - ! BUDGET - ! BUDGET terms 1-10 are for volumes (m3) - ! BUDGET terms 11-30 are for flows (m3/s) - ! BUDGET only ocean runoff and direct gets out of the system -! if (budget_check) then - call t_startf('mosartr_budget') - do nt = 1,nt_rtm - do nr = rtmCTL%begr,rtmCTL%endr - budget_terms( 2,nt) = budget_terms( 2,nt) + rtmCTL%volr(nr,nt) - budget_terms( 4,nt) = budget_terms( 4,nt) + TRunoff%wt(nr,nt) - budget_terms( 6,nt) = budget_terms( 6,nt) + TRunoff%wr(nr,nt) - budget_terms( 8,nt) = budget_terms( 8,nt) + TRunoff%wh(nr,nt)*rtmCTL%area(nr) - budget_terms(21,nt) = budget_terms(21,nt) + rtmCTL%direct(nr,nt) - if (rtmCTL%mask(nr) >= 2) then - budget_terms(18,nt) = budget_terms(18,nt) + rtmCTL%runoff(nr,nt) - budget_terms(26,nt) = budget_terms(26,nt) - erout_prev(nr,nt) - budget_terms(27,nt) = budget_terms(27,nt) + flow(nr,nt) - else - budget_terms(23,nt) = budget_terms(23,nt) - erout_prev(nr,nt) - budget_terms(24,nt) = budget_terms(24,nt) + flow(nr,nt) - endif - budget_terms(25,nt) = budget_terms(25,nt) - eroutup_avg(nr,nt) - budget_terms(28,nt) = budget_terms(28,nt) - erlat_avg(nr,nt) - budget_terms(22,nt) = budget_terms(22,nt) + rtmCTL%runoff(nr,nt) + rtmCTL%direct(nr,nt) + eroutup_avg(nr,nt) - enddo - enddo - nt = 1 - do nr = rtmCTL%begr,rtmCTL%endr - budget_terms(19,nt) = budget_terms(19,nt) + rtmCTL%flood(nr) - budget_terms(22,nt) = budget_terms(22,nt) + rtmCTL%flood(nr) - enddo - - ! accumulate the budget total over the run to make sure it's decreasing on avg - budget_accum_cnt = budget_accum_cnt + 1 - do nt = 1,nt_rtm - budget_volume = (budget_terms( 2,nt) - budget_terms( 1,nt)) / delt_coupling - budget_input = (budget_terms(13,nt) + budget_terms(14,nt) + & - budget_terms(15,nt) + budget_terms(16,nt)) - budget_output = (budget_terms(18,nt) + budget_terms(19,nt) + & - budget_terms(21,nt)) - budget_total = budget_volume - budget_input + budget_output - budget_accum(nt) = budget_accum(nt) + budget_total - budget_terms(30,nt) = budget_accum(nt)/budget_accum_cnt - enddo - call t_stopf('mosartr_budget') - - if (budget_check) then - call t_startf('mosartr_budget') - !--- check budget - - ! convert fluxes from m3/s to m3 by mult by coupling_period - budget_terms(11:30,:) = budget_terms(11:30,:) * delt_coupling - - ! convert terms from m3 to million m3 - budget_terms(:,:) = budget_terms(:,:) * 1.0e-6_r8 - - ! global sum - call shr_mpi_sum(budget_terms,budget_global,mpicom_rof,'mosart global budget',all=.false.) - - ! write budget - if (masterproc) then - write(iulog,'(2a,i10,i6)') trim(subname),' MOSART BUDGET diagnostics (million m3) for ',ymd,tod - do nt = 1,nt_rtm - budget_volume = (budget_global( 2,nt) - budget_global( 1,nt)) - budget_input = (budget_global(13,nt) + budget_global(14,nt) + & - budget_global(15,nt)) - budget_output = (budget_global(18,nt) + budget_global(19,nt) + & - budget_global(21,nt)) - budget_total = budget_volume - budget_input + budget_output - budget_euler = budget_volume - budget_global(20,nt) + budget_global(18,nt) - budget_eroutlag = budget_global(23,nt) - budget_global(24,nt) - write(iulog,'(2a,i4)') trim(subname),' tracer = ',nt - write(iulog,'(2a,i4,f22.6)') trim(subname),' volume init = ',nt,budget_global(1,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' volume final = ',nt,budget_global(2,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumeh init = ',nt,budget_global(7,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumeh final = ',nt,budget_global(8,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumet init = ',nt,budget_global(3,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumet final = ',nt,budget_global(4,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumer init = ',nt,budget_global(5,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' volumer final = ',nt,budget_global(6,nt) - !write(iulog,'(2a)') trim(subname),'----------------' - write(iulog,'(2a,i4,f22.6)') trim(subname),' input surface = ',nt,budget_global(13,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' input subsurf = ',nt,budget_global(14,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' input gwl = ',nt,budget_global(15,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' input irrig = ',nt,budget_global(16,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' input total = ',nt,budget_global(17,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' input check = ',nt,budget_input - budget_global(17,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' input euler = ',nt,budget_global(20,nt) - !write(iulog,'(2a)') trim(subname),'----------------' - write(iulog,'(2a,i4,f22.6)') trim(subname),' output flow = ',nt,budget_global(18,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' output direct = ',nt,budget_global(21,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' output flood = ',nt,budget_global(19,nt) - write(iulog,'(2a,i4,f22.6)') trim(subname),' output total = ',nt,budget_global(22,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' output check = ',nt,budget_output - budget_global(22,nt) - !write(iulog,'(2a)') trim(subname),'----------------' - write(iulog,'(2a,i4,f22.6)') trim(subname),' sum input = ',nt,budget_input - write(iulog,'(2a,i4,f22.6)') trim(subname),' sum dvolume = ',nt,budget_volume - write(iulog,'(2a,i4,f22.6)') trim(subname),' sum output = ',nt,budget_output - !write(iulog,'(2a)') trim(subname),'----------------' - write(iulog,'(2a,i4,f22.6)') trim(subname),' net (dv-i+o) = ',nt,budget_total - !write(iulog,'(2a,i4,f22.6)') trim(subname),' net euler = ',nt,budget_euler - write(iulog,'(2a,i4,f22.6)') trim(subname),' eul erout lag = ',nt,budget_eroutlag - !write(iulog,'(2a,i4,f22.6)') trim(subname),' accum (dv-i+o)= ',nt,budget_global(30,nt) - !write(iulog,'(2a)') trim(subname),'----------------' - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout_prev no= ',nt,budget_global(23,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout no= ',nt,budget_global(24,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' eroutup_avg = ',nt,budget_global(25,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout_prev out= ',nt,budget_global(26,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erout out= ',nt,budget_global(27,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' erlateral = ',nt,budget_global(28,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' euler gwl = ',nt,budget_global(29,nt) - !write(iulog,'(2a,i4,f22.6)') trim(subname),' net main chan = ',nt,budget_global(6,nt)-budget_global(5,nt)+budget_global(24,nt)-budget_global(23,nt)+budget_global(27,nt)+budget_global(28,nt)+budget_global(29,nt) - !write(iulog,'(2a)') trim(subname),'----------------' - - if ((budget_total-budget_eroutlag) > 1.0e-6) then - write(iulog,'(2a,i4)') trim(subname),' ***** BUDGET WARNING error gt 1. m3 for nt = ',nt - endif - if ((budget_total+budget_eroutlag) >= 1.0e-6) then - if ((budget_total-budget_eroutlag)/(budget_total+budget_eroutlag) > 0.001_r8) then - write(iulog,'(2a,i4)') trim(subname),' ***** BUDGET WARNING out of balance for nt = ',nt - endif - endif - enddo - write(iulog,'(a)') '----------------------------------- ' - endif - - call t_stopf('mosartr_budget') - endif ! budget_check - - !----------------------------------- - ! Write out MOSART history file - !----------------------------------- - - call t_startf('mosartr_hbuf') - call RtmHistFldsSet() - call RtmHistUpdateHbuf() - call t_stopf('mosartr_hbuf') - - call t_startf('mosartr_htapes') - call RtmHistHtapesWrapup( rstwr, nlend ) - call t_stopf('mosartr_htapes') - - !----------------------------------- - ! Write out MOSART restart file - !----------------------------------- - - if (rstwr) then - call t_startf('mosartr_rest') - filer = RtmRestFileName(rdate=rdate) - call RtmRestFileWrite( filer, rdate=rdate ) - call t_stopf('mosartr_rest') - end if - - !----------------------------------- - ! Done - !----------------------------------- - - first_call = .false. - - call shr_sys_flush(iulog) - call t_stopf('mosartr_tot') - - end subroutine Rtmrun - -!----------------------------------------------------------------------- - - subroutine RtmFloodInit(frivinp, begr, endr, fthresh, evel ) - - !----------------------------------------------------------------------- - ! Uses - - ! Input variables - character(len=*), intent(in) :: frivinp - integer , intent(in) :: begr, endr - real(r8), intent(out) :: fthresh(begr:endr) - real(r8), intent(out) :: evel(begr:endr,nt_rtm) - - ! Local variables - real(r8) , pointer :: rslope(:) - real(r8) , pointer :: max_volr(:) - integer, pointer :: compdof(:) ! computational degrees of freedom for pio - integer :: nt,n,cnt ! indices - logical :: readvar ! read variable in or not - integer :: ier ! status variable - integer :: dids(2) ! variable dimension ids - type(file_desc_t) :: ncid ! pio file desc - type(var_desc_t) :: vardesc ! pio variable desc - type(io_desc_t) :: iodesc ! pio io desc - character(len=256) :: locfn ! local file name - - !MOSART Flood variables for spatially varying celerity - real(r8) :: effvel(nt_rtm) = 0.7_r8 ! downstream velocity (m/s) - real(r8) :: min_ev(nt_rtm) = 0.35_r8 ! minimum downstream velocity (m/s) - real(r8) :: fslope = 1.0_r8 ! maximum slope for which flooding can occur - character(len=*),parameter :: subname = '(RtmFloodInit) ' - !----------------------------------------------------------------------- - - allocate(rslope(begr:endr), max_volr(begr:endr), stat=ier) - if (ier /= 0) call shr_sys_abort(subname // ' allocation ERROR') - - ! Assume that if SLOPE is on river input dataset so is MAX_VOLR and that - ! both have the same io descriptor - - call getfil(frivinp, locfn, 0 ) - call ncd_pio_openfile (ncid, trim(locfn), 0) - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ier = pio_inq_varid(ncid, name='SLOPE', vardesc=vardesc) - if (ier /= PIO_noerr) then - if (masterproc) write(iulog,*) subname//' variable SLOPE is not on dataset' - readvar = .false. - else - readvar = .true. - end if - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - if (readvar) then - ier = pio_inq_vardimid(ncid, vardesc, dids) - allocate(compdof(rtmCTL%lnumr)) - cnt = 0 - do n = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - compDOF(cnt) = rtmCTL%gindex(n) - enddo - call pio_initdecomp(pio_subsystem, pio_double, dids, compDOF, iodesc) - deallocate(compdof) -! tcraig, there ia bug here, shouldn't use same vardesc for two different variable - call pio_read_darray(ncid, vardesc, iodesc, rslope, ier) - call pio_read_darray(ncid, vardesc, iodesc, max_volr, ier) - call pio_freedecomp(ncid, iodesc) - else - rslope(:) = 1._r8 - max_volr(:) = spval - end if - call pio_closefile(ncid) - - do nt = 1,nt_rtm - do n = rtmCTL%begr, rtmCTL%endr - fthresh(n) = 0.95*max_volr(n)*max(1._r8,rslope(n)) - ! modify velocity based on gridcell average slope (Manning eqn) - evel(n,nt) = max(min_ev(nt),effvel(nt_rtm)*sqrt(max(0._r8,rslope(n)))) - end do - end do - - deallocate(rslope, max_volr) - - end subroutine RtmFloodInit - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: -! -! !INTERFACE: - subroutine MOSART_init -! -! !REVISION HISTORY: -! Author: Hongyi Li - -! !DESCRIPTION: -! initialize MOSART variables -! -! !USES: -! !ARGUMENTS: - implicit none -! -! !REVISION HISTORY: -! Author: Hongyi Li -! -! -! !OTHER LOCAL VARIABLES: -!EOP - type(file_desc_t) :: ncid ! pio file desc - type(var_desc_t) :: vardesc ! pio variable desc - type(io_desc_t) :: iodesc_dbl ! pio io desc - type(io_desc_t) :: iodesc_int ! pio io desc - integer, pointer :: compdof(:) ! computational degrees of freedom for pio - integer :: dids(2) ! variable dimension ids - integer :: dsizes(2) ! variable dimension lengths - integer :: ier ! error code - integer :: begr, endr, iunit, nn, n, cnt, nr, nt - integer :: numDT_r, numDT_t - integer :: lsize, gsize - integer :: igrow, igcol, iwgt - type(mct_avect) :: avtmp, avtmpG ! temporary avects - type(mct_sMat) :: sMat ! temporary sparse matrix, needed for sMatP - real(r8):: areatot_prev, areatot_tmp, areatot_new - real(r8):: hlen_max, rlen_min - integer :: tcnt - character(len=16384) :: rList ! list of fields for SM multiply - character(len=1000) :: fname - character(len=*),parameter :: subname = '(MOSART_init)' - character(len=*),parameter :: FORMI = '(2A,2i10)' - character(len=*),parameter :: FORMR = '(2A,2g15.7)' - - begr = rtmCTL%begr - endr = rtmCTL%endr - - if(endr >= begr) then - ! routing parameters - call ncd_pio_openfile (ncid, trim(frivinp_rtm), 0) - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - allocate(compdof(rtmCTL%lnumr)) - cnt = 0 - do n = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - compDOF(cnt) = rtmCTL%gindex(n) - enddo - - ! setup iodesc based on frac dids - ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) - ier = pio_inq_vardimid(ncid, vardesc, dids) - ier = pio_inq_dimlen(ncid, dids(1),dsizes(1)) - ier = pio_inq_dimlen(ncid, dids(2),dsizes(2)) - call pio_initdecomp(pio_subsystem, pio_double, dsizes, compDOF, iodesc_dbl) - call pio_initdecomp(pio_subsystem, pio_int , dsizes, compDOF, iodesc_int) - deallocate(compdof) - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - - allocate(TUnit%euler_calc(nt_rtm)) - Tunit%euler_calc = .true. - - allocate(TUnit%frac(begr:endr)) - ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%frac, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read frac ',minval(Tunit%frac),maxval(Tunit%frac) - call shr_sys_flush(iulog) - - ! read fdir, convert to mask - ! fdir <0 ocean, 0=outlet, >0 land - ! tunit mask is 0=ocean, 1=land, 2=outlet for mosart calcs - - allocate(TUnit%mask(begr:endr)) - ier = pio_inq_varid(ncid, name='fdir', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_int, TUnit%mask, ier) - if (masterproc) write(iulog,FORMI) trim(subname),' read fdir mask ',minval(Tunit%mask),maxval(Tunit%mask) - call shr_sys_flush(iulog) - - do n = rtmCtl%begr, rtmCTL%endr - if (Tunit%mask(n) < 0) then - Tunit%mask(n) = 0 - elseif (Tunit%mask(n) == 0) then - Tunit%mask(n) = 2 - if (abs(Tunit%frac(n)-1.0_r8)>1.0e-9) then - write(iulog,*) subname,' ERROR frac ne 1.0',n,Tunit%frac(n) - call shr_sys_abort(subname//' ERROR frac ne 1.0') - endif - elseif (Tunit%mask(n) > 0) then - Tunit%mask(n) = 1 - if (abs(Tunit%frac(n)-1.0_r8)>1.0e-9) then - write(iulog,*) subname,' ERROR frac ne 1.0',n,Tunit%frac(n) - call shr_sys_abort(subname//' ERROR frac ne 1.0') - endif - else - call shr_sys_abort(subname//' Tunit mask error') - endif - enddo - - allocate(TUnit%ID0(begr:endr)) - ier = pio_inq_varid(ncid, name='ID', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_int, TUnit%ID0, ier) - if (masterproc) write(iulog,FORMI) trim(subname),' read ID0 ',minval(Tunit%ID0),maxval(Tunit%ID0) - call shr_sys_flush(iulog) - - allocate(TUnit%dnID(begr:endr)) - ier = pio_inq_varid(ncid, name='dnID', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_int, TUnit%dnID, ier) - if (masterproc) write(iulog,FORMI) trim(subname),' read dnID ',minval(Tunit%dnID),maxval(Tunit%dnID) - call shr_sys_flush(iulog) - - !------------------------------------------------------- - ! RESET ID0 and dnID indices using the IDkey to be consistent - ! with standard gindex order to leverage gsmap_r - !------------------------------------------------------- - do n=rtmCtl%begr, rtmCTL%endr - TUnit%ID0(n) = IDkey(TUnit%ID0(n)) - if (Tunit%dnID(n) > 0 .and. TUnit%dnID(n) <= rtmlon*rtmlat) then - if (IDkey(TUnit%dnID(n)) > 0 .and. IDkey(TUnit%dnID(n)) <= rtmlon*rtmlat) then - TUnit%dnID(n) = IDkey(TUnit%dnID(n)) - else - write(iulog,*) subname,' ERROR bad IDkey for TUnit%dnID',n,TUnit%dnID(n),IDkey(TUnit%dnID(n)) - call shr_sys_abort(subname//' ERROR bad IDkey for TUnit%dnID') - endif - endif - enddo - - allocate(TUnit%area(begr:endr)) - ier = pio_inq_varid(ncid, name='area', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%area, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read area ',minval(Tunit%area),maxval(Tunit%area) - call shr_sys_flush(iulog) - - do n=rtmCtl%begr, rtmCTL%endr - if (TUnit%area(n) < 0._r8) TUnit%area(n) = rtmCTL%area(n) - if (TUnit%area(n) /= rtmCTL%area(n)) then - write(iulog,*) subname,' ERROR area mismatch',TUnit%area(n),rtmCTL%area(n) - call shr_sys_abort(subname//' ERROR area mismatch') - endif - enddo - - allocate(TUnit%areaTotal(begr:endr)) - ier = pio_inq_varid(ncid, name='areaTotal', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%areaTotal, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read areaTotal ',minval(Tunit%areaTotal),maxval(Tunit%areaTotal) - call shr_sys_flush(iulog) - - allocate(TUnit%rlenTotal(begr:endr)) - TUnit%rlenTotal = 0._r8 - - allocate(TUnit%nh(begr:endr)) - ier = pio_inq_varid(ncid, name='nh', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%nh, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read nh ',minval(Tunit%nh),maxval(Tunit%nh) - call shr_sys_flush(iulog) - - allocate(TUnit%hslp(begr:endr)) - ier = pio_inq_varid(ncid, name='hslp', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%hslp, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read hslp ',minval(Tunit%hslp),maxval(Tunit%hslp) - call shr_sys_flush(iulog) - - allocate(TUnit%hslpsqrt(begr:endr)) - TUnit%hslpsqrt = 0._r8 - - allocate(TUnit%gxr(begr:endr)) - ier = pio_inq_varid(ncid, name='gxr', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%gxr, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read gxr ',minval(Tunit%gxr),maxval(Tunit%gxr) - call shr_sys_flush(iulog) - - allocate(TUnit%hlen(begr:endr)) - TUnit%hlen = 0._r8 - - allocate(TUnit%tslp(begr:endr)) - ier = pio_inq_varid(ncid, name='tslp', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%tslp, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read tslp ',minval(Tunit%tslp),maxval(Tunit%tslp) - call shr_sys_flush(iulog) - - allocate(TUnit%tslpsqrt(begr:endr)) - TUnit%tslpsqrt = 0._r8 - - allocate(TUnit%tlen(begr:endr)) - TUnit%tlen = 0._r8 - - allocate(TUnit%twidth(begr:endr)) - ier = pio_inq_varid(ncid, name='twid', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%twidth, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read twidth ',minval(Tunit%twidth),maxval(Tunit%twidth) - call shr_sys_flush(iulog) - ! save twidth before adjusted below - allocate(TUnit%twidth0(begr:endr)) - TUnit%twidth0(begr:endr)=TUnit%twidth(begr:endr) - - allocate(TUnit%nt(begr:endr)) - ier = pio_inq_varid(ncid, name='nt', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%nt, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read nt ',minval(Tunit%nt),maxval(Tunit%nt) - call shr_sys_flush(iulog) - - allocate(TUnit%rlen(begr:endr)) - ier = pio_inq_varid(ncid, name='rlen', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rlen, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read rlen ',minval(Tunit%rlen),maxval(Tunit%rlen) - call shr_sys_flush(iulog) - - allocate(TUnit%rslp(begr:endr)) - ier = pio_inq_varid(ncid, name='rslp', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rslp, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read rslp ',minval(Tunit%rslp),maxval(Tunit%rslp) - call shr_sys_flush(iulog) - - allocate(TUnit%rslpsqrt(begr:endr)) - TUnit%rslpsqrt = 0._r8 - - allocate(TUnit%rwidth(begr:endr)) - ier = pio_inq_varid(ncid, name='rwid', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rwidth, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read rwidth ',minval(Tunit%rwidth),maxval(Tunit%rwidth) - call shr_sys_flush(iulog) - - allocate(TUnit%rwidth0(begr:endr)) - ier = pio_inq_varid(ncid, name='rwid0', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rwidth0, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read rwidth0 ',minval(Tunit%rwidth0),maxval(Tunit%rwidth0) - call shr_sys_flush(iulog) - - allocate(TUnit%rdepth(begr:endr)) - ier = pio_inq_varid(ncid, name='rdep', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%rdepth, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read rdepth ',minval(Tunit%rdepth),maxval(Tunit%rdepth) - call shr_sys_flush(iulog) - - allocate(TUnit%nr(begr:endr)) - ier = pio_inq_varid(ncid, name='nr', vardesc=vardesc) - call pio_read_darray(ncid, vardesc, iodesc_dbl, TUnit%nr, ier) - if (masterproc) write(iulog,FORMR) trim(subname),' read nr ',minval(Tunit%nr),maxval(Tunit%nr) - call shr_sys_flush(iulog) - - allocate(TUnit%nUp(begr:endr)) - TUnit%nUp = 0 - - allocate(TUnit%iUp(begr:endr,8)) - TUnit%iUp = 0 - - allocate(TUnit%indexDown(begr:endr)) - TUnit%indexDown = 0 - - ! initialize water states and fluxes - allocate (TRunoff%wh(begr:endr,nt_rtm)) - TRunoff%wh = 0._r8 - - allocate (TRunoff%dwh(begr:endr,nt_rtm)) - TRunoff%dwh = 0._r8 - - allocate (TRunoff%yh(begr:endr,nt_rtm)) - TRunoff%yh = 0._r8 - - allocate (TRunoff%qsur(begr:endr,nt_rtm)) - TRunoff%qsur = 0._r8 - - allocate (TRunoff%qsub(begr:endr,nt_rtm)) - TRunoff%qsub = 0._r8 - - allocate (TRunoff%qgwl(begr:endr,nt_rtm)) - TRunoff%qgwl = 0._r8 - - allocate (TRunoff%ehout(begr:endr,nt_rtm)) - TRunoff%ehout = 0._r8 - - allocate (TRunoff%tarea(begr:endr,nt_rtm)) - TRunoff%tarea = 0._r8 - - allocate (TRunoff%wt(begr:endr,nt_rtm)) - TRunoff%wt= 0._r8 - - allocate (TRunoff%dwt(begr:endr,nt_rtm)) - TRunoff%dwt = 0._r8 - - allocate (TRunoff%yt(begr:endr,nt_rtm)) - TRunoff%yt = 0._r8 - - allocate (TRunoff%mt(begr:endr,nt_rtm)) - TRunoff%mt = 0._r8 - - allocate (TRunoff%rt(begr:endr,nt_rtm)) - TRunoff%rt = 0._r8 - - allocate (TRunoff%pt(begr:endr,nt_rtm)) - TRunoff%pt = 0._r8 - - allocate (TRunoff%vt(begr:endr,nt_rtm)) - TRunoff%vt = 0._r8 - - allocate (TRunoff%tt(begr:endr,nt_rtm)) - TRunoff%tt = 0._r8 - - allocate (TRunoff%etin(begr:endr,nt_rtm)) - TRunoff%etin = 0._r8 - - allocate (TRunoff%etout(begr:endr,nt_rtm)) - TRunoff%etout = 0._r8 - - allocate (TRunoff%rarea(begr:endr,nt_rtm)) - TRunoff%rarea = 0._r8 - - allocate (TRunoff%wr(begr:endr,nt_rtm)) - TRunoff%wr = 0._r8 - - allocate (TRunoff%dwr(begr:endr,nt_rtm)) - TRunoff%dwr = 0._r8 - - allocate (TRunoff%yr(begr:endr,nt_rtm)) - TRunoff%yr = 0._r8 - - allocate (TRunoff%mr(begr:endr,nt_rtm)) - TRunoff%mr = 0._r8 - - allocate (TRunoff%rr(begr:endr,nt_rtm)) - TRunoff%rr = 0._r8 - - allocate (TRunoff%pr(begr:endr,nt_rtm)) - TRunoff%pr = 0._r8 - - allocate (TRunoff%vr(begr:endr,nt_rtm)) - TRunoff%vr = 0._r8 - - allocate (TRunoff%tr(begr:endr,nt_rtm)) - TRunoff%tr = 0._r8 - - allocate (TRunoff%erlg(begr:endr,nt_rtm)) - TRunoff%erlg = 0._r8 - - allocate (TRunoff%erlateral(begr:endr,nt_rtm)) - TRunoff%erlateral = 0._r8 - - allocate (TRunoff%erin(begr:endr,nt_rtm)) - TRunoff%erin = 0._r8 - - allocate (TRunoff%erout(begr:endr,nt_rtm)) - TRunoff%erout = 0._r8 - - allocate (TRunoff%erout_prev(begr:endr,nt_rtm)) - TRunoff%erout_prev = 0._r8 - - allocate (TRunoff%eroutUp(begr:endr,nt_rtm)) - TRunoff%eroutUp = 0._r8 - - allocate (TRunoff%eroutUp_avg(begr:endr,nt_rtm)) - TRunoff%eroutUp_avg = 0._r8 - - allocate (TRunoff%erlat_avg(begr:endr,nt_rtm)) - TRunoff%erlat_avg = 0._r8 - - allocate (TRunoff%ergwl(begr:endr,nt_rtm)) - TRunoff%ergwl = 0._r8 - - allocate (TRunoff%flow(begr:endr,nt_rtm)) - TRunoff%flow = 0._r8 - - allocate (TPara%c_twid(begr:endr)) - TPara%c_twid = 1.0_r8 - - call pio_freedecomp(ncid, iodesc_dbl) - call pio_freedecomp(ncid, iodesc_int) - call pio_closefile(ncid) - - ! control parameters and some other derived parameters - ! estimate derived input variables - - ! add minimum value to rlen (length of main channel); rlen values can - ! be too small, leading to tlen values that are too large - - do iunit=rtmCTL%begr,rtmCTL%endr - rlen_min = sqrt(TUnit%area(iunit)) - if(TUnit%rlen(iunit) < rlen_min) then - TUnit%rlen(iunit) = rlen_min - end if - end do - - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%Gxr(iunit) > 0._r8) then - TUnit%rlenTotal(iunit) = TUnit%area(iunit)*TUnit%Gxr(iunit) - end if - end do - - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%rlen(iunit) > TUnit%rlenTotal(iunit)) then - TUnit%rlenTotal(iunit) = TUnit%rlen(iunit) - end if - end do - - do iunit=rtmCTL%begr,rtmCTL%endr - - if(TUnit%rlen(iunit) > 0._r8) then - TUnit%hlen(iunit) = TUnit%area(iunit) / TUnit%rlenTotal(iunit) / 2._r8 - - ! constrain hlen (hillslope length) values based on cell area - hlen_max = max(1000.0_r8, sqrt(TUnit%area(iunit))) - if(TUnit%hlen(iunit) > hlen_max) then - TUnit%hlen(iunit) = hlen_max ! allievate the outlier in drainag\e density estimation. TO DO - end if - - TUnit%tlen(iunit) = TUnit%area(iunit) / TUnit%rlen(iunit) / 2._r8 - TUnit%hlen(iunit) - - if(TUnit%twidth(iunit) < 0._r8) then - TUnit%twidth(iunit) = 0._r8 - end if - if(TUnit%tlen(iunit) > 0._r8 .and. (TUnit%rlenTotal(iunit)-TUnit%rlen(iunit))/TUnit%tlen(iunit) > 1._r8) then - TUnit%twidth(iunit) = TPara%c_twid(iunit)*TUnit%twidth(iunit)* & - ((TUnit%rlenTotal(iunit)-TUnit%rlen(iunit))/TUnit%tlen(iunit)) - end if - - if(TUnit%tlen(iunit) > 0._r8 .and. TUnit%twidth(iunit) <= 0._r8) then - TUnit%twidth(iunit) = 0._r8 - end if - else - TUnit%hlen(iunit) = 0._r8 - TUnit%tlen(iunit) = 0._r8 - TUnit%twidth(iunit) = 0._r8 - end if - - if(TUnit%rslp(iunit) <= 0._r8) then - TUnit%rslp(iunit) = 0.0001_r8 - end if - if(TUnit%tslp(iunit) <= 0._r8) then - TUnit%tslp(iunit) = 0.0001_r8 - end if - if(TUnit%hslp(iunit) <= 0._r8) then - TUnit%hslp(iunit) = 0.005_r8 - end if - TUnit%rslpsqrt(iunit) = sqrt(Tunit%rslp(iunit)) - TUnit%tslpsqrt(iunit) = sqrt(Tunit%tslp(iunit)) - TUnit%hslpsqrt(iunit) = sqrt(Tunit%hslp(iunit)) - end do - - lsize = rtmCTL%lnumr - gsize = rtmlon*rtmlat - - if (smat_option == 'opt') then - ! distributed smat initialization - ! mct_sMat_init must be given the number of rows and columns that - ! would be in the full matrix. Nrows= size of output vector=nb. - ! Ncols = size of input vector = na. - - cnt = 0 - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 - enddo - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr - if (TUnit%dnID(iunit) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = TUnit%dnID(iunit) - sMat%data%iAttr(igcol,cnt) = TUnit%ID0(iunit) - endif - enddo - - call mct_sMatP_Init(sMatP_eroutUp, sMat, gsMap_r, gsMap_r, 0, mpicom_rof, ROFID) - - elseif (smat_option == 'Xonly' .or. smat_option == 'Yonly') then - ! root initialization - call mct_aVect_init(avtmp,rList='f1:f2',lsize=lsize) - call mct_aVect_zero(avtmp) - cnt = 0 - do iunit = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avtmp%rAttr(1,cnt) = TUnit%ID0(iunit) - avtmp%rAttr(2,cnt) = TUnit%dnID(iunit) - enddo - call mct_avect_gather(avtmp,avtmpG,gsmap_r,mastertask,mpicom_rof) - if (masterproc) then - cnt = 0 - do n = 1,rtmlon*rtmlat - if (avtmpG%rAttr(2,n) > 0) then - cnt = cnt + 1 - endif - enddo - - call mct_sMat_init(sMat, gsize, gsize, cnt) - igrow = mct_sMat_indexIA(sMat,'grow') - igcol = mct_sMat_indexIA(sMat,'gcol') - iwgt = mct_sMat_indexRA(sMat,'weight') - - cnt = 0 - do n = 1,rtmlon*rtmlat - if (avtmpG%rAttr(2,n) > 0) then - cnt = cnt + 1 - sMat%data%rAttr(iwgt ,cnt) = 1.0_r8 - sMat%data%iAttr(igrow,cnt) = avtmpG%rAttr(2,n) - sMat%data%iAttr(igcol,cnt) = avtmpG%rAttr(1,n) - endif - enddo - call mct_avect_clean(avtmpG) - else - call mct_sMat_init(sMat,1,1,1) - endif - call mct_avect_clean(avtmp) - - call mct_sMatP_Init(sMatP_eroutUp, sMat, gsMap_r, gsMap_r, smat_option, 0, mpicom_rof, ROFID) - - else - - write(iulog,*) trim(subname),' MOSART ERROR: invalid smat_option '//trim(smat_option) - call shr_sys_abort(trim(subname)//' ERROR invald smat option') - - endif - - ! initialize the AVs to go with sMatP - write(rList,'(a,i3.3)') 'tr',1 - do nt = 2,nt_rtm - write(rList,'(a,i3.3)') trim(rList)//':tr',nt - enddo - if ( masterproc ) write(iulog,*) trim(subname),' MOSART initialize avect ',trim(rList) - call mct_aVect_init(avsrc_eroutUp,rList=rList,lsize=rtmCTL%lnumr) - call mct_aVect_init(avdst_eroutUp,rList=rList,lsize=rtmCTL%lnumr) - - lsize = mct_smat_gNumEl(sMatP_eroutUp%Matrix,mpicom_rof) - if (masterproc) write(iulog,*) subname," Done initializing SmatP_eroutUp, nElements = ",lsize - - ! keep only sMatP - call mct_sMat_clean(sMat) - - end if ! endr >= begr - - !--- compute areatot from area using dnID --- - !--- this basically advects upstream areas downstream and - !--- adds them up as it goes until all upstream areas are accounted for - - allocate(Tunit%areatotal2(rtmCTL%begr:rtmCTL%endr)) - Tunit%areatotal2 = 0._r8 - - ! initialize avdst to local area and add that to areatotal2 - cnt = 0 - call mct_avect_zero(avdst_eroutUp) - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avdst_eroutUp%rAttr(1,cnt) = rtmCTL%area(nr) - Tunit%areatotal2(nr) = avdst_eroutUp%rAttr(1,cnt) - enddo - - tcnt = 0 - areatot_prev = -99._r8 - areatot_new = -50._r8 - do while (areatot_new /= areatot_prev .and. tcnt < rtmlon*rtmlat) - - tcnt = tcnt + 1 - - ! copy avdst to avsrc for next downstream step - cnt = 0 - call mct_avect_zero(avsrc_eroutUp) - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - avsrc_eroutUp%rAttr(1,cnt) = avdst_eroutUp%rAttr(1,cnt) - enddo - - call mct_avect_zero(avdst_eroutUp) - - call mct_sMat_avMult(avsrc_eroutUp, sMatP_eroutUp, avdst_eroutUp) - - ! add avdst to areatot and compute new global sum - cnt = 0 - areatot_prev = areatot_new - areatot_tmp = 0._r8 - do nr = rtmCTL%begr,rtmCTL%endr - cnt = cnt + 1 - Tunit%areatotal2(nr) = Tunit%areatotal2(nr) + avdst_eroutUp%rAttr(1,cnt) - areatot_tmp = areatot_tmp + Tunit%areatotal2(nr) - enddo - call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) - - if (masterproc) then - write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new - endif - - enddo - - if (areatot_new /= areatot_prev) then - write(iulog,*) trim(subname),' MOSART ERROR: areatot incorrect ',areatot_new, areatot_prev - call shr_sys_abort(trim(subname)//' ERROR areatot incorrect') - endif - -! do nr = rtmCTL%begr,rtmCTL%endr -! if (TUnit%areatotal(nr) > 0._r8 .and. Tunit%areatotal2(nr) /= TUnit%areatotal(nr)) then -! write(iulog,'(2a,i12,2e16.4,f16.4)') trim(subname),' areatot diff ',nr,TUnit%areatotal(nr),Tunit%areatota!l2(nr),& -! abs(TUnit%areatotal(nr)-Tunit%areatotal2(nr))/(TUnit%areatotal(nr)) -! endif -! enddo - - - ! control parameters - Tctl%RoutingMethod = 1 - !Tctl%DATAH = rtm_nsteps*get_step_size() - !Tctl%DeltaT = 60._r8 ! - ! if(Tctl%DATAH > 0 .and. Tctl%DATAH < Tctl%DeltaT) then - ! Tctl%DeltaT = Tctl%DATAH - ! end if - Tctl%DLevelH2R = 5 - Tctl%DLevelR = 3 - call SubTimestep ! prepare for numerical computation - - call shr_mpi_max(maxval(Tunit%numDT_r),numDT_r,mpicom_rof,'numDT_r',all=.false.) - call shr_mpi_max(maxval(Tunit%numDT_t),numDT_t,mpicom_rof,'numDT_t',all=.false.) - if (masterproc) then - write(iulog,*) subname,' DLevelH2R = ',Tctl%DlevelH2R - write(iulog,*) subname,' numDT_r = ',minval(Tunit%numDT_r),maxval(Tunit%numDT_r) - write(iulog,*) subname,' numDT_r max = ',numDT_r - write(iulog,*) subname,' numDT_t = ',minval(Tunit%numDT_t),maxval(Tunit%numDT_t) - write(iulog,*) subname,' numDT_t max = ',numDT_t - endif - - !if(masterproc) then - ! fname = '/lustre/liho745/DCLM_model/ccsm_hy/run/clm_MOSART_subw2/run/test.dat' - ! call createFile(1111,fname) - !end if - - end subroutine MOSART_init - -!---------------------------------------------------------------------------- - - subroutine SubTimestep - ! !DESCRIPTION: predescribe the sub-time-steps for channel routing - implicit none - integer :: iunit !local index - character(len=*),parameter :: subname = '(SubTimestep)' - - allocate(TUnit%numDT_r(rtmCTL%begr:rtmCTL%endr),TUnit%numDT_t(rtmCTL%begr:rtmCTL%endr)) - TUnit%numDT_r = 1 - TUnit%numDT_t = 1 - allocate(TUnit%phi_r(rtmCTL%begr:rtmCTL%endr),TUnit%phi_t(rtmCTL%begr:rtmCTL%endr)) - TUnit%phi_r = 0._r8 - TUnit%phi_t = 0._r8 - - do iunit=rtmCTL%begr,rtmCTL%endr - if(TUnit%mask(iunit) > 0 .and. TUnit%rlen(iunit) > 0._r8) then - TUnit%phi_r(iunit) = TUnit%areaTotal2(iunit)*sqrt(TUnit%rslp(iunit))/(TUnit%rlen(iunit)*TUnit%rwidth(iunit)) - if(TUnit%phi_r(iunit) >= 10._r8) then - TUnit%numDT_r(iunit) = (TUnit%numDT_r(iunit)*log10(TUnit%phi_r(iunit))*Tctl%DLevelR) + 1 - else - TUnit%numDT_r(iunit) = TUnit%numDT_r(iunit)*1.0_r8*Tctl%DLevelR + 1 - end if - end if - if(TUnit%numDT_r(iunit) < 1) TUnit%numDT_r(iunit) = 1 - - if(TUnit%tlen(iunit) > 0._r8) then - TUnit%phi_t(iunit) = TUnit%area(iunit)*sqrt(TUnit%tslp(iunit))/(TUnit%tlen(iunit)*TUnit%twidth(iunit)) - if(TUnit%phi_t(iunit) >= 10._r8) then - TUnit%numDT_t(iunit) = (TUnit%numDT_t(iunit)*log10(TUnit%phi_t(iunit))*Tctl%DLevelR) + 1 - else - TUnit%numDT_t(iunit) = (TUnit%numDT_t(iunit)*1.0*Tctl%DLevelR) + 1 - end if - end if - if(TUnit%numDT_t(iunit) < 1) TUnit%numDT_t(iunit) = 1 - end do - end subroutine SubTimestep - -!----------------------------------------------------------------------- - -end module RtmMod - diff --git a/src/riverroute/RtmRestFile.F90 b/src/riverroute/RtmRestFile.F90 deleted file mode 100644 index 19c593c..0000000 --- a/src/riverroute/RtmRestFile.F90 +++ /dev/null @@ -1,471 +0,0 @@ -module RtmRestFile - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: restFileMod -! -! !DESCRIPTION: -! Reads from or writes to/ the MOSART restart file. -! -! !USES: - use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_sys_mod , only : shr_sys_abort - use RtmSpmd , only : masterproc - use RtmVar , only : rtmlon, rtmlat, iulog, inst_suffix, rpntfil, & - caseid, nsrest, brnch_retain_casename, & - finidat_rtm, nrevsn_rtm, spval, & - nsrContinue, nsrBranch, nsrStartup, & - ctitle, version, username, hostname, conventions, source, & - nt_rtm, nt_rtm, rtm_tracers - use RtmHistFile , only : RtmHistRestart - use RtmFileUtils , only : relavu, getavu, opnfil, getfil - use RtmTimeManager, only : timemgr_restart, get_nstep, get_curr_date, is_last_step - use RunoffMod , only : rtmCTL - use RtmIO - use RtmDateTime -! -! !PUBLIC TYPES: - implicit none - save -! -! !PUBLIC MEMBER FUNCTIONS: - public :: RtmRestFileName - public :: RtmRestFileRead - public :: RtmRestFileWrite - public :: RtmRestGetfile - public :: RtmRestTimeManager - public :: RtmRestart -! -! !PRIVATE MEMBER FUNCTIONS: - private :: restFile_read_pfile - private :: restFile_write_pfile ! Writes restart pointer file - private :: restFile_dimset -! -! !REVISION HISTORY: -! Author: Mariana Vertenstein -! -! !PRIVATE TYPES: None - private - -!----------------------------------------------------------------------- -contains -!----------------------------------------------------------------------- - -!======================================================================= - - subroutine RtmRestFileWrite( file, rdate ) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! Read/write MOSART restart file. - - ! !ARGUMENTS: - implicit none - character(len=*) , intent(in) :: file ! output netcdf restart file - character(len=*) , intent(in) :: rdate ! restart file time stamp for name - - ! !LOCAL VARIABLES: - type(file_desc_t) :: ncid ! netcdf id - integer :: i ! index - logical :: ptrfile ! write out the restart pointer file - !----------------------------------------------------------------------- - - ! Define dimensions and variables - - if (masterproc) then - write(iulog,*) - write(iulog,*)'restFile_open: writing MOSART restart dataset ' - write(iulog,*) - end if - call ncd_pio_createfile(ncid, trim(file)) - call restFile_dimset( ncid ) - call RtmRestart( ncid, flag='define' ) - call RtmHistRestart ( ncid, flag='define', rdate=rdate ) - call timemgr_restart( ncid, flag='define' ) - call ncd_enddef(ncid) - - ! Write restart file variables - call RtmRestart( ncid, flag='write' ) - call RtmHistRestart ( ncid, flag='write' ) - call timemgr_restart( ncid, flag='write' ) - call ncd_pio_closefile(ncid) - - if (masterproc) then - write(iulog,*) 'Successfully wrote local restart file ',trim(file) - write(iulog,'(72a1)') ("-",i=1,60) - write(iulog,*) - end if - - ! Write restart pointer file - call restFile_write_pfile( file ) - - ! Write out diagnostic info - - if (masterproc) then - write(iulog,*) 'Successfully wrote out restart data at nstep = ',get_nstep() - write(iulog,'(72a1)') ("-",i=1,60) - end if - - end subroutine RtmRestFileWrite - -!----------------------------------------------------------------------- - - subroutine RtmRestFileRead( file ) - - ! !DESCRIPTION: - ! Read a MOSART restart file. - ! - ! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: file ! output netcdf restart file - ! - ! !LOCAL VARIABLES: - type(file_desc_t) :: ncid ! netcdf id - integer :: i ! index - !------------------------------------- - - ! Read file - if (masterproc) write(iulog,*) 'Reading restart dataset' - call ncd_pio_openfile (ncid, trim(file), 0) - call RtmRestart( ncid, flag='read' ) - call RtmHistRestart(ncid, flag='read') - call ncd_pio_closefile(ncid) - - ! Write out diagnostic info - if (masterproc) then - write(iulog,'(72a1)') ("-",i=1,60) - write(iulog,*) 'Successfully read restart data for restart run' - write(iulog,*) - end if - - end subroutine RtmRestFileRead - -!----------------------------------------------------------------------- - - subroutine RtmRestTimeManager( file ) - - ! !DESCRIPTION: - ! Read a MOSART restart file. - ! - ! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: file ! output netcdf restart file - ! - ! !LOCAL VARIABLES: - type(file_desc_t) :: ncid ! netcdf id - integer :: i ! index - !------------------------------------- - - ! Read file - if (masterproc) write(iulog,*) 'Reading restart Timemanger' - call ncd_pio_openfile (ncid, trim(file), 0) - call timemgr_restart(ncid, flag='read') - call ncd_pio_closefile(ncid) - - ! Write out diagnostic info - if (masterproc) then - write(iulog,'(72a1)') ("-",i=1,60) - write(iulog,*) 'Successfully read restart data for restart run' - write(iulog,*) - end if - - end subroutine RtmRestTimeManager - -!----------------------------------------------------------------------- - - subroutine RtmRestGetfile( file, path ) - - !--------------------------------------------------- - ! DESCRIPTION: - ! Determine and obtain netcdf restart file - - ! ARGUMENTS: - implicit none - character(len=*), intent(out) :: file ! name of netcdf restart file - character(len=*), intent(out) :: path ! full pathname of netcdf restart file - - ! LOCAL VARIABLES: - integer :: status ! return status - integer :: length ! temporary - character(len=256) :: ftest,ctest ! temporaries - !--------------------------------------------------- - - ! Continue run: - ! Restart file pathname is read restart pointer file - if (nsrest==nsrContinue) then - call restFile_read_pfile( path ) - call getfil( path, file, 0 ) - end if - - ! Branch run: - ! Restart file pathname is obtained from namelist "nrevsn_rtm" - if (nsrest==nsrBranch) then - length = len_trim(nrevsn_rtm) - if (nrevsn_rtm(length-2:length) == '.nc') then - path = trim(nrevsn_rtm) - else - path = trim(nrevsn_rtm) // '.nc' - end if - call getfil( path, file, 0 ) - - ! Check case name consistency (case name must be different - ! for branch run, unless brnch_retain_casename is set) - ctest = 'xx.'//trim(caseid)//'.mosart' - ftest = 'xx.'//trim(file) - status = index(trim(ftest),trim(ctest)) - if (status /= 0 .and. .not.(brnch_retain_casename)) then - write(iulog,*) 'Must change case name on branch run if ',& - 'brnch_retain_casename namelist is not set' - write(iulog,*) 'previous case filename= ',trim(file),& - ' current case = ',trim(caseid), ' ctest = ',trim(ctest), & - ' ftest = ',trim(ftest) - call shr_sys_abort() - end if - end if - - ! Initial run - if (nsrest==nsrStartup) then - call getfil( finidat_rtm, file, 0 ) - end if - - end subroutine RtmRestGetfile - -!----------------------------------------------------------------------- - - subroutine restFile_read_pfile( pnamer ) - - ! !DESCRIPTION: - ! Setup restart file and perform necessary consistency checks - - ! !ARGUMENTS: - implicit none - character(len=*), intent(out) :: pnamer ! full path of restart file - - ! !LOCAL VARIABLES: - integer :: i ! indices - integer :: nio ! restart unit - integer :: status ! substring check status - character(len=256) :: locfn ! Restart pointer file name - !-------------------------------------------------------- - - ! Obtain the restart file from the restart pointer file. - ! For restart runs, the restart pointer file contains the full pathname - ! of the restart file. For branch runs, the namelist variable - ! [nrevsn_rtm] contains the full pathname of the restart file. - ! New history files are always created for branch runs. - - if (masterproc) then - write(iulog,*) 'Reading restart pointer file....' - endif - - nio = getavu() - locfn = './'// trim(rpntfil)//trim(inst_suffix) - call opnfil (locfn, nio, 'f') - read (nio,'(a256)') pnamer - call relavu (nio) - - if (masterproc) then - write(iulog,*) 'Reading restart data.....' - write(iulog,'(72a1)') ("-",i=1,60) - end if - - end subroutine restFile_read_pfile - -!----------------------------------------------------------------------- - - subroutine restFile_write_pfile( fnamer ) - - ! !DESCRIPTION: - ! Open restart pointer file. Write names of current netcdf restart file. - ! - ! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: fnamer - ! - ! !LOCAL VARIABLES: - integer :: m ! index - integer :: nio ! restart pointer file - character(len=256) :: filename ! local file name - - if (masterproc) then - nio = getavu() - filename= './'// trim(rpntfil)//trim(inst_suffix) - call opnfil( filename, nio, 'f' ) - - write(nio,'(a)') fnamer - call relavu( nio ) - write(iulog,*)'Successfully wrote local restart pointer file' - end if - - end subroutine restFile_write_pfile - - -!----------------------------------------------------------------------- - - character(len=256) function RtmRestFileName( rdate ) - - implicit none - character(len=*), intent(in) :: rdate ! input date for restart file name - - RtmRestFileName = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//".r."//trim(rdate)//".nc" - if (masterproc) then - write(iulog,*)'writing restart file ',trim(RtmRestFileName),' for model date = ',rdate - end if - - end function RtmRestFileName - -!------------------------------------------------------------------------ - - subroutine restFile_dimset( ncid ) - - !---------------------------------------------------------------- - ! !DESCRIPTION: - ! Read/Write initial data from/to netCDF instantaneous initial data file - - ! !ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid - - ! !LOCAL VARIABLES: - integer :: dimid ! netCDF dimension id - integer :: ier ! error status - character(len= 8) :: curdate ! current date - character(len= 8) :: curtime ! current time - character(len=256) :: str - character(len=*),parameter :: subname='restFile_dimset' ! subroutine name - !---------------------------------------------------------------- - - ! Define dimensions - - call ncd_defdim(ncid, 'rtmlon' , rtmlon , dimid) - call ncd_defdim(ncid, 'rtmlat' , rtmlat , dimid) - call ncd_defdim(ncid, 'string_length', 64 , dimid) - - ! Define global attributes - - call ncd_putatt(ncid, NCD_GLOBAL, 'Conventions', trim(conventions)) - call getdatetime(curdate, curtime) - str = 'created on ' // curdate // ' ' // curtime - call ncd_putatt(ncid, NCD_GLOBAL, 'history' , trim(str)) - call ncd_putatt(ncid, NCD_GLOBAL, 'username', trim(username)) - call ncd_putatt(ncid, NCD_GLOBAL, 'host' , trim(hostname)) - call ncd_putatt(ncid, NCD_GLOBAL, 'version' , trim(version)) - call ncd_putatt(ncid, NCD_GLOBAL, 'source' , trim(source)) - call ncd_putatt(ncid, NCD_GLOBAL, 'case_title' , trim(ctitle)) - call ncd_putatt(ncid, NCD_GLOBAL, 'case_id' , trim(caseid)) - call ncd_putatt(ncid, NCD_GLOBAL, 'title', & - 'MOSART Restart information, required to continue a simulation' ) - - end subroutine restFile_dimset - -!----------------------------------------------------------------------- - - subroutine RtmRestart(ncid, flag) - - !----------------------------------------------------------------------- - ! DESCRIPTION: - ! Read/write MOSART restart data. - ! - ! ARGUMENTS: - implicit none - type(file_desc_t), intent(inout) :: ncid ! netcdf id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - ! LOCAL VARIABLES: - logical :: readvar ! determine if variable is on initial file - integer :: nt,nv,n ! indices - real(r8) , pointer :: dfld(:) ! temporary array - character(len=32) :: vname,uname - character(len=255) :: lname - !----------------------------------------------------------------------- - - do nv = 1,7 - do nt = 1,nt_rtm - - if (nv == 1) then - vname = 'RTM_VOLR_'//trim(rtm_tracers(nt)) - lname = 'water volume in cell (volr)' - uname = 'm3' - dfld => rtmCTL%volr(:,nt) - elseif (nv == 2) then - vname = 'RTM_RUNOFF_'//trim(rtm_tracers(nt)) - lname = 'runoff (runoff)' - uname = 'm3/s' - dfld => rtmCTL%runoff(:,nt) - elseif (nv == 3) then - vname = 'RTM_DVOLRDT_'//trim(rtm_tracers(nt)) - lname = 'water volume change in cell (dvolrdt)' - uname = 'mm/s' - dfld => rtmCTL%dvolrdt(:,nt) - elseif (nv == 4) then - vname = 'RTM_WH_'//trim(rtm_tracers(nt)) - lname = 'surface water storage at hillslopes in cell' - uname = 'm' - dfld => rtmCTL%wh(:,nt) - elseif (nv == 5) then - vname = 'RTM_WT_'//trim(rtm_tracers(nt)) - lname = 'water storage in tributary channels in cell' - uname = 'm3' - dfld => rtmCTL%wt(:,nt) - elseif (nv == 6) then - vname = 'RTM_WR_'//trim(rtm_tracers(nt)) - lname = 'water storage in main channel in cell' - uname = 'm3' - dfld => rtmCTL%wr(:,nt) - elseif (nv == 7) then - vname = 'RTM_EROUT_'//trim(rtm_tracers(nt)) - lname = 'instataneous flow out of main channel in cell' - uname = 'm3/s' - dfld => rtmCTL%erout(:,nt) - else - write(iulog,*) 'Rtm ERROR: illegal nv value a ',nv - call shr_sys_abort() - endif - - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=trim(vname), & - xtype=ncd_double, dim1name='rtmlon', dim2name='rtmlat', & - long_name=trim(lname), units=trim(uname), fill_value=spval) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=trim(vname), data=dfld, dim1name='allrof', & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (nsrest == nsrContinue) then - call shr_sys_abort() - else - dfld = 0._r8 - end if - end if - end if - - enddo - enddo - - if (flag == 'read') then - do n = rtmCTL%begr,rtmCTL%endr - do nt = 1,nt_rtm - if (abs(rtmCTL%volr(n,nt)) > 1.e30) rtmCTL%volr(n,nt) = 0. - if (abs(rtmCTL%runoff(n,nt)) > 1.e30) rtmCTL%runoff(n,nt) = 0. - if (abs(rtmCTL%dvolrdt(n,nt)) > 1.e30) rtmCTL%dvolrdt(n,nt) = 0. - if (abs(rtmCTL%wh(n,nt)) > 1.e30) rtmCTL%wh(n,nt) = 0. - if (abs(rtmCTL%wt(n,nt)) > 1.e30) rtmCTL%wt(n,nt) = 0. - if (abs(rtmCTL%wr(n,nt)) > 1.e30) rtmCTL%wr(n,nt) = 0. - if (abs(rtmCTL%erout(n,nt)) > 1.e30) rtmCTL%erout(n,nt) = 0. - end do - if (rtmCTL%mask(n) == 1) then - do nt = 1,nt_rtm - rtmCTL%runofflnd(n,nt) = rtmCTL%runoff(n,nt) - rtmCTL%dvolrdtlnd(n,nt)= rtmCTL%dvolrdt(n,nt) - end do - elseif (rtmCTL%mask(n) >= 2) then - do nt = 1,nt_rtm - rtmCTL%runoffocn(n,nt) = rtmCTL%runoff(n,nt) - rtmCTL%dvolrdtocn(n,nt)= rtmCTL%dvolrdt(n,nt) - enddo - endif - enddo - endif - - end subroutine RtmRestart - -end module RtmRestFile diff --git a/src/riverroute/RtmSpmd.F90 b/src/riverroute/RtmSpmd.F90 deleted file mode 100644 index 99a0938..0000000 --- a/src/riverroute/RtmSpmd.F90 +++ /dev/null @@ -1,92 +0,0 @@ - -module RtmSpmd - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: RtmSpmd -! -! !DESCRIPTION: -! RTM SPMD initialization -! -! !REVISION HISTORY: -! Author: Mariana Vertenstein -! -!EOP -!----------------------------------------------------------------------- - implicit none - private - -#include - - save ! This statement won't be needed once all compilers we support are compliant with FORTRAN-2008 - - ! Default settings valid even if there is no spmd - - logical, public :: masterproc ! proc 0 logical for printing msgs - integer, public :: iam ! processor number - integer, public :: npes ! number of processors for rtm - integer, public :: mpicom_rof ! communicator group for rtm - integer, public :: ROFID ! mct compid - integer, public, parameter :: MASTERTASK=0 ! the value of iam which is assigned - ! the masterproc duties - - ! - ! Public methods - ! - public :: RtmSpmdInit ! Initialization - - ! - ! Values from mpif.h that can be used - ! - public :: MPI_INTEGER - public :: MPI_REAL8 - public :: MPI_LOGICAL - public :: MPI_SUM - public :: MPI_MIN - public :: MPI_MAX - public :: MPI_LOR - public :: MPI_STATUS_SIZE - public :: MPI_ANY_SOURCE - public :: MPI_CHARACTER - public :: MPI_COMM_WORLD - public :: MPI_MAX_PROCESSOR_NAME - -contains - -!----------------------------------------------------------------------- - - subroutine RtmSpmdInit(mpicom) - - !----------------------------------------------------------------------- - ! !DESCRIPTION: - ! MPI initialization (number of processes, etc) - ! - ! !ARGUMENTS: - implicit none - integer, intent(in) :: mpicom - ! - ! !LOCAL VARIABLES: - integer :: ier ! return error status - !----------------------------------------------------------------------- - - ! Initialize mpi communicator group - - mpicom_rof = mpicom - - ! Get my processor id - - call mpi_comm_rank(mpicom_rof, iam, ier) - if (iam == MASTERTASK) then - masterproc = .true. - else - masterproc = .false. - end if - - ! Get number of processors - - call mpi_comm_size(mpicom_rof, npes, ier) - - end subroutine RtmSpmdInit - -end module RtmSpmd diff --git a/src/riverroute/RtmTimeManager.F90 b/src/riverroute/RtmTimeManager.F90 deleted file mode 100644 index 66d1a83..0000000 --- a/src/riverroute/RtmTimeManager.F90 +++ /dev/null @@ -1,1091 +0,0 @@ -module RtmTimeManager - - use shr_kind_mod, only: r8 => shr_kind_r8 - use shr_sys_mod , only: shr_sys_abort - use RtmSpmd , only: masterproc, iam, mpicom_rof, MPI_INTEGER, MPI_CHARACTER - use RtmVar , only: isecspday, iulog, nsrest, nsrContinue - use RtmIO - use ESMF - - - implicit none - private - -! Public methods - - public ::& - timemgr_setup, &! setup startup values - timemgr_init, &! time manager initialization - timemgr_restart, &! read/write time manager restart info and restart time manager - advance_timestep, &! increment timestep number - get_clock, &! get the clock from the time-manager - get_step_size, &! return step size in seconds - get_nstep, &! return timestep number - get_curr_date, &! return date components at end of current timestep - get_prev_date, &! return date components at beginning of current timestep - get_start_date, &! return components of the start date - get_ref_date, &! return components of the reference date - get_curr_time, &! return components of elapsed time since reference date at end of current timestep - get_prev_time, &! return components of elapsed time since reference date at beg of current timestep - get_calendar, &! return calendar - is_first_step, &! return true on first step of initial run - is_first_restart_step, &! return true on first step of restart or branch run - is_end_curr_day, &! return true on last timestep in current day - is_end_curr_month, &! return true on last timestep in current month - is_last_step, &! return true on last timestep - is_restart ! return true if this is a restart run - -! Public parameter data - character(len=*), public, parameter :: NO_LEAP_C = 'NO_LEAP' - character(len=*), public, parameter :: GREGORIAN_C = 'GREGORIAN' - - -! Private module data - -! Private data for input - - character(len=ESMF_MAXSTR), save :: calendar = NO_LEAP_C ! Calendar to use in date calculations - integer, parameter :: uninit_int = -999999999 - real(r8), parameter :: uninit_r8 = -999999999.0 - -! Input - integer, save ::& - dtime = uninit_int ! timestep in seconds - -! Input from CESM driver - integer, save ::& - nelapse = uninit_int, &! number of timesteps (or days if negative) to extend a run - start_ymd = uninit_int, &! starting date for run in yearmmdd format - start_tod = 0, &! starting time of day for run in seconds - stop_ymd = uninit_int, &! stopping date for run in yearmmdd format - stop_tod = 0, &! stopping time of day for run in seconds - ref_ymd = uninit_int, &! reference date for time coordinate in yearmmdd format - ref_tod = 0 ! reference time of day for time coordinate in seconds - type(ESMF_Calendar), target, save :: & - tm_cal ! calendar - type(ESMF_Clock), save :: & - tm_clock ! model clock - integer, save ::& ! Data required to restart time manager: - rst_nstep = uninit_int, &! current step number - rst_step_days = uninit_int, &! days component of timestep size - rst_step_sec = uninit_int, &! timestep size seconds - rst_start_ymd = uninit_int, &! start date - rst_start_tod = uninit_int, &! start time of day - rst_ref_ymd = uninit_int, &! reference date - rst_ref_tod = uninit_int, &! reference time of day - rst_curr_ymd = uninit_int, &! current date - rst_curr_tod = uninit_int ! current time of day - character(len=ESMF_MAXSTR), save :: & - rst_calendar ! Calendar - - logical, save :: tm_first_restart_step = .false. ! true for first step of a restart or branch run - integer, save :: cal_type = uninit_int ! calendar type - logical, save :: timemgr_set = .false. ! true when timemgr initialized - -! Private module methods - private :: timemgr_spmdbcast - private :: init_calendar - private :: init_clock - private :: timemgr_print - private :: TimeGetymd - -contains - -!========================================================================================= - -subroutine timemgr_setup( calendar_in, start_ymd_in, start_tod_in, ref_ymd_in, & - ref_tod_in, stop_ymd_in, stop_tod_in, nelapse_in) - - ! set time manager startup values - character(len=*), optional, intent(IN) :: calendar_in ! Calendar type - integer , optional, intent(IN) :: nelapse_in ! Number of step (or days) to advance - integer , optional, intent(IN) :: start_ymd_in ! Start date (YYYYMMDD) - integer , optional, intent(IN) :: start_tod_in ! Start time of day (sec) - integer , optional, intent(IN) :: ref_ymd_in ! Reference date (YYYYMMDD) - integer , optional, intent(IN) :: ref_tod_in ! Reference time of day (sec) - integer , optional, intent(IN) :: stop_ymd_in ! Stop date (YYYYMMDD) - integer , optional, intent(IN) :: stop_tod_in ! Stop time of day (sec) - character(len=*), parameter :: sub = 'rtm::set_timemgr_init' - - ! timemgr_set is called in timemgr_init and timemgr_restart - if ( timemgr_set ) then - call shr_sys_abort( sub//":: timemgr_init or timemgr_restart already called" ) - end if - if (present(calendar_in) ) calendar = trim(calendar_in) - if (present(start_ymd_in)) start_ymd = start_ymd_in - if (present(start_tod_in)) start_tod = start_tod_in - if (present(ref_ymd_in) ) ref_ymd = ref_ymd_in - if (present(ref_tod_in) ) ref_tod = ref_tod_in - if (present(stop_ymd_in) ) stop_ymd = stop_ymd_in - if (present(stop_tod_in) ) stop_tod = stop_tod_in - if (present(nelapse_in) ) nelapse = nelapse_in - -end subroutine timemgr_setup - -!========================================================================================= - -subroutine timemgr_init( dtime_in ) - - ! Initialize the ESMF time manager from the sync clock - ! - integer, intent(in) :: dtime_in ! Time-step (sec) - ! - integer :: rc ! return code - integer :: yr, mon, day, tod ! Year, month, day, and second as integers - type(ESMF_Time) :: start_date ! start date for run - type(ESMF_Time) :: stop_date ! stop date for run - type(ESMF_Time) :: curr_date ! temporary date used in logic - type(ESMF_Time) :: ref_date ! reference date for time coordinate - type(ESMF_Time) :: current ! current date (from clock) - type(ESMF_TimeInterval) :: day_step_size ! day step size - type(ESMF_TimeInterval) :: step_size ! timestep size - logical :: run_length_specified = .false. - character(len=*), parameter :: sub = 'rtm::timemgr_init' - - ! - dtime = real(dtime_in) - call timemgr_spmdbcast( ) - - ! Initalize calendar - call init_calendar() - - ! Initalize start date. - if ( start_ymd == uninit_int ) then - write(iulog,*)sub,': start_ymd must be specified ' - call shr_sys_abort - end if - if ( start_tod == uninit_int ) then - write(iulog,*)sub,': start_tod must be specified ' - call shr_sys_abort - end if - start_date = TimeSetymd( start_ymd, start_tod, "start_date" ) - - ! Initialize current date - curr_date = start_date - - ! Initalize stop date. - stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) - - call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') - - call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') - - if ( stop_ymd /= uninit_int ) then - current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - end if - if ( nelapse /= uninit_int ) then - if ( nelapse >= 0 ) then - current = curr_date + step_size*nelapse - else - current = curr_date - day_step_size*nelapse - end if - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - end if - if ( .not. run_length_specified ) then - call shr_sys_abort (sub//': Must specify stop_ymd or nelapse') - end if - - ! Error check - if ( stop_date <= start_date ) then - write(iulog,*)sub, ': stop date must be specified later than start date: ' - call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - if ( curr_date >= stop_date ) then - write(iulog,*)sub, ': stop date must be specified later than current date: ' - call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - - ! Initalize reference date for time coordinate. - if ( ref_ymd /= uninit_int ) then - ref_date = TimeSetymd( ref_ymd, ref_tod, "ref_date" ) - else - ref_date = start_date - end if - - ! Initialize clock - call init_clock( start_date, ref_date, curr_date, stop_date ) - - ! Print configuration summary to log file (stdout). - if (masterproc) call timemgr_print() - - timemgr_set = .true. - -end subroutine timemgr_init - -!========================================================================================= - -subroutine init_clock( start_date, ref_date, curr_date, stop_date ) - - ! Initialize the clock based on the start_date, ref_date, and curr_date - ! as well as the settings from the namelist specifying the time to stop - ! - type(ESMF_Time), intent(in) :: start_date ! start date for run - type(ESMF_Time), intent(in) :: ref_date ! reference date for time coordinate - type(ESMF_Time), intent(in) :: curr_date ! current date (equal to start_date) - type(ESMF_Time), intent(in) :: stop_date ! stop date for run - ! - character(len=*), parameter :: sub = 'rtm::init_clock' - type(ESMF_TimeInterval) :: step_size ! timestep size - type(ESMF_Time) :: current ! current date (from clock) - integer :: yr, mon, day, tod ! Year, month, day, and second as integers - integer :: rc ! return code - ! - call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') - - ! Initialize the clock - - tm_clock = ESMF_ClockCreate(name="RTM Time-manager clock", timeStep=step_size, startTime=start_date, & - stopTime=stop_date, refTime=ref_date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockSetup') - - ! Advance clock to the current time (in case of a restart) - - call ESMF_ClockGet(tm_clock, currTime=current, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - do while( curr_date > current ) - call ESMF_ClockAdvance( tm_clock, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockAdvance') - call ESMF_ClockGet(tm_clock, currTime=current ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - end do -end subroutine init_clock - -!========================================================================================= - -function TimeSetymd( ymd, tod, desc ) - - - ! Set the time by an integer as YYYYMMDD and integer seconds in the day - ! - integer, intent(in) :: ymd ! Year, month, day YYYYMMDD - integer, intent(in) :: tod ! Time of day in seconds - character(len=*), intent(in) :: desc ! Description of time to set - ! - type(ESMF_Time) :: TimeSetymd ! Return value - ! - character(len=*), parameter :: sub = 'rtm::TimeSetymd' - integer :: yr, mon, day ! Year, month, day as integers - integer :: rc ! return code - ! - if ( (ymd < 0) .or. (tod < 0) .or. (tod > isecspday) )then - write(iulog,*) sub//': error yymmdd is a negative number or time-of-day out of bounds', & - ymd, tod - call shr_sys_abort - end if - yr = ymd / 10000 - mon = (ymd - yr*10000) / 100 - day = ymd - yr*10000 - mon*100 - call ESMF_TimeSet( TimeSetymd, yy=yr, mm=mon, dd=day, s=tod, & - calendar=tm_cal, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeSet: setting '//trim(desc)) -end function TimeSetymd - -!========================================================================================= - -integer function TimeGetymd( date, tod ) - - ! Get the date and time of day in ymd from ESMF Time. - ! - type(ESMF_Time), intent(inout) :: date ! Input date to convert to ymd - integer, intent(out), optional :: tod ! Time of day in seconds - ! - character(len=*), parameter :: sub = 'rtm::TimeGetymd' - integer :: yr, mon, day - integer :: rc ! return code - ! - call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - TimeGetymd = yr*10000 + mon*100 + day - if ( present( tod ) )then - call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - end if - if ( yr < 0 )then - write(iulog,*) sub//': error year is less than zero', yr - call shr_sys_abort - end if -end function TimeGetymd - -!========================================================================================= - -subroutine timemgr_restart(ncid, flag) - - ! Read/Write information needed on restart to a netcdf file. - ! - type(file_desc_t), intent(inout) :: ncid ! netcdf id - character(len=*) , intent(in) :: flag ! 'read' or 'write' - ! - logical :: run_length_specified = .false. - integer :: rc ! return code - integer :: yr, mon, day, tod ! Year, month, day, and second as integers - logical :: readvar ! determine if variable is on initial file - integer :: rst_caltype ! calendar type - type(ESMF_Time) :: start_date ! start date for run - type(ESMF_Time) :: stop_date ! stop date for run - type(ESMF_Time) :: ref_date ! reference date for run - type(ESMF_Time) :: curr_date ! date of data in restart file - type(ESMF_Time) :: current ! current date (from clock) - type(ESMF_TimeInterval) :: day_step_size ! day step size - type(ESMF_TimeInterval) :: step_size ! timestep size - integer, parameter :: noleap = 1 - integer, parameter :: gregorian = 2 - character(len=135) :: varname - character(len=len(calendar)) :: cal - character(len=*), parameter :: sub = 'timemgr_restart' - ! - if (flag == 'write') then - rst_calendar = calendar - else if (flag == 'read') then - calendar = rst_calendar - end if - varname = 'timemgr_rst_type' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='calendar type', units='unitless', flag_meanings=(/ "NO_LEAP_C", "GREGORIAN" /), & - flag_values=(/ noleap, gregorian /), ifill_value=uninit_int ) - else if (flag == 'read' .or. flag == 'write') then - if (flag== 'write') then - cal = to_upper(calendar) - if ( trim(cal) == NO_LEAP_C ) then - rst_caltype = noleap - else if ( trim(cal) == GREGORIAN_C ) then - rst_caltype = gregorian - else - call shr_sys_abort(sub//'ERROR: unrecognized calendar specified= '//trim(calendar)) - end if - end if - call ncd_io(varname=varname, data=rst_caltype, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if (flag == 'read') then - if ( rst_caltype == noleap ) then - calendar = NO_LEAP_C - else if ( rst_caltype == gregorian ) then - calendar = GREGORIAN_C - else - write(iulog,*)sub,': unrecognized calendar type in restart file: ',rst_caltype - call shr_sys_abort( sub//'ERROR: bad calendar type in restart file') - end if - end if - end if - - if (flag == 'write') then - call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, refTime=ref_date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - rst_step_sec = dtime - rst_start_ymd = TimeGetymd( start_date, tod=rst_start_tod ) - rst_ref_ymd = TimeGetymd( ref_date, tod=rst_ref_tod ) - rst_curr_ymd = TimeGetymd( curr_date, tod=rst_curr_tod ) - end if - - varname = 'timemgr_rst_step_sec' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='seconds component of timestep size', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_step_sec, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_step_sec < 0 .or. rst_step_sec > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - varname = 'timemgr_rst_start_ymd' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='start date', units='YYYYMMDD', ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_start_ymd, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - end if - - varname = 'timemgr_rst_start_tod' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='start time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_start_tod, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - varname = 'timemgr_rst_ref_ymd' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='reference date', units='YYYYMMDD', ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_ref_ymd, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - end if - - varname = 'timemgr_rst_ref_tod' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='reference time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_ref_tod, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - varname = 'timemgr_rst_curr_ymd' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='current date', units='YYYYMMDD', ifill_value=uninit_int) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_curr_ymd, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - end if - - varname = 'timemgr_rst_curr_tod' - if (flag == 'define') then - call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & - long_name='current time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int ) - else if (flag == 'read' .or. flag == 'write') then - call ncd_io(varname=varname, data=rst_curr_tod, & - ncid=ncid, flag=flag, readvar=readvar) - if (flag=='read' .and. .not. readvar) then - if (is_restart()) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') - end if - end if - if ( rst_curr_tod < 0 .or. rst_curr_tod > isecspday ) then - call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') - end if - end if - - - if (flag == 'read') then - - ! Restart the ESMF time manager using the synclock for ending date. - call timemgr_spmdbcast( ) - - ! Initialize calendar from restart info - call init_calendar() - - ! Initialize the timestep from restart info - dtime = rst_step_sec - - ! Initialize start date from restart info - start_date = TimeSetymd( rst_start_ymd, rst_start_tod, "start_date" ) - - ! Initialize current date from restart info - curr_date = TimeSetymd( rst_curr_ymd, rst_curr_tod, "curr_date" ) - - ! Initialize stop date from sync clock or namelist input - stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) - - call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') - - call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') - - if ( stop_ymd /= uninit_int ) then - current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - else if ( nelapse /= uninit_int ) then - if ( nelapse >= 0 ) then - current = curr_date + step_size*nelapse - else - current = curr_date - day_step_size*nelapse - end if - if ( current < stop_date ) stop_date = current - run_length_specified = .true. - end if - if ( .not. run_length_specified ) then - call shr_sys_abort (sub//': Must specify stop_ymd or nelapse') - end if - - ! Error check - if ( stop_date <= start_date ) then - write(iulog,*)sub, ': stop date must be specified later than start date: ' - call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - if ( curr_date >= stop_date ) then - write(iulog,*)sub, ': stop date must be specified later than current date: ' - call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod - call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) - write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod - call shr_sys_abort - end if - - ! Initialize ref date from restart info - ref_date = TimeSetymd( rst_ref_ymd, rst_ref_tod, "ref_date" ) - - ! Initialize clock - call init_clock( start_date, ref_date, curr_date, stop_date ) - - ! Set flag that this is the first timestep of the restart run. - tm_first_restart_step = .true. - - ! Print configuration summary to log file (stdout). - if (masterproc) call timemgr_print() - - timemgr_set = .true. - - end if - -end subroutine timemgr_restart - -!========================================================================================= - -subroutine init_calendar( ) - - !--------------------------------------------------------------------------------- - ! Initialize calendar - ! - ! Local variables - ! - character(len=*), parameter :: sub = 'rtm::init_calendar' - type(ESMF_CalKind_Flag) :: cal_type ! calendar type - character(len=len(calendar)) :: caltmp - integer :: rc ! return code - !--------------------------------------------------------------------------------- - - caltmp = to_upper(calendar) - if ( trim(caltmp) == NO_LEAP_C ) then - cal_type = ESMF_CALKIND_NOLEAP - else if ( trim(caltmp) == GREGORIAN_C ) then - cal_type = ESMF_CALKIND_GREGORIAN - else - write(iulog,*)sub,': unrecognized calendar specified: ',calendar - call shr_sys_abort - end if - tm_cal = ESMF_CalendarCreate( name=caltmp, calkindflag=cal_type, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_CalendarSet') - -end subroutine init_calendar - -!========================================================================================= - -subroutine timemgr_print() - - !--------------------------------------------------------------------------------- - character(len=*), parameter :: sub = 'rtm::timemgr_print' - integer :: rc - integer :: yr, mon, day - integer :: & ! Data required to restart time manager: - nstep = uninit_int, &! current step number - step_sec = uninit_int, &! timestep size seconds - start_yr = uninit_int, &! start year - start_mon = uninit_int, &! start month - start_day = uninit_int, &! start day of month - start_tod = uninit_int, &! start time of day - stop_yr = uninit_int, &! stop year - stop_mon = uninit_int, &! stop month - stop_day = uninit_int, &! stop day of month - stop_tod = uninit_int, &! stop time of day - ref_yr = uninit_int, &! reference year - ref_mon = uninit_int, &! reference month - ref_day = uninit_int, &! reference day of month - ref_tod = uninit_int, &! reference time of day - curr_yr = uninit_int, &! current year - curr_mon = uninit_int, &! current month - curr_day = uninit_int, &! current day of month - curr_tod = uninit_int ! current time of day - integer(ESMF_KIND_I8) :: step_no - type(ESMF_Time) :: start_date! start date for run - type(ESMF_Time) :: stop_date ! stop date for run - type(ESMF_Time) :: curr_date ! date of data in restart file - type(ESMF_Time) :: ref_date ! reference date - type(ESMF_TimeInterval) :: step ! Time-step - !--------------------------------------------------------------------------------- - - call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, & - refTime=ref_date, stopTime=stop_date, timeStep=step, & - advanceCount=step_no, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - nstep = step_no - - write(iulog,*)' ******** RTM Time Manager Configuration ********' - - call ESMF_TimeIntervalGet( step, s=step_sec, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') - - call ESMF_TimeGet( start_date, yy=start_yr, mm=start_mon, dd=start_day, & - s=start_tod, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( stop_date, yy=stop_yr, mm=stop_mon, dd=stop_day, & - s=stop_tod, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( ref_date, yy=ref_yr, mm=ref_mon, dd=ref_day, s=ref_tod, & - rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - call ESMF_TimeGet( curr_date, yy=curr_yr, mm=curr_mon, dd=curr_day, & - s=curr_tod, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - - write(iulog,*)' Calendar type: ',trim(calendar) - write(iulog,*)' Timestep size (seconds): ', step_sec - write(iulog,*)' Start date (yr mon day tod): ', start_yr, start_mon, & - start_day, start_tod - write(iulog,*)' Stop date (yr mon day tod): ', stop_yr, stop_mon, & - stop_day, stop_tod - write(iulog,*)' Reference date (yr mon day tod): ', ref_yr, ref_mon, & - ref_day, ref_tod - write(iulog,*)' Current step number: ', nstep - write(iulog,*)' Current date (yr mon day tod): ', curr_yr, curr_mon, & - curr_day, curr_tod - - write(iulog,*)' ************************************************' - -end subroutine timemgr_print - -!========================================================================================= - -subroutine advance_timestep() - - ! Increment the timestep number. - - character(len=*), parameter :: sub = 'rtm::advance_timestep' - integer :: rc - - call ESMF_ClockAdvance( tm_clock, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockAdvance') - - tm_first_restart_step = .false. - -end subroutine advance_timestep - -!========================================================================================= - -subroutine get_clock( clock ) - - ! Return the ESMF clock - - type(ESMF_Clock), intent(inout) :: clock - - character(len=*), parameter :: sub = 'rtm::get_clock' - type(ESMF_TimeInterval) :: step_size - type(ESMF_Time) :: start_date, stop_date, ref_date - integer :: rc - - call ESMF_ClockGet( tm_clock, timeStep=step_size, startTime=start_date, & - stoptime=stop_date, reftime=ref_date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - call ESMF_ClockSet(clock, timeStep=step_size, startTime=start_date, & - stoptime=stop_date, reftime=ref_date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockSet') - -end subroutine get_clock - -!========================================================================================= - -integer function get_step_size() - - ! Return the step size in seconds. - - character(len=*), parameter :: sub = 'rtm::get_step_size' - type(ESMF_TimeInterval) :: step_size ! timestep size - integer :: rc - - call ESMF_ClockGet(tm_clock, timeStep=step_size, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - call ESMF_TimeIntervalGet(step_size, s=get_step_size, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockTimeIntervalGet') - -end function get_step_size - -!========================================================================================= - -integer function get_nstep() - - ! Return the timestep number. - - character(len=*), parameter :: sub = 'rtm::get_nstep' - integer :: rc - integer(ESMF_KIND_I8) :: step_no - - call ESMF_ClockGet(tm_clock, advanceCount=step_no, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - get_nstep = step_no - -end function get_nstep - -!========================================================================================= - -subroutine get_curr_date(yr, mon, day, tod, offset) - - !----------------------------------------------------------------------------------------- - ! Return date components valid at end of current timestep with an optional - ! offset (positive or negative) in seconds. - - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - - integer, optional, intent(in) :: offset ! Offset from current time in seconds. - ! Positive for future times, negative - ! for previous times. - - character(len=*), parameter :: sub = 'rtm::get_curr_date' - integer :: rc - type(ESMF_Time) :: date - type(ESMF_TimeInterval) :: off - !----------------------------------------------------------------------------------------- - - call ESMF_ClockGet( tm_clock, currTime=date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - if (present(offset)) then - if (offset > 0) then - call ESMF_TimeIntervalSet( off, s=offset, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') - date = date + off - else if (offset < 0) then - call ESMF_TimeIntervalSet( off, s=-offset, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet') - date = date - off - end if - end if - - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - -end subroutine get_curr_date - -!========================================================================================= - -subroutine get_prev_date(yr, mon, day, tod) - -! Return date components valid at beginning of current timestep. - -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - -! Local variables - character(len=*), parameter :: sub = 'rtm::get_prev_date' - integer :: rc - type(ESMF_Time) :: date -!----------------------------------------------------------------------------------------- - - call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - -end subroutine get_prev_date - -!========================================================================================= - -subroutine get_start_date(yr, mon, day, tod) - - ! Return date components valid at beginning of initial run. - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - - character(len=*), parameter :: sub = 'rtm::get_start_date' - integer :: rc - type(ESMF_Time) :: date - - call ESMF_ClockGet(tm_clock, startTime=date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - -end subroutine get_start_date - -!========================================================================================= - -subroutine get_ref_date(yr, mon, day, tod) - -! Return date components of the reference date. - -! Arguments - integer, intent(out) ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - -! Local variables - character(len=*), parameter :: sub = 'rtm::get_ref_date' - integer :: rc - type(ESMF_Time) :: date -!----------------------------------------------------------------------------------------- - - call ESMF_ClockGet(tm_clock, refTime=date, rc=rc) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeGet') - -end subroutine get_ref_date - -!========================================================================================= - -subroutine get_curr_time(days, seconds) - -! Return time components valid at end of current timestep. -! Current time is the time interval between the current date and the reference date. - -! Arguments - integer, intent(out) ::& - days, &! number of whole days in time interval - seconds ! remaining seconds in time interval - -! Local variables - character(len=*), parameter :: sub = 'rtm::get_curr_time' - integer :: rc - type(ESMF_Time) :: cdate, rdate - type(ESMF_TimeInterval) :: diff -!----------------------------------------------------------------------------------------- - - call ESMF_ClockGet( tm_clock, currTime=cdate, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - call ESMF_ClockGet( tm_clock, refTime=rdate, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - - diff = cdate - rdate - - call ESMF_TimeIntervalGet(diff, d=days, s=seconds, rc=rc) - call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') - -end subroutine get_curr_time - -!========================================================================================= - -subroutine get_prev_time(days, seconds) - -! Return time components valid at beg of current timestep. -! prev time is the time interval between the prev date and the reference date. - -! Arguments - integer, intent(out) ::& - days, &! number of whole days in time interval - seconds ! remaining seconds in time interval - -! Local variables - character(len=*), parameter :: sub = 'rtm::get_prev_time' - integer :: rc - type(ESMF_Time) :: date, ref_date - type(ESMF_TimeInterval) :: diff -!----------------------------------------------------------------------------------------- - - call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet for prevTime') - call ESMF_ClockGet(tm_clock, refTime=ref_date, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet for refTime') - diff = date - ref_date - call ESMF_TimeIntervalGet( diff, d=days, s=seconds, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_TimeintervalGet') - -end subroutine get_prev_time - -!========================================================================================= - -function get_calendar() - - ! Return calendar - - character(len=ESMF_MAXSTR) :: get_calendar - - get_calendar = calendar - -end function get_calendar - -!========================================================================================= - -function is_end_curr_day() - - ! Return true if current timestep is last timestep in current day. - logical :: is_end_curr_day - - integer ::& - yr, &! year - mon, &! month - day, &! day of month - tod ! time of day (seconds past 0Z) - - call get_curr_date(yr, mon, day, tod) - is_end_curr_day = (tod == 0) - -end function is_end_curr_day - -!========================================================================================= - -logical function is_end_curr_month() - - ! Return true if current timestep is last timestep in current month. - integer :: yr, mon, day, tod ! time of day (seconds past 0Z) - - call get_curr_date(yr, mon, day, tod) - is_end_curr_month = (day == 1 .and. tod == 0) - -end function is_end_curr_month - -!========================================================================================= - -logical function is_first_step() - - ! Return true on first step of initial run only. - character(len=*), parameter :: sub = 'rtm::is_first_step' - integer :: rc - integer :: nstep - integer(ESMF_KIND_I8) :: step_no - - call ESMF_ClockGet( tm_clock, advanceCount=step_no, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - nstep = step_no - is_first_step = (nstep == 1) - -end function is_first_step - -!========================================================================================= - -logical function is_first_restart_step() - - ! Return true on first step of restart run only. - is_first_restart_step = tm_first_restart_step - -end function is_first_restart_step - -!========================================================================================= - -logical function is_last_step() - - ! Return true on last timestep. - character(len=*), parameter :: sub = 'rtm::is_last_step' - type(ESMF_Time) :: stop_date - type(ESMF_Time) :: curr_date - type(ESMF_TimeInterval) :: time_step - integer :: rc - - call ESMF_ClockGet( tm_clock, stopTime=stop_date, & - currTime=curr_date, TimeStep=time_step, rc=rc ) - call chkrc(rc, sub//': error return from ESMF_ClockGet') - if ( curr_date+time_step > stop_date ) then - is_last_step = .true. - else - is_last_step = .false. - end if - -end function is_last_step - -!========================================================================================= - -subroutine chkrc(rc, mes) - integer, intent(in) :: rc ! return code from time management library - character(len=*), intent(in) :: mes ! error message - if ( rc == ESMF_SUCCESS ) return - write(iulog,*) mes - call shr_sys_abort ('CHKRC') -end subroutine chkrc - -!========================================================================================= - -function to_upper(str) - - ! Convert character string to upper case. Use achar and iachar intrinsics - ! to ensure use of ascii collating sequence. - character(len=*), intent(in) :: str ! String to convert to upper case - character(len=len(str)) :: to_upper - - integer :: i ! Index - integer :: aseq ! ascii collating sequence - character(len=1) :: ctmp ! Character temporary - - do i = 1, len(str) - ctmp = str(i:i) - aseq = iachar(ctmp) - if ( aseq >= 97 .and. aseq <= 122 ) ctmp = achar(aseq - 32) - to_upper(i:i) = ctmp - end do - -end function to_upper - -!========================================================================================= - -logical function is_restart( ) - ! Determine if restart run - if (nsrest == nsrContinue) then - is_restart = .true. - else - is_restart = .false. - end if -end function is_restart - -!========================================================================================= - -subroutine timemgr_spmdbcast( ) - - integer :: ier - - call mpi_bcast (dtime, 1, MPI_INTEGER, 0, mpicom_rof, ier) - -end subroutine timemgr_spmdbcast - -end module RtmTimeManager diff --git a/src/riverroute/RtmVar.F90 b/src/riverroute/RtmVar.F90 deleted file mode 100644 index 744cf01..0000000 --- a/src/riverroute/RtmVar.F90 +++ /dev/null @@ -1,131 +0,0 @@ -module RtmVar - - use shr_kind_mod , only : r8 => shr_kind_r8, CL => SHR_KIND_CL - use shr_const_mod, only : SHR_CONST_CDAY,SHR_CONST_REARTH - use shr_sys_mod , only : shr_sys_abort - use RtmSpmd , only : masterproc - - implicit none - - !TODO - nt_rtm and rtm_tracers need to be removed and set by access to the index array - integer, parameter, public :: nt_rtm = 2 ! number of tracers - character(len=3), parameter, public :: rtm_tracers(nt_rtm) = (/'LIQ','ICE'/) - - ! Constants - integer, parameter, private :: iundef = -9999999 - integer, parameter, private :: rundef = -9999999._r8 - - real(r8), public, parameter :: secspday = SHR_CONST_CDAY ! Seconds per day - integer, public, parameter :: isecspday= secspday ! Integer seconds per day - real(r8), public, parameter :: spval = 1.e36_r8 ! special value for real data - integer , public, parameter :: ispval = -9999 ! special value for int data - real(r8) :: re = SHR_CONST_REARTH*0.001_r8 ! radius of earth (km) - logical , public :: barrier_timers = .false. ! barrier timers - - ! Run control variables - character(len=CL), public :: caseid = ' ' ! case id - character(len=CL), public :: ctitle = ' ' ! case title - integer, public, parameter :: nsrStartup = 0 ! Startup from initial conditions - integer, public, parameter :: nsrContinue = 1 ! Continue from restart files - integer, public, parameter :: nsrBranch = 2 ! Branch from restart files - integer, public :: nsrest = iundef ! Type of run - logical, public :: brnch_retain_casename = .false. ! true => allow case name to remain the same for branch run - ! by default this is not allowed - logical, public :: noland = .false. ! true => no valid land points -- do NOT run - character(len=32) , public :: decomp_option ! decomp option - character(len=32) , public :: bypass_routing_option ! bypass routing model method - character(len=32) , public :: qgwl_runoff_option ! method for handling qgwl runoff - character(len=32) , public :: smat_option ! smatrix multiply option (opt, Xonly, Yonly) - ! opt = XandY in MCT - ! Xonly = Xonly in MCT, should be bfb on different pe counts - ! Yonly = Yonly in MCT - character(len=CL), public :: hostname = ' ' ! Hostname of machine running on - character(len=CL), public :: username = ' ' ! username of user running program - character(len=CL), public :: version = " " ! version of program - character(len=CL), public :: conventions = "CF-1.0" ! dataset conventions - character(len=CL), public :: source = "Model for Scale Adaptive River Transport MOSART1.0" ! description of this source - character(len=CL), public :: model_doi_url ! Web address of the Digital Object Identifier (DOI) for this model version - - ! Unit Numbers - integer, public :: iulog = 6 ! "stdout" log file unit number, default is 6 - - ! Instance control - integer, public :: inst_index - character(len=16), public :: inst_name - character(len=16), public :: inst_suffix - - ! Rtm control variables - character(len=CL), public :: nrevsn_rtm = ' ' ! restart data file name for branch run - character(len=CL), public :: finidat_rtm = ' ' ! initial conditions file name - character(len=CL), public :: frivinp_rtm = ' ' ! MOSART input data file name - logical, public :: ice_runoff = .true. ! true => runoff is split into liquid and ice, - ! otherwise just liquid - ! Rtm grid size - integer :: rtmlon = 1 ! number of mosart longitudes (initialize) - integer :: rtmlat = 1 ! number of mosart latitudes (initialize) - - character(len=CL), public :: rpntfil = 'rpointer.rof' ! file name for local restart pointer file - - logical, private :: RtmVar_isset = .false. - -!================================================================================ -contains -!================================================================================ - - subroutine RtmVarSet( caseid_in, ctitle_in, brnch_retain_casename_in, & - nsrest_in, version_in, hostname_in, username_in, & - model_doi_url_in ) - - !----------------------------------------------------------------------- - ! Set input control variables. - ! - ! !ARGUMENTS: - character(len=CL), optional, intent(IN) :: caseid_in ! case id - character(len=CL), optional, intent(IN) :: ctitle_in ! case title - integer , optional, intent(IN) :: nsrest_in ! 0: initial run. 1: restart: 3: branch - character(len=CL), optional, intent(IN) :: version_in ! model version - character(len=CL), optional, intent(IN) :: hostname_in ! hostname running on - character(len=CL), optional, intent(IN) :: username_in ! username running job - character(len=CL), optional, intent(IN) :: model_doi_url_in ! web address of Digital Object Identifier (DOI) for model version - logical , optional, intent(IN) :: brnch_retain_casename_in ! true => allow case name to - !----------------------------------------------------------------------- - - if ( RtmVar_isset )then - call shr_sys_abort( 'RtmVarSet ERROR:: control variables already set -- EXIT' ) - end if - - if (present(caseid_in)) caseid = caseid_in - if (present(ctitle_in)) ctitle = ctitle_in - if (present(nsrest_in)) nsrest = nsrest_in - if (present(version_in)) version = version_in - if (present(username_in)) username = username_in - if (present(hostname_in)) hostname = hostname_in - if (present(model_doi_url_in)) model_doi_url = model_doi_url_in - if (present(brnch_retain_casename_in)) brnch_retain_casename = brnch_retain_casename_in - - end subroutine RtmVarSet - -!================================================================================ - - subroutine RtmVarInit( ) - if (masterproc) then - if (nsrest == iundef) then - call shr_sys_abort( 'RtmVarInit ERROR:: must set nsrest' ) - end if - if (nsrest == nsrBranch .and. nrevsn_rtm == ' ') then - call shr_sys_abort( 'RtmVarInit ERROR: need to set restart data file name' ) - end if - if (nsrest == nsrStartup ) then - nrevsn_rtm = ' ' - end if - if (nsrest == nsrContinue) then - nrevsn_rtm = 'set by restart pointer file file' - end if - if (nsrest /= nsrStartup .and. nsrest /= nsrContinue .and. nsrest /= nsrBranch ) then - call shr_sys_abort( 'RtmVarInit ERROR: nsrest NOT set to a valid value' ) - end if - endif - RtmVar_isset = .true. - end subroutine RtmVarInit - -end module RtmVar diff --git a/src/riverroute/RunoffMod.F90 b/src/riverroute/RunoffMod.F90 deleted file mode 100644 index 995be6c..0000000 --- a/src/riverroute/RunoffMod.F90 +++ /dev/null @@ -1,368 +0,0 @@ -module RunoffMod - -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: RunoffMod -! -! !DESCRIPTION: -! Module containing utilities for history file and coupler runoff data -! -! !USES: - use shr_kind_mod, only : r8 => shr_kind_r8 - use RtmVar , only : iulog, spval, nt_rtm - use mct_mod - -! !PUBLIC TYPES: - implicit none - private - - type(mct_gsmap),public :: gsmap_r ! gsmap for mosart decomposition - - type(mct_sMatP),public :: sMatP_dnstrm ! sparse matrix plus for downstream advection - type(mct_avect),public :: avsrc_dnstrm ! src avect for SM mult downstream advection - type(mct_avect),public :: avdst_dnstrm ! dst avect for SM mult downstream advection - - type(mct_sMatP),public :: sMatP_direct ! sparse matrix plus for direct to outlet flow - type(mct_avect),public :: avsrc_direct ! src avect for SM mult direct to outlet flow - type(mct_avect),public :: avdst_direct ! dst avect for SM mult direct to outlet flow - - type(mct_sMatP),public :: sMatP_eroutUp ! sparse matrix plus for eroutUp calc - type(mct_avect),public :: avsrc_eroutUp ! src avect for SM mult eroutUp calc - type(mct_avect),public :: avdst_eroutUp ! dst avect for SM mult eroutUp calc - - public :: runoff_flow - type runoff_flow - ! - local initialization - real(r8), pointer :: lonc(:) ! lon of cell - real(r8), pointer :: latc(:) ! lat of cell - real(r8), pointer :: area(:) ! area of cell - integer , pointer :: gindex(:) ! global index consistent with map file - integer , pointer :: dsig(:) ! downstream index, global index - integer , pointer :: outletg(:) ! outlet index, global index - - ! - global - integer , pointer :: mask(:) ! general mask of cell 1=land, 2=ocean, 3=outlet - real(r8), pointer :: rlon(:) ! rtm longitude list, 1d - real(r8), pointer :: rlat(:) ! rtm latitude list, 1d - real(r8) :: totarea ! global area - integer :: numr ! rtm gdc global number of cells - - ! - local - integer :: begr,endr ! local start/stop indices - integer :: lnumr ! local number of cells - - ! - local - real(r8), pointer :: runofflnd(:,:) ! runoff masked for land (m3 H2O/s) - real(r8), pointer :: runoffocn(:,:) ! runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: runofftot(:,:) ! total runoff masked for ocn (m3 H2O/s) - real(r8), pointer :: dvolrdt(:,:) ! RTM change in storage (mm/s) - real(r8), pointer :: dvolrdtlnd(:,:) ! dvolrdt masked for land (mm/s) - real(r8), pointer :: dvolrdtocn(:,:) ! dvolrdt masked for ocn (mm/s) - real(r8), pointer :: volr(:,:) ! RTM storage (m3) - real(r8), pointer :: fthresh(:) ! RTM water flood threshold - - ! - restarts - real(r8), pointer :: wh(:,:) ! MOSART hillslope surface water storage (m) - real(r8), pointer :: wt(:,:) ! MOSART sub-network water storage (m3) - real(r8), pointer :: wr(:,:) ! MOSART main channel water storage (m3) - real(r8), pointer :: erout(:,:) ! MOSART flow out of the main channel, instantaneous (m3/s) - - ! inputs - real(r8), pointer :: qsur(:,:) ! coupler surface forcing [m3/s] - real(r8), pointer :: qsub(:,:) ! coupler subsurface forcing [m3/s] - real(r8), pointer :: qgwl(:,:) ! coupler glacier/wetland/lake forcing [m3/s] - - ! - outputs - real(r8), pointer :: flood(:) ! coupler return flood water sent back to clm [m3/s] - real(r8), pointer :: runoff(:,:) ! coupler return mosart basin derived flow [m3/s] - real(r8), pointer :: direct(:,:) ! coupler return direct flow [m3/s] - - real(r8), pointer :: qirrig(:) ! coupler irrigation [m3/s] - real(r8), pointer :: qirrig_actual(:) ! minimum of irrigation and available main channel storage - - ! - history (currently needed) - real(r8), pointer :: runofflnd_nt1(:) - real(r8), pointer :: runofflnd_nt2(:) - real(r8), pointer :: runoffocn_nt1(:) - real(r8), pointer :: runoffocn_nt2(:) - real(r8), pointer :: runofftot_nt1(:) - real(r8), pointer :: runofftot_nt2(:) - real(r8), pointer :: runoffdir_nt1(:) - real(r8), pointer :: runoffdir_nt2(:) - real(r8), pointer :: dvolrdtlnd_nt1(:) - real(r8), pointer :: dvolrdtlnd_nt2(:) - real(r8), pointer :: dvolrdtocn_nt1(:) - real(r8), pointer :: dvolrdtocn_nt2(:) - real(r8), pointer :: volr_nt1(:) - real(r8), pointer :: volr_nt2(:) - real(r8), pointer :: volr_mch(:) - real(r8), pointer :: qsur_nt1(:) - real(r8), pointer :: qsur_nt2(:) - real(r8), pointer :: qsub_nt1(:) - real(r8), pointer :: qsub_nt2(:) - real(r8), pointer :: qgwl_nt1(:) - real(r8), pointer :: qgwl_nt2(:) - - end type runoff_flow - - - !== Hongyi - ! constrol information - public :: Tcontrol - type Tcontrol - integer :: NUnit ! numer of Grides in the model domain, which is equal to the number of cells, nrows*ncols - integer :: NSTART ! the # of the time step to start the routing. Previous NSTART - 1 steps will be passed over. - integer :: NSTEPS ! number of time steps specified in the modeling - integer :: NWARMUP ! time steps for model warming up - real(r8) :: DATAH ! time step of runoff generation in second provided by the user - integer :: Num_dt ! number of sub-steps within the current step interval, - ! i.e., if the time step of the incoming runoff data is 3-hr, and num_dt is set to 10, - ! then deltaT = 3*3600/10 = 1080 seconds - real(r8) :: DeltaT ! Time step in seconds - integer :: DLevelH2R ! The base number of channel routing sub-time-steps within one hillslope routing step. - ! Usually channel routing requires small time steps than hillslope routing. - integer :: DLevelR ! The number of channel routing sub-time-steps at a higher level within one channel routing step at a lower level. - integer :: Restart ! flag, Restart=1 means starting from the state of last run, =0 means starting from model-inset initial state. - integer :: RoutingMethod ! Flag for routing methods. 1 --> variable storage method from SWAT model; 2 --> Muskingum method? - integer :: RoutingFlag ! Flag for whether including hillslope and sub-network routing. 1--> include routing through hillslope, sub-network and main channel; 0--> main channel routing only. - - character(len=100) :: baseName ! name of the case study, e.g., columbia - character(len=200) :: ctlFile ! the name of the control file - character(len=100) :: ctlPath ! the path of the control file - character(len=200) :: paraFile ! the path of the parameter files - character(len=100) :: paraPath ! the path of the parameter files - character(len=100) :: runoffPath ! the path of the runoff data - character(len=100) :: outPath ! the path of the output file(s) - integer :: numStation ! number of basins to be simulated - character(len=200) :: staListFile ! name of the file containing station list - integer, pointer :: out_ID(:) ! the indices of the outlet subbasins whether the stations are located - character(len=80), pointer :: out_name(:) ! the name of the outlets - character(len=80) :: curOutlet ! the name of the current outlet - end type Tcontrol - - ! --- Topographic and geometric properties, applicable for both grid- and subbasin-based representations - public :: Tspatialunit - type Tspatialunit - ! grid properties - integer , pointer :: mask(:) ! mosart mask of mosart cell, 0=null, 1=land with dnID, 2=outlet - integer , pointer :: ID0(:) - real(r8), pointer :: lat(:) ! latitude of the centroid of the cell - real(r8), pointer :: lon(:) ! longitude of the centroid of the cell - real(r8), pointer :: area(:) ! area of local cell, [m2] - real(r8), pointer :: areaTotal(:) ! total upstream drainage area, [m2] - real(r8), pointer :: areaTotal2(:)! computed total upstream drainage area, [m2] - real(r8), pointer :: rlenTotal(:) ! length of all reaches, [m] - real(r8), pointer :: Gxr(:) ! drainage density within the cell, [1/m] - real(r8), pointer :: frac(:) ! fraction of cell included in the study area, [-] - logical , pointer :: euler_calc(:) ! flag for calculating tracers in euler - - - ! hillslope properties - real(r8), pointer :: nh(:) ! manning's roughness of the hillslope (channel network excluded) - real(r8), pointer :: hslp(:) ! slope of hillslope, [-] - real(r8), pointer :: hslpsqrt(:) ! sqrt of slope of hillslope, [-] - real(r8), pointer :: hlen(:) ! length of hillslope within the cell, [m] - - ! subnetwork channel properties - real(r8), pointer :: tslp(:) ! average slope of tributaries, [-] - real(r8), pointer :: tslpsqrt(:) ! sqrt of average slope of tributaries, [-] - real(r8), pointer :: tlen(:) ! length of all sub-network reach within the cell, [m] - real(r8), pointer :: twidth(:) ! bankfull width of the sub-reach, [m] - real(r8), pointer :: twidth0(:) ! unadjusted twidth - real(r8), pointer :: nt(:) ! manning's roughness of the subnetwork at hillslope - - ! main channel properties - real(r8), pointer :: rlen(:) ! length of main river reach, [m] - real(r8), pointer :: rslp(:) ! slope of main river reach, [-] - real(r8), pointer :: rslpsqrt(:) ! sqrt of slope of main river reach, [-] - real(r8), pointer :: rwidth(:) ! bankfull width of main reach, [m] - real(r8), pointer :: rwidth0(:) ! total width of the flood plain, [m] - real(r8), pointer :: rdepth(:) ! bankfull depth of river cross section, [m] - real(r8), pointer :: nr(:) ! manning's roughness of the main reach - integer , pointer :: dnID(:) ! IDs of the downstream units, corresponding to the subbasin ID in the input table - integer , pointer :: nUp(:) ! number of upstream units, maximum 8 - integer , pointer :: iUp(:,:) ! IDs of upstream units, corresponding to the subbasin ID in the input table - - integer , pointer :: indexDown(:) ! indices of the downstream units in the ID array. sometimes subbasins IDs may not be continuous - - integer , pointer :: numDT_r(:) ! for a main reach, the number of sub-time-steps needed for numerical stability - integer , pointer :: numDT_t(:) ! for a subnetwork reach, the number of sub-time-steps needed for numerical stability - real(r8), pointer :: phi_r(:) ! the indicator used to define numDT_r - real(r8), pointer :: phi_t(:) ! the indicator used to define numDT_t - end type Tspatialunit - - ! status and flux variables - public :: TstatusFlux - type TstatusFlux - ! hillsloope - !! states - real(r8), pointer :: wh(:,:) ! storage of surface water, [m] - real(r8), pointer :: dwh(:,:) ! change of water storage, [m/s] - real(r8), pointer :: yh(:,:) ! depth of surface water, [m] - real(r8), pointer :: wsat(:,:) ! storage of surface water within saturated area at hillslope [m] - real(r8), pointer :: wunsat(:,:) ! storage of surface water within unsaturated area at hillslope [m] - real(r8), pointer :: qhorton(:,:) ! Infiltration excess runoff generated from hillslope, [m/s] - real(r8), pointer :: qdunne(:,:) ! Saturation excess runoff generated from hillslope, [m/s] - real(r8), pointer :: qsur(:,:) ! Surface runoff generated from hillslope, [m/s] - real(r8), pointer :: qsub(:,:) ! Subsurface runoff generated from hillslope, [m/s] - real(r8), pointer :: qgwl(:,:) ! gwl runoff term from glacier, wetlands and lakes, [m/s] - !! fluxes - real(r8), pointer :: ehout(:,:) ! overland flow from hillslope into the sub-channel, [m/s] - real(r8), pointer :: asat(:,:) ! saturated area fraction from hillslope, [-] - real(r8), pointer :: esat(:,:) ! evaporation from saturated area fraction at hillslope, [m/s] - - ! subnetwork channel - !! states - real(r8), pointer :: tarea(:,:) ! area of channel water surface, [m2] - real(r8), pointer :: wt(:,:) ! storage of surface water, [m3] - real(r8), pointer :: dwt(:,:) ! change of water storage, [m3] - real(r8), pointer :: yt(:,:) ! water depth, [m] - real(r8), pointer :: mt(:,:) ! cross section area, [m2] - real(r8), pointer :: rt(:,:) ! hydraulic radii, [m] - real(r8), pointer :: pt(:,:) ! wetness perimeter, [m] - real(r8), pointer :: vt(:,:) ! flow velocity, [m/s] - real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] - !! fluxes - real(r8), pointer :: tevap(:,:) ! evaporation, [m/s] - real(r8), pointer :: etin(:,:) ! lateral inflow from hillslope, including surface and subsurface runoff generation components, [m3/s] - real(r8), pointer :: etout(:,:) ! discharge from sub-network into the main reach, [m3/s] - - ! main channel - !! states - real(r8), pointer :: rarea(:,:) ! area of channel water surface, [m2] - real(r8), pointer :: wr(:,:) ! storage of surface water, [m3] - real(r8), pointer :: dwr(:,:) ! change of water storage, [m3] - real(r8), pointer :: yr(:,:) ! water depth. [m] - real(r8), pointer :: mr(:,:) ! cross section area, [m2] - real(r8), pointer :: rr(:,:) ! hydraulic radius, [m] - real(r8), pointer :: pr(:,:) ! wetness perimeter, [m] - real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] - real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] - !! exchange fluxes - real(r8), pointer :: erlg(:,:) ! evaporation, [m/s] - real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] - real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] - real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] - real(r8), pointer :: erout_prev(:,:) ! outflow into downstream links from previous timestep, [m3/s] - real(r8), pointer :: eroutUp(:,:) ! outflow sum of upstream gridcells, instantaneous (m3/s) - real(r8), pointer :: eroutUp_avg(:,:) ! outflow sum of upstream gridcells, average [m3/s] - real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] - real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] - real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] - real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] - real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] - - !! for Runge-Kutta algorithm - real(r8), pointer :: wrtemp(:,:) ! temporary storage item, for 4th order Runge-Kutta algorithm; - real(r8), pointer :: erintemp(:,:) - real(r8), pointer :: erouttemp(:,:) - real(r8), pointer :: k1(:,:) - real(r8), pointer :: k2(:,:) - real(r8), pointer :: k3(:,:) - real(r8), pointer :: k4(:,:) - end type TstatusFlux - !== Hongyi - - ! parameters to be calibrated. Ideally, these parameters are supposed to be uniform for one region - public :: Tparameter - type Tparameter - real(r8), pointer :: c_nr(:) ! coefficient to adjust the manning's roughness of channels - real(r8), pointer :: c_nh(:) ! coefficient to adjust the manning's roughness of overland flow across hillslopes - real(r8), pointer :: c_twid(:) ! coefficient to adjust the width of sub-reach channel - end type Tparameter - - !== Hongyi - type (Tcontrol) , public :: Tctl - type (Tspatialunit), public :: TUnit - type (TstatusFlux) , public :: TRunoff - type (Tparameter) , public :: TPara - !== Hongyi - - type (runoff_flow) , public :: rtmCTL - - public :: RunoffInit - -contains - - subroutine RunoffInit(begr, endr, numr) - - integer, intent(in) :: begr, endr, numr - - integer :: ier - - allocate(rtmCTL%runoff(begr:endr,nt_rtm), & - rtmCTL%dvolrdt(begr:endr,nt_rtm), & - rtmCTL%runofflnd(begr:endr,nt_rtm), & - rtmCTL%dvolrdtlnd(begr:endr,nt_rtm), & - rtmCTL%runoffocn(begr:endr,nt_rtm), & - rtmCTL%dvolrdtocn(begr:endr,nt_rtm), & - rtmCTL%runofftot(begr:endr,nt_rtm), & - rtmCTL%area(begr:endr), & - rtmCTL%volr(begr:endr,nt_rtm), & - rtmCTL%lonc(begr:endr), & - rtmCTL%latc(begr:endr), & - rtmCTL%dsig(begr:endr), & - rtmCTL%outletg(begr:endr), & - rtmCTL%runofflnd_nt1(begr:endr), & - rtmCTL%runofflnd_nt2(begr:endr), & - rtmCTL%runoffocn_nt1(begr:endr), & - rtmCTL%runoffocn_nt2(begr:endr), & - rtmCTL%runofftot_nt1(begr:endr), & - rtmCTL%runofftot_nt2(begr:endr), & - rtmCTL%runoffdir_nt1(begr:endr), & - rtmCTL%runoffdir_nt2(begr:endr), & - rtmCTL%volr_nt1(begr:endr), & - rtmCTL%volr_nt2(begr:endr), & - rtmCTL%volr_mch(begr:endr), & - rtmCTL%dvolrdtlnd_nt1(begr:endr), & - rtmCTL%dvolrdtlnd_nt2(begr:endr), & - rtmCTL%dvolrdtocn_nt1(begr:endr), & - rtmCTL%dvolrdtocn_nt2(begr:endr), & - rtmCTL%qsur_nt1(begr:endr), & - rtmCTL%qsur_nt2(begr:endr), & - rtmCTL%qsub_nt1(begr:endr), & - rtmCTL%qsub_nt2(begr:endr), & - rtmCTL%qgwl_nt1(begr:endr), & - rtmCTL%qgwl_nt2(begr:endr), & - rtmCTL%mask(begr:endr), & - rtmCTL%gindex(begr:endr), & - rtmCTL%fthresh(begr:endr), & - rtmCTL%flood(begr:endr), & - rtmCTL%direct(begr:endr,nt_rtm), & - rtmCTL%wh(begr:endr,nt_rtm), & - rtmCTL%wt(begr:endr,nt_rtm), & - rtmCTL%wr(begr:endr,nt_rtm), & - rtmCTL%erout(begr:endr,nt_rtm), & - rtmCTL%qsur(begr:endr,nt_rtm), & - rtmCTL%qsub(begr:endr,nt_rtm), & - rtmCTL%qgwl(begr:endr,nt_rtm), & - rtmCTL%qirrig(begr:endr), & - rtmCTL%qirrig_actual(begr:endr), & - stat=ier) - if (ier /= 0) then - write(iulog,*)'Rtmini ERROR allocation of runoff local arrays' - call shr_sys_abort - end if - - rtmCTL%runoff(:,:) = 0._r8 - rtmCTL%runofflnd(:,:) = spval - rtmCTL%runoffocn(:,:) = spval - rtmCTL%runofftot(:,:) = spval - rtmCTL%dvolrdt(:,:) = 0._r8 - rtmCTL%dvolrdtlnd(:,:) = spval - rtmCTL%dvolrdtocn(:,:) = spval - rtmCTL%volr(:,:) = 0._r8 - rtmCTL%flood(:) = 0._r8 - rtmCTL%direct(:,:) = 0._r8 - rtmCTL%qirrig(:) = 0._r8 - rtmCTL%qirrig_actual(:)= 0._r8 - rtmCTL%volr_mch(:) = 0._r8 - - rtmCTL%qsur(:,:) = 0._r8 - rtmCTL%qsub(:,:) = 0._r8 - rtmCTL%qgwl(:,:) = 0._r8 - - end subroutine RunoffInit - -end module RunoffMod diff --git a/src/riverroute/mosart_budget_type.F90 b/src/riverroute/mosart_budget_type.F90 new file mode 100644 index 0000000..3df5c8a --- /dev/null +++ b/src/riverroute/mosart_budget_type.F90 @@ -0,0 +1,267 @@ +module mosart_budget_type + + ! Variables and routines used for + ! calculating and checking tracer global and local budgets + + use shr_kind_mod, only: r8 => shr_kind_r8, CL => SHR_KIND_CL + use shr_sys_mod, only: shr_sys_abort + use shr_mpi_mod, only: shr_mpi_sum, shr_mpi_max + use mosart_vars, only: re, spval, barrier_timers, iulog, mainproc, npes, iam, mpicom_rof + use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara + use mosart_timemanager, only: get_nstep, get_curr_date + + implicit none + private + + type budget_type + ! accumulated budget over run (not used for now) + real(r8), pointer :: accum_grc(:, :) ! Gridcell level budget accumulator per tracer over the run (m3) + real(r8), pointer :: accum_glob(:) ! Global budget accumulator (1e6 m3) + + ! budget terms per gridcell + real(r8), pointer :: beg_vol_grc(:, :) ! volume begining of the timestep (m3) + real(r8), pointer :: end_vol_grc(:, :) ! volume end of the timestep (m3) + real(r8), pointer :: in_grc(:, :) ! budget in terms (m3) + real(r8), pointer :: out_grc(:, :) ! budget out terms (m3) + real(r8), pointer :: net_grc(:, :) ! net budget (dvolume + inputs - outputs) (m3) + real(r8), pointer :: lag_grc(:, :) ! euler erout lagged (m3) + + ! budget global terms + real(r8), pointer :: beg_vol_glob(:) ! volume begining of the timestep (1e6 m3) + real(r8), pointer :: end_vol_glob(:) ! volume end of the timestep (1e6 m3) + real(r8), pointer :: in_glob(:) ! budget in terms (1e6 m3) + real(r8), pointer :: out_glob(:) ! budget out terms (1e6 m3) + real(r8), pointer :: net_glob(:) ! net budget (dvolume + inputs - outputs) (1e6 m3) + real(r8), pointer :: lag_glob(:) ! euler erout lagged (1e6 m3) + + ! budget parameters + real(r8) :: tolerance = 1e-6_r8 ! budget absolute tolerance + real(r8) :: rel_tolerance = 1e-6_r8 ! budget relative tolerance + logical(r8), pointer :: do_budget(:) ! if budget should be checked (per tracer) + contains + procedure, public :: Init + procedure, public :: set_budget + procedure, public :: check_budget + end type budget_type + public :: budget_type + + integer, parameter :: index_beg_vol_grc = 1 + integer, parameter :: index_end_vol_grc = 2 + integer, parameter :: index_in_grc = 3 + integer, parameter :: index_out_grc = 4 + integer, parameter :: index_net_grc = 5 + integer, parameter :: index_lag_grc = 6 + + character(*), parameter :: u_FILE_u = & + __FILE__ + +!----------------------------------------------------------------------- +contains +!----------------------------------------------------------------------- + + subroutine Init(this, begr, endr, ntracers) + + ! Initialize budget type + + ! Arguments + class(budget_type) :: this + integer, intent(in) :: begr, endr, ntracers + !------------------------------------------------- + + ! gridcell level: + allocate (this%accum_grc(begr:endr, ntracers)) + this%accum_grc = 0._r8 + + allocate (this%beg_vol_grc(begr:endr, ntracers)) + this%beg_vol_grc = 0._r8 + + allocate (this%end_vol_grc(begr:endr, ntracers)) + this%end_vol_grc = 0._r8 + + allocate (this%in_grc(begr:endr, ntracers)) + this%in_grc = 0._r8 + + allocate (this%out_grc(begr:endr, ntracers)) + this%out_grc = 0._r8 + + allocate (this%net_grc(begr:endr, ntracers)) + this%net_grc = 0._r8 + + allocate (this%lag_grc(begr:endr, ntracers)) + this%lag_grc = 0._r8 + + ! global level: + allocate (this%accum_glob(ntracers)) + this%accum_glob = 0._r8 + + allocate (this%beg_vol_glob(ntracers)) + this%beg_vol_glob = 0._r8 + + allocate (this%end_vol_glob(ntracers)) + this%end_vol_glob = 0._r8 + + allocate (this%in_glob(ntracers)) + this%in_glob = 0._r8 + + allocate (this%out_glob(ntracers)) + this%out_glob = 0._r8 + + allocate (this%net_glob(ntracers)) + this%net_glob = 0._r8 + + allocate (this%lag_glob(ntracers)) + this%lag_glob = 0._r8 + + allocate (this%do_budget(ntracers)) + this%do_budget = .true. + + end subroutine Init + + !----------------------------------------------------------------------- + + subroutine set_budget(this, begr, endr, ntracers, dt) + + ! Arguments + class(budget_type) :: this + integer, intent(in) :: begr, endr, ntracers + real(r8), intent(in) :: dt + + ! local variables + integer :: nr, nt !indices + integer :: nt_liq, nt_ice + !------------------------------------------------- + + nt_liq = ctl%nt_liq + nt_ice = ctl%nt_ice + do nr = begr, endr + do nt = 1, ntracers + this%beg_vol_grc(nr, nt) = ctl%volr(nr, nt) + if (nt == nt_ice) then + this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt) + ctl%qglc_ice(nr)) * dt + else if (nt == nt_liq) then + this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt) + ctl%qglc_liq(nr)) * dt + end if + ! this was for budget_terms(17) + !if (nt==1) then + ! this%in_grc(nr,nt)=this%in_grc(nr,nt) +ctl%qirrig(nr) + !endif + end do + end do + + this%end_vol_grc(:,:) = 0.0_r8 + this%out_grc(:,:) = 0.0_r8 + this%net_grc(:,:) = 0.0_r8 + this%lag_grc(:,:) = 0.0_r8 + + this%beg_vol_glob(:) = 0.0_r8 + this%end_vol_glob(:) = 0.0_r8 + this%in_glob(:) = 0.0_r8 + this%out_glob(:) = 0.0_r8 + this%net_glob(:) = 0.0_r8 + this%lag_glob(:) = 0.0_r8 + + end subroutine set_budget + + !----------------------------------------------------------------------- + + subroutine check_budget(this, begr, endr, ntracers, dt) + + ! Arguments + class(budget_type) :: this + integer, intent(in) :: begr, endr, ntracers + real(r8), intent(in) :: dt + + ! Local variables + integer :: nr, nt !indecies + integer :: nt_liq ! liquid index + integer :: yr,mon,day,ymd,tod !time vars + real(r8) :: tmp_in(6, ntracers) ! array to pass to mpi_sum + real(r8) :: tmp_glob(6, ntracers) ! array from mpi_sum + logical :: error_budget ! flag for an error + real(r8) :: abserr, relerr + !------------------------------------------------- + + call get_curr_date(yr, mon, day, tod) + ymd = yr*10000 + mon*100 + day + tmp_in = 0.0_r8 + tmp_glob = 0.0_r8 + + nt_liq = ctl%nt_liq + do nr = begr, endr + do nt = 1, ntracers + this%end_vol_grc(nr, nt) = ctl%volr(nr, nt) + this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%direct(nr, nt) + ctl%direct_glc(nr, nt) + if (nt == nt_liq) then + this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%flood(nr) + end if + if (ctl%mask(nr) >= 2) then + this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%runoff(nr, nt) + else + this%lag_grc(nr, nt) = this%lag_grc(nr, nt) - ctl%erout_prev(nr, nt) - ctl%flow(nr, nt) + end if + this%out_grc(nr,nt) = this%out_grc(nr,nt) * dt + this%lag_grc(nr,nt) = this%lag_grc(nr,nt) * dt + this%net_grc(nr,nt) = this%end_vol_grc(nr,nt) - this%beg_vol_grc(nr,nt) - (this%in_grc(nr,nt)-this%out_grc(nr,nt)) + this%accum_grc(nr,nt) = this%accum_grc(nr,nt) + this%net_grc(nr,nt) + end do + end do + + do nt = 1, ntracers + tmp_in(index_beg_vol_grc, nt) = sum(this%beg_vol_grc(:, nt)) + tmp_in(index_end_vol_grc, nt) = sum(this%end_vol_grc(:, nt)) + tmp_in(index_in_grc, nt) = sum(this%in_grc(:, nt)) + tmp_in(index_out_grc, nt) = sum(this%out_grc(:, nt)) + tmp_in(index_net_grc, nt) = sum(this%net_grc(:, nt)) + tmp_in(index_lag_grc, nt) = sum(this%lag_grc(:, nt)) + end do + + tmp_in = tmp_in*1e-6_r8 !convert to million m3 + call shr_mpi_sum(tmp_in, tmp_glob, mpicom_rof, 'mosart global budget', all=.false.) + + do nt = 1, ntracers + error_budget = .false. + abserr = 0.0_r8 + relerr = 0.0_r8 + this%beg_vol_glob(nt) = tmp_glob(index_beg_vol_grc, nt) + this%end_vol_glob(nt) = tmp_glob(index_end_vol_grc, nt) + this%in_glob(nt) = tmp_glob(index_in_grc, nt) + this%out_glob(nt) = tmp_glob(index_out_grc, nt) + this%net_glob(nt) = tmp_glob(index_net_grc, nt) + this%lag_glob(nt) = tmp_glob(index_lag_grc, nt) + if (this%do_budget(nt)) then + if (abs(this%net_glob(nt) - this%lag_glob(nt)*dt) > this%tolerance) then + error_budget = .true. + abserr = abs(this%net_glob(nt) - this%lag_glob(nt)) + end if + if (abs(this%net_glob(nt) + this%lag_glob(nt)) > 1e-6) then + if ( abs(this%net_glob(nt) - this%lag_glob(nt)) & + /abs(this%net_glob(nt) + this%lag_glob(nt)) > this%rel_tolerance) then + error_budget = .true. + relerr = abs(this%net_glob(nt) - this%lag_glob(nt)) /abs(this%net_glob(nt) + this%lag_glob(nt)) + end if + end if + if (mainproc) then + write (iulog, '(a)') '-----------------------------------' + write (iulog, '(a)') '*****MOSART BUDGET DIAGNOSTICS*****' + write (iulog,'(a,i10,i6)') ' diagnostics for ', ymd, tod + write (iulog, '(a,i4,2a)') ' tracer = ', nt, ' ', ctl%tracer_names(nt) + write (iulog, '(a,f22.6,a)') ' time step size = ', dt, ' sec' + write (iulog, '(a,f22.6,a)') ' volume begining of the step = ', this%beg_vol_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' volume end of the step = ', this%end_vol_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' inputs = ', this%in_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' outputs = ', this%out_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' net budget (dv -i + o) = ', this%net_glob(nt), ' (mil m3)' + write (iulog, '(a,f22.6,a)') ' eul erout lag = ', this%lag_glob(nt), '(mil m3)' + write (iulog, '(a,f22.6)') ' absolute budget error = ', abserr + write (iulog, '(a,f22.6)') ' relative budget error = ', relerr + if (error_budget) then + write(iulog,'(a)') ' BUDGET OUT OF BALANCE WARNING ' + endif + write (iulog, '(a)') '-----------------------------------' + end if + end if + end do + + end subroutine check_budget + +end module mosart_budget_type diff --git a/src/riverroute/mosart_control_type.F90 b/src/riverroute/mosart_control_type.F90 new file mode 100644 index 0000000..095d1f1 --- /dev/null +++ b/src/riverroute/mosart_control_type.F90 @@ -0,0 +1,1248 @@ +module mosart_control_type + + use shr_kind_mod, only : r8 => shr_kind_r8, CS => shr_kind_cs + use shr_sys_mod, only : shr_sys_abort + use shr_const_mod, only : shr_const_pi, shr_const_rearth + use shr_string_mod, only : shr_string_listGetNum, shr_string_listGetName + use shr_mpi_mod, only : shr_mpi_sum + use mosart_io, only : ncd_io, ncd_pio_openfile, ncd_pio_closefile + use mosart_vars, only : mainproc, iam, npes, mpicom_rof, iulog, spval, re, vm + use pio, only : file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling + use ESMF, only : ESMF_DistGrid, ESMF_Array, ESMF_RouteHandle, ESMF_SUCCESS, & + ESMF_DistGridCreate, ESMF_ArrayCreate, ESMF_ArrayHaloStore, & + ESMF_ArrayHalo, ESMF_ArrayGet, ESMF_VMAllReduce, ESMF_REDUCE_SUM + use perf_mod, only : t_startf, t_stopf + use nuopc_shr_methods, only : chkerr + + implicit none + private + + type control_type + + ! grid sizes + integer :: lnumr ! local number of cells + integer :: numr ! global number of cells + integer :: nlon = -999 ! number of longitudes + integer :: nlat = -999 ! number of latitudes + + ! tracers + integer :: ntracers = -999 ! number of tracers + character(len=3), allocatable :: tracer_names(:)! tracer names + integer :: nt_liq ! index of liquid tracer in tracer_names + integer :: nt_ice ! index of ice tracer in tracer_names + logical :: rof_from_glc ! if true, will receive liq and ice runoff from glc + + ! decomp info + integer :: begr ! local start index + integer :: endr ! local stop indices + integer , pointer :: gindex(:) => null() ! global index consistent with map file + type(ESMF_DistGrid) :: distgrid ! esmf global index space descriptor + + ! grid + real(r8), pointer :: rlon(:) => null() ! longitude list, 1d + real(r8), pointer :: rlat(:) => null() ! latitude list, 1d + real(r8), pointer :: lonc(:) => null() ! lon of cell + real(r8), pointer :: latc(:) => null() ! lat of cell + integer , pointer :: dsig(:) => null() ! downstream index, global index + integer , pointer :: outletg(:) => null() ! outlet index, global index + real(r8), pointer :: area(:) => null() ! area of cell + integer , pointer :: mask(:) => null() ! general mask of cell 1=land, 2=ocean, 3=outlet + real(r8) :: totarea ! global area + + ! inputs to MOSART + real(r8), pointer :: qsur(:,:) => null() ! surface runoff from coupler [m3/s] (lnd) + real(r8), pointer :: qsub(:,:) => null() ! subsurfacer runoff from coupler [m3/s] (lnd) + real(r8), pointer :: qgwl(:,:) => null() ! glacier/wetland/lake runoff from coupler [m3/s] (lnd) + real(r8), pointer :: qirrig(:) => null() ! irrigation flow from coupler [m3/s] + real(r8), pointer :: qglc_liq(:) => null() ! glacier liquid runoff from coupler [m3/s] (glc) + real(r8), pointer :: qglc_ice(:) => null() ! glacier ice runoff from coupler [m3/s] (glc) + + ! outputs from MOSART + real(r8), pointer :: flood(:) => null() ! flood water to coupler [m3/s] (lnd) + real(r8), pointer :: runoff(:,:) => null() ! runoff (from outlet to reach) to coupler [m3/s] + real(r8), pointer :: direct(:,:) => null() ! direct flow to outlet from land input [m3/s] + real(r8), pointer :: qirrig_actual(:) => null() ! minimum of irrigation and available main channel storage [m3/s] + real(r8), pointer :: direct_glc(:,:) =>null() ! direct flow to outlet from glc input [m3/s] + + ! storage, runoff + real(r8), pointer :: runofflnd(:,:) => null() ! runoff masked for land [m3/s] + real(r8), pointer :: runoffocn(:,:) => null() ! runoff masked for ocn [m3/s] + real(r8), pointer :: runofftot(:,:) => null() ! total runoff masked for ocn [m3/s] + real(r8), pointer :: dvolrdt(:,:) => null() ! change in storage (mm/s) + real(r8), pointer :: dvolrdtlnd(:,:) => null() ! dvolrdt masked for land (mm/s) + real(r8), pointer :: dvolrdtocn(:,:) => null() ! dvolrdt masked for ocn (mm/s) + real(r8), pointer :: volr(:,:) => null() ! storage (m3) + real(r8), pointer :: fthresh(:) => null() ! water flood threshold + + ! flux variables + real(r8), pointer :: flow(:,:) => null() ! stream flow out of gridcell (m3/s) + real(r8), pointer :: evel(:,:) => null() ! effective tracer velocity (m/s) NOT_USED + real(r8), pointer :: erout_prev(:,:) => null() ! erout previous timestep (m3/s) + real(r8), pointer :: eroutup_avg(:,:) => null() ! eroutup average over coupling period (m3/s) + real(r8), pointer :: erlat_avg(:,:) => null() ! erlateral average over coupling period (m3/s) + real(r8), pointer :: effvel(:) => null() ! effective velocity for a tracer NOT_USED + + ! halo operations + type(ESMF_RouteHandle) :: haloHandle + type(ESMF_Array) :: fld_halo_array + type(ESMF_Array) :: lon_halo_array + type(ESMF_Array) :: lat_halo_array + integer , pointer :: halo_arrayptr_index(:,:) => null() ! index into halo_arrayptr that corresponds to a halo point + real(r8), pointer :: fld_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + real(r8), pointer :: lon_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + real(r8), pointer :: lat_halo_arrayptr(:) => null() ! preallocated memory for exclusive region plus halo + + contains + + procedure, public :: Init + procedure, public :: init_tracer_names + procedure, private :: init_decomp + procedure, private :: test_halo + procedure, public :: calc_gradient + + end type control_type + public :: control_type + + private :: init_decomp + public :: calc_gradient + +#ifdef NDEBUG + integer,parameter :: dbug = 0 ! 0 = none, 1=normal, 2=much, 3=max +#else + integer,parameter :: dbug = 3 ! 0 = none, 1=normal, 2=much, 3=max +#endif + + integer, public :: max_num_halo = 8 + ! eight surrounding indices ordered as [N,NE,E,SE,S,SW,W,NW] + integer, public :: halo_n = 1 + integer, public :: halo_ne = 2 + integer, public :: halo_e = 3 + integer, public :: halo_se = 4 + integer, public :: halo_s = 5 + integer, public :: halo_sw = 6 + integer, public :: halo_w = 7 + integer, public :: halo_nw = 8 + + ! The following are set from + + character(*), parameter :: u_FILE_u = & + __FILE__ + +!======================================================================== +contains +!======================================================================== + + subroutine init_tracer_names(this, mosart_tracers) + + ! This sets the indices for liquid and ice runoff. In the future additional tracers + ! will be enabled so this is a starting point. + + ! Arguments + class(control_type) :: this + character(len=CS) :: mosart_tracers ! colon delimited string of tracer names + + ! Local variables + integer :: nt + character(len=*),parameter :: subname = '(mosart_control_type: init_tracer_names)' + !----------------------------------------------------------------------- + + ! Determine number of tracers and array of tracer names + this%ntracers = shr_string_listGetNum(mosart_tracers) + allocate(this%tracer_names(this%ntracers)) + do nt = 1,this%ntracers + call shr_string_listGetName(mosart_tracers, nt, this%tracer_names(nt)) + end do + + ! Set tracers + this%nt_liq = 0 + this%nt_ice = 0 + do nt = 1,this%ntracers + if (trim(this%tracer_names(nt)) == 'LIQ') this%nt_liq = nt + if (trim(this%tracer_names(nt)) == 'ICE') this%nt_ice = nt + enddo + if (this%nt_liq == 0 .or. this%nt_ice == 0) then + write(iulog,*) trim(subname),': ERROR in tracers LIQ ICE ',this%nt_liq,this%nt_ice,this%tracer_names(:) + call shr_sys_abort() + endif + + end subroutine init_tracer_names + + + !======================================================================== + subroutine Init(this, locfn, decomp_option, use_halo_option, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn + character(len=*) , intent(in) :: decomp_option ! decomposition option + logical , intent(in) :: use_halo_option ! create ESMF array and route handle for halos + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + real(r8) :: area_global(this%nlon*this%nlat) ! area + real(r8) :: tempr(this%nlon,this%nlat) ! temporary buffer + real(r8) :: rlats(this%nlat) ! latitude of 1d south grid cell edge (deg) + real(r8) :: rlatn(this%nlat) ! latitude of 1d north grid cell edge (deg) + real(r8) :: rlonw(this%nlon) ! longitude of 1d west grid cell edge (deg) + real(r8) :: rlone(this%nlon) ! longitude of 1d east grid cell edge (deg) + real(r8) :: larea(1) ! tmp local sum of area + real(r8) :: totarea(1) ! tmp total area + real(r8) :: deg2rad ! pi/180 + integer :: g, n, i, j, nr, nt ! iterators + real(r8) :: edgen ! North edge of the direction file + real(r8) :: edgee ! East edge of the direction file + real(r8) :: edges ! South edge of the direction file + real(r8) :: edgew ! West edge of the direction file + real(r8) :: dx ! lon dist. betn grid cells (m) + real(r8) :: dy ! lat dist. betn grid cells (m) + type(file_desc_t) :: ncid ! pio file desc + logical :: found ! flag + integer :: ntracers ! used to simplify code + integer :: ier ! error status + integer :: begr, endr ! used to simplify code + integer :: nlon,nlat + real(r8) :: effvel0 = 10.0_r8 ! default velocity (m/s) + character(len=*),parameter :: subname = '(mosart_control_type: Init)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nlon = this%nlon + nlat = this%nlat + + !--------------------------------------- + ! Read the routing parameters + !--------------------------------------- + + call ncd_pio_openfile (ncid, trim(locfn), 0) + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + + call ncd_io(ncid=ncid, varname='longxy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart longitudes') + if (mainproc) write(iulog,*) 'Read longxy ',minval(tempr),maxval(tempr) + allocate(this%rlon(this%nlon)) + do i=1,nlon + this%rlon(i) = tempr(i,1) + enddo + if (mainproc) write(iulog,*) 'rlon center ',minval(this%rlon),maxval(this%rlon) + + call ncd_io(ncid=ncid, varname='latixy', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart latitudes') + if (mainproc) write(iulog,*) 'Read latixy ',minval(tempr),maxval(tempr) + allocate(this%rlat(this%nlat)) + do j=1,this%nlat + this%rlat(j) = tempr(1,j) + end do + if (mainproc) write(iulog,*) 'rlat center ',minval(this%rlat),maxval(this%rlat) + + call ncd_io(ncid=ncid, varname='area', flag='read', data=tempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart area') + if (mainproc) write(iulog,*) 'Read area ',minval(tempr),maxval(tempr) + do j=1,this%nlat + do i=1,nlon + n = (j-1)*nlon + i + area_global(n) = tempr(i,j) + end do + end do + if (mainproc) write(iulog,*) 'area ',minval(area_global),maxval(area_global) + call ncd_pio_closefile(ncid) + + !------------------------------------------------------- + ! adjust area estimation from DRT algorithm for those outlet grids + ! useful for grid-based representation only + ! need to compute areas where they are not defined in input file + !------------------------------------------------------- + + ! Derive gridbox edges + ! assuming equispaced grid, calculate edges from nlat/nlon + ! w/o assuming a global grid + edgen = maxval(this%rlat) + 0.5*abs(this%rlat(1) - this%rlat(2)) + edges = minval(this%rlat) - 0.5*abs(this%rlat(1) - this%rlat(2)) + edgee = maxval(this%rlon) + 0.5*abs(this%rlon(1) - this%rlon(2)) + edgew = minval(this%rlon) - 0.5*abs(this%rlon(1) - this%rlon(2)) + if (edgen .ne. 90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgen = ', edgen + end if + if (edges .ne. -90._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edges = ', edges + end if + if (edgee .ne. 180._r8)then + if (mainproc ) write(iulog,*) 'Regional grid: edgee = ', edgee + end if + if (edgew .ne.-180._r8)then + if ( mainproc ) write(iulog,*) 'Regional grid: edgew = ', edgew + end if + + ! Set edge latitudes (assumes latitudes are constant for a given longitude) + rlats(:) = edges + rlatn(:) = edgen + do j = 2, nlat + if (this%rlat(2) > this%rlat(1)) then ! South to North grid + rlats(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlatn(j-1) = rlats(j) + else ! North to South grid + rlatn(j) = (this%rlat(j-1) + this%rlat(j)) / 2._r8 + rlats(j-1) = rlatn(j) + end if + end do + + ! Set edge longitudes + rlonw(:) = edgew + rlone(:) = edgee + dx = (edgee - edgew) / nlon + do i = 2, nlon + rlonw(i) = rlonw(i) + (i-1)*dx + rlone(i-1) = rlonw(i) + end do + + ! adjust area estimation from DRT algorithm for those outlet grids + deg2rad = shr_const_pi / 180._r8 + do n=1,nlon*nlat + if (area_global(n) <= 0._r8) then + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + dx = (rlone(i) - rlonw(i)) * deg2rad + dy = sin(rlatn(j)*deg2rad) - sin(rlats(j)*deg2rad) + area_global(n) = abs(1.e6_r8 * dx*dy*re*re) + if (mainproc .and. area_global(n) <= 0) then + write(iulog,*) 'Warning! Zero area for unit ', n, area_global(n),dx,dy,re + end if + end if + end do + + ! --------------------------------------------- + ! Determine decomposition + ! --------------------------------------------- + + ! memory for this%gindex, this%mask and this%dsig is allocated in init_decomp + call t_startf('mosarti_decomp') + call this%init_decomp(locfn, decomp_option, use_halo_option, & + nlon, nlat, this%begr, this%endr, this%lnumr, this%numr, IDkey, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosarti_decomp') + + ! --------------------------------------------- + ! Allocate and initialize remaining variables + ! --------------------------------------------- + + begr = this%begr + endr = this%endr + ntracers = this%ntracers + + allocate(this%area(begr:endr), & + ! + this%volr(begr:endr,ntracers), & + this%dvolrdt(begr:endr,ntracers), & + this%dvolrdtlnd(begr:endr,ntracers), & + this%dvolrdtocn(begr:endr,ntracers), & + ! + this%runoff(begr:endr,ntracers), & + this%runofflnd(begr:endr,ntracers), & + this%runoffocn(begr:endr,ntracers), & + this%runofftot(begr:endr,ntracers), & + ! + this%fthresh(begr:endr), & + this%flood(begr:endr), & + ! + this%direct(begr:endr,ntracers), & + this%qsur(begr:endr,ntracers), & + this%qsub(begr:endr,ntracers), & + this%qgwl(begr:endr,ntracers), & + this%qirrig(begr:endr), & + this%qirrig_actual(begr:endr), & + this%qglc_liq(begr:endr), & + this%qglc_ice(begr:endr), & + ! + this%evel(begr:endr,ntracers), & + this%flow(begr:endr,ntracers), & + this%erout_prev(begr:endr,ntracers), & + this%eroutup_avg(begr:endr,ntracers),& + this%erlat_avg(begr:endr,ntracers), & + ! + this%effvel(ntracers), & + this%direct_glc(begr:endr,2), & + stat=ier) + if (ier /= 0) then + write(iulog,*)'mosarart_control_type allocation error' + call shr_sys_abort + end if + + this%runoff(:,:) = 0._r8 + this%runofflnd(:,:) = spval + this%runoffocn(:,:) = spval + this%runofftot(:,:) = spval + this%dvolrdt(:,:) = 0._r8 + this%dvolrdtlnd(:,:) = spval + this%dvolrdtocn(:,:) = spval + this%volr(:,:) = 0._r8 + this%flood(:) = 0._r8 + this%direct(:,:) = 0._r8 + this%qirrig(:) = 0._r8 + this%qirrig_actual(:) = 0._r8 + this%qsur(:,:) = 0._r8 + this%qsub(:,:) = 0._r8 + this%qgwl(:,:) = 0._r8 + this%qglc_liq(:) = 0._r8 + this%qglc_ice(:) = 0._r8 + this%fthresh(:) = abs(spval) + this%flow(:,:) = 0._r8 + this%erout_prev(:,:) = 0._r8 + this%eroutup_avg(:,:) = 0._r8 + this%erlat_avg(:,:) = 0._r8 + this%direct_glc(:,:) = 0._r8 + + this%effvel(:) = effvel0 ! downstream velocity (m/s) + do nt = 1,ntracers + do nr = begr,endr + this%evel(nr,nt) = this%effvel(nt) + enddo + enddo + + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + this%area(nr) = area_global(n) + enddo + + larea(1) = 0.0_r8 + do nr = begr,endr + larea(1) = larea(1) + this%area(nr) + end do + if (minval(this%mask) < 1) then + write(iulog,*) subname,'ERROR this mask lt 1 ',minval(this%mask),maxval(this%mask) + call shr_sys_abort(subname//' ERROR this mask') + endif + + call ESMF_VMAllReduce(vm, larea, totarea, 1, ESMF_REDUCE_SUM, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + this%totarea = totarea(1) + + if (mainproc) then + write(iulog,*) subname,' earth area ',4.0_r8*shr_const_pi*1.0e6_r8*re*re + write(iulog,*) subname,' mosart area ',this%totarea + end if + + end subroutine Init + + !======================================================================== + subroutine init_decomp(this, locfn, decomp_option, use_halo_option, & + nlon, nlat, begr, endr, lnumr, numr, IDkey, rc) + + ! Arguments + class(control_type) :: this + character(len=*) , intent(in) :: locfn ! local routing filename + character(len=*) , intent(in) :: decomp_option + logical , intent(in) :: use_halo_option + integer , intent(in) :: nlon + integer , intent(in) :: nlat + integer , intent(out) :: begr + integer , intent(out) :: endr + integer , intent(out) :: lnumr + integer , intent(out) :: numr + integer , intent(out) :: IDkey(:) ! translation key from ID to gindex + integer , intent(out) :: rc + + ! Local variables + integer :: n, nr, i, j, g ! indices + integer :: nl,nloops ! used for decomp search + real(r8),allocatable :: rtempr(:,:) ! global temporary buffer - real + integer, allocatable :: gmask(:) ! global mask + integer, allocatable :: glo2loc(:) ! global global->local mapping + integer, allocatable :: dnID_global(:) ! global downstream ID based on ID0 + integer, allocatable :: idxocn(:) ! global downstream ocean outlet cell + integer, allocatable :: nupstrm(:) ! number of upstream cells including own cell + integer, allocatable :: pocn(:) ! pe number assigned to basin + integer :: ID0_global ! global (local) ID index + integer :: nop(0:npes-1) ! number of gridcells on a pe + integer :: nba(0:npes-1) ! number of basins on each pe + integer :: nrs(0:npes-1) ! begr on each pe + integer :: maxgcells_per_pe ! max num of points per pe for decomp + integer :: minbas,maxbas ! used for decomp search + integer :: pid,np,npmin,npmax,npint ! log loop control + integer :: nmos ! number of mosart points + integer :: nout ! number of basin with outlets + integer :: nbas ! number of basin/ocean points + integer :: nrof ! num of active mosart points + integer :: baspe ! pe with min number of mosart cells + logical :: found ! flag + integer :: ier ! error status + type(file_desc_t) :: ncid ! pio file desc + integer :: procid + integer :: im1,ip1 + integer :: jm1,jp1 + integer :: n_sw, n_s, n_se + integer :: n_nw, n_n, n_ne + integer :: n_e, n_w + integer :: num_halo + integer, pointer :: halo_list(:) + integer, pointer :: seqlist(:) + integer, allocatable :: store_halo_index(:) + character(len=*),parameter :: subname = '(mosart_control_type: init_decomp) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !------------------------------------------------------- + ! Read ID and DnID from routing file + !------------------------------------------------------- + + ! RESET dnID indices based on ID0 + ! rename the dnID values to be consistent with global grid indexing. + ! where 1 = lower left of grid and nlon*nlat is upper right. + ! ID0 is the "key", modify dnID based on that. keep the IDkey around + ! for as long as needed. This is a key that translates the ID0 value + ! to the gindex value. compute the key, then apply the key to dnID_global. + ! As part of this, check that each value of ID0 is unique and within + ! the range of 1 to nlon*nlat. + + call ncd_pio_openfile(ncid, trim(locfn), 0) + + allocate(rtempr(nlon,nlat)) + allocate(dnID_global(nlon*nlat)) + + call ncd_io(ncid=ncid, varname='ID', flag='read', data=rtempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart ID') + if (mainproc) write(iulog,*) 'Read ID ',minval(rtempr),maxval(rtempr) + + IDkey(:) = 0 + do j=1,nlat + do i=1,nlon + n = (j-1)*nlon + i + ID0_global = int(rtempr(i,j)) + if (ID0_global < 0 .or. ID0_global > nlon*nlat) then + write(iulog,*) subname,' ERROR ID0 out of range',n,ID0_global + call shr_sys_abort(subname//' ERROR error ID0 out of range') + endif + if (IDkey(ID0_global) /= 0) then + write(iulog,*) subname,' ERROR ID0 value occurs twice',n,ID0_global + call shr_sys_abort(subname//' ERROR ID0 value occurs twice') + endif + IDkey(ID0_global) = n + end do + end do + if (minval(IDkey) < 1) then + write(iulog,*) subname,' ERROR IDkey incomplete' + call shr_sys_abort(subname//' ERROR IDkey incomplete') + endif + + call ncd_io(ncid=ncid, varname='dnID', flag='read', data=rtempr, readvar=found) + if ( .not. found ) call shr_sys_abort( trim(subname)//' ERROR: read mosart dnID') + if (mainproc) write(iulog,*) 'Read dnID ',minval(rtempr),maxval(rtempr) + do j=1,nlat + do i=1,nlon + n = (j-1)*nlon + i + dnID_global(n) = int(rtempr(i,j)) + if (dnID_global(n) > 0 .and. dnID_global(n) <= nlon*nlat) then + if (IDkey(dnID_global(n)) > 0 .and. IDkey(dnID_global(n)) <= nlon*nlat) then + dnID_global(n) = IDkey(dnID_global(n)) + else + write(iulog,*) subname,' ERROR bad IDkey',n,dnID_global(n),IDkey(dnID_global(n)) + call shr_sys_abort(subname//' ERROR bad IDkey') + endif + endif + end do + end do + if (mainproc) write(iulog,*) 'dnID ',minval(rtempr),maxval(rtempr) + deallocate(rtempr) + + call ncd_pio_closefile(ncid) + + !------------------------------------------------------- + ! Determine mosart ocn/land mask (global, all procs) + !------------------------------------------------------- + + ! 1=land, 2=ocean, 3=ocean outlet from land + allocate(gmask(nlon*nlat)) + gmask(:) = 2 ! assume ocean point + do n=1,nlon*nlat ! mark all downstream points as outlet + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(nr) = 3 ! <- nr + end if + enddo + do n=1,nlon*nlat ! now mark all points with downstream points as land + nr = dnID_global(n) + if ((nr > 0) .and. (nr <= nlon*nlat)) then + gmask(n) = 1 ! <- n + end if + enddo + + !------------------------------------------------------- + ! Compute total number of basins and runoff points + !------------------------------------------------------- + + nbas = 0 + nrof = 0 + nout = 0 + nmos = 0 + do nr=1,nlon*nlat + if (gmask(nr) == 3) then + nout = nout + 1 + nbas = nbas + 1 + nmos = nmos + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 2) then + nbas = nbas + 1 + nrof = nrof + 1 + elseif (gmask(nr) == 1) then + nmos = nmos + 1 + nrof = nrof + 1 + endif + enddo + if (mainproc) then + write(iulog,*) 'Number of outlet basins = ',nout + write(iulog,*) 'Number of total basins = ',nbas + write(iulog,*) 'Number of mosart points = ',nmos + write(iulog,*) 'Number of runoff points = ',nrof + endif + + !------------------------------------------------------- + ! Compute river basins, actually compute ocean outlet gridcell + !------------------------------------------------------- + + ! idxocn = final downstream cell, index is global 1d ocean gridcell + ! nupstrm = number of source gridcells upstream including self + allocate(idxocn(nlon*nlat)) + allocate(nupstrm(nlon*nlat)) + idxocn(:) = 0 + nupstrm(:) = 0 + do nr=1,nlon*nlat + n = nr + if (abs(gmask(n)) == 1) then ! land + g = 0 + do while (abs(gmask(n)) == 1 .and. g < nlon*nlat) ! follow downstream + nupstrm(n) = nupstrm(n) + 1 + n = dnID_global(n) + g = g + 1 + end do + if (gmask(n) == 3) then ! found ocean outlet + nupstrm(n) = nupstrm(n) + 1 ! one more land cell for n + idxocn(nr) = n ! set ocean outlet or nr to n + elseif (abs(gmask(n)) == 1) then ! no ocean outlet, warn user, ignore cell + write(iulog,*) subname,' ERROR closed basin found', & + g,nr,gmask(nr),dnID_global(nr),n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR closed basin found') + elseif (gmask(n) == 2) then + write(iulog,*) subname,' ERROR found invalid ocean cell ',nr + call shr_sys_abort(subname//' ERROR found invalid ocean cell') + else + write(iulog,*) subname,' ERROR downstream cell is unknown', & + g,nr,gmask(nr),dnID_global(nr),n,gmask(n),dnID_global(n) + call shr_sys_abort(subname//' ERROR downstream cell is unknown') + endif + elseif (gmask(n) >= 2) then ! ocean, give to self + nupstrm(n) = nupstrm(n) + 1 + idxocn(nr) = n + endif + enddo + + !------------------------------------------------------- + !--- Now allocate those basins to pes + !------------------------------------------------------- + + ! this is the heart of the decomp, need to set pocn and nop by the end of this + ! pocn is the pe that gets the basin associated with ocean outlet nr + ! nop is a running count of the number of mosart cells/pe + allocate(pocn(nlon*nlat)) + pocn(:) = -99 + nop(0:npes-1) = 0 + if (trim(decomp_option) == 'basin') then + + baspe = 0 + maxgcells_per_pe = int(float(nrof)/float(npes)*0.445) + 1 + nloops = 3 + minbas = nrof + do nl=1,nloops + maxbas = minbas - 1 + minbas = maxval(nupstrm)/(2**nl) + if (nl == nloops) minbas = min(minbas,1) + do nr=1,nlon*nlat + if (gmask(nr) >= 2 .and. nupstrm(nr) > 0 .and. nupstrm(nr) >= minbas .and. nupstrm(nr) <= maxbas) then + ! Decomp options + ! find min pe (implemented but scales poorly) + ! use increasing thresholds (implemented, ok load balance for l2r or calc) + ! distribute basins using above methods but work from max to min basin size + ! find next pe below maxgcells_per_pe threshhold and increment + do while (nop(baspe) > maxgcells_per_pe) + baspe = baspe + 1 + if (baspe > npes-1) then + baspe = 0 + ! 3 loop, .445 and 1.5 chosen carefully + maxgcells_per_pe = max(maxgcells_per_pe*1.5, maxgcells_per_pe+1.0) + endif + enddo + if (baspe > npes-1 .or. baspe < 0) then + write(iulog,*) 'ERROR in decomp for mosart ',nr,npes,baspe + call shr_sys_abort('ERROR mosart decomp') + endif + nop(baspe) = nop(baspe) + nupstrm(nr) + pocn(nr) = baspe + endif + enddo ! nr + enddo ! nl + + ! set pocn for land cells, was set for ocean above + do nr=1,nlon*nlat + if (idxocn(nr) > 0) then + pocn(nr) = pocn(idxocn(nr)) + if (pocn(nr) < 0 .or. pocn(nr) > npes-1) then + write(iulog,*) subname,' ERROR pocn lnd setting ',& + nr,idxocn(nr),idxocn(idxocn(nr)),pocn(idxocn(nr)),pocn(nr),npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + enddo + + elseif (trim(decomp_option) == '1d') then + + ! distribute active points in 1d fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + maxgcells_per_pe = (nrof-1)/npes + 1 + do nr=1,nlon*nlat + pocn(nr) = baspe + nop(baspe) = nop(baspe) + 1 + if (nop(baspe) >= maxgcells_per_pe) then + baspe = (mod(baspe+1,npes)) + if (baspe < 0 .or. baspe > npes-1) then + write(iulog,*) subname,' ERROR basepe ',baspe,npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + endif + enddo + + elseif (trim(decomp_option) == 'roundrobin') then + + ! distribute active points in roundrobin fashion to pes + ! baspe is the pe assignment + ! maxgcells_per_pe is the maximum number of points to assign to each pe + baspe = 0 + do nr=1,nlon*nlat + pocn(nr) = baspe + nop(baspe) = nop(baspe) + 1 + baspe = (mod(baspe+1,npes)) + if (baspe < 0 .or. baspe > npes-1) then + write(iulog,*) subname,' ERROR basepe ',baspe,npes + call shr_sys_abort(subname//' ERROR pocn lnd') + endif + enddo + do nr = 1,nlon*nlat + if (pocn(nr) < 0) then + write(6,*)'WARNING: nr,pocn(nr) is < 0',nr,pocn(nr) + end if + end do + + else + write(iulog,*) subname,' ERROR decomp option unknown ',trim(decomp_option) + call shr_sys_abort(subname//' ERROR pocn lnd') + endif ! decomp_option + + if (mainproc) then + write(iulog,*) 'mosart cells and basins total = ',nrof,nbas + write(iulog,*) 'mosart cells per basin avg/max = ',nrof/nbas,maxval(nupstrm) + write(iulog,*) 'mosart cells per pe min/max = ',minval(nop),maxval(nop) + write(iulog,*) 'mosart basins per pe min/max = ',minval(nba),maxval(nba) + endif + deallocate(nupstrm) + + !------------------------------------------------------- + ! Determine begr, endr, numr and lnumr + !------------------------------------------------------- + + numr = 0 + do n = 0,npes-1 + if (iam == n) then + begr = numr + 1 + endr = begr + nop(n) - 1 + endif + numr = numr + nop(n) + enddo + lnumr = endr - begr + 1 + + !------------------------------------------------------- + ! Determine glo2loc (global to local) + !------------------------------------------------------- + + ! pocn(nlon*nlat) pe number assigned to basin + ! nop(0:npes-1) number of gridcells on a pe + ! nba(0:npes-1) number of basins on each pe + ! nrs(0:npes-1) begr on each pe + + ! Determine glo2loc + ! nrs is begr on each pe + ! reuse nba for nop-like counter here, pocn -99 is unused cell + + nrs(:) = 0 + nrs(0) = 1 + do n = 1,npes-1 + ! nop is number of cells per pe + ! so loop through the pes and determine begr on each pe + nrs(n) = nrs(n-1) + nop(n-1) + enddo + + allocate(glo2loc(nlon*nlat)) + glo2loc(:) = 0 + nba(:) = 0 + do nr = 1,nlon*nlat + procid = pocn(nr) + if (procid >= 0) then + glo2loc(nr) = nrs(procid) + nba(procid) + nba(procid) = nba(procid) + 1 + endif + enddo + do n = 0,npes-1 + if (nba(n) /= nop(n)) then + write(iulog,*) subname,' ERROR mosart cell count ',n,nba(n),nop(n) + call shr_sys_abort(subname//' ERROR mosart cell count') + endif + enddo + + ! Determine gindex + allocate(this%gindex(begr:endr)) + do j = 1,nlat + do i = 1,nlon + n = (j-1)*nlon + i + if (dnID_global(n) > 0) then + if (glo2loc(dnID_global(n)) == 0) then + write(iulog,*) subname,' ERROR glo2loc dnID_global ',& + nr,n,dnID_global(n),glo2loc(dnID_global(n)) + call shr_sys_abort(subname//' ERROT glo2loc dnID_global') + end if + end if + nr = glo2loc(n) + if (nr >= begr .and. nr <= endr) then + this%gindex(nr) = n + endif + end do + end do + + !------------------------------------------------------- + ! Create distGrid from global index array + !------------------------------------------------------- + + allocate(seqlist(endr-begr+1)) + n = 0 + do nr = begr,endr + n = n + 1 + seqlist(n) = this%gindex(nr) + end do + this%DistGrid = ESMF_DistGridCreate(arbSeqIndexList=seqlist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + deallocate(seqlist) + + !------------------------------------------------------- + ! Determine local lonc and latc + !------------------------------------------------------- + + allocate(this%lonc(begr:endr), this%latc(begr:endr)) + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + this%lonc(nr) = this%rlon(i) + this%latc(nr) = this%rlat(j) + end do + + !------------------------------------------------------- + ! Determine halo points and create halo route handle + !------------------------------------------------------- + if( use_halo_option ) then + ! note that for each gridcell below there are nhalo extra elements that need to be allocated + ! Need to keep track of the global index of each halo point + ! temporary allocatable array store_halo_index = size((endr-begr+1)*nhalo) (nhalo is the number of halo points) + ! + ! Allocate halo_arrayptr_index - local index (starting at 1) into this%halo_arrayptr on my pe + allocate(this%halo_arrayptr_index(endr-begr+1,max_num_halo)) + this%halo_arrayptr_index(:,:) = -999 + + allocate(store_halo_index((endr-begr+1)*max_num_halo)) + store_halo_index(:) = 0 + + do nr = begr,endr + n = this%gindex(nr) + i = mod(n-1,nlon) + 1 + j = (n-1)/nlon + 1 + jm1 = j-1 + jp1 = j+1 + im1 = i-1 + ip1 = i+1 + if (i == 1) im1 = 1 + if (j == 1) jm1 = 1 + if (i == nlon) ip1 = nlon + if (j == nlat) jp1 = nlat + n_sw = (jm1-1)*nlon + im1 + n_s = (jm1-1)*nlon + i + n_se = (jm1-1)*nlon + ip1 + n_e = ( j-1)*nlon + ip1 + n_ne = (jp1-1)*nlon + ip1 + n_n = (jp1-1)*nlon + i + n_nw = (jp1-1)*nlon + im1 + n_w = ( j-1)*nlon + im1 + call set_halo_index(n_sw, halo_sw, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_s , halo_s , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_se, halo_se, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_e , halo_e , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_ne, halo_ne, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_n , halo_n , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_nw, halo_nw, glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + call set_halo_index(n_w , halo_w , glo2loc, nr, begr, endr, pocn, store_halo_index, this%halo_arrayptr_index) + end do + + ! Allocate halo_list - global indices of the halo points on my pe + num_halo = count(store_halo_index /= 0) + allocate(halo_list(num_halo)) + halo_list(1:num_halo) = store_halo_index(1:num_halo) + + ! Create halo route handle using predefined allocatable memory + allocate(this%fld_halo_arrayptr(endr-begr+1+num_halo)) + this%fld_halo_arrayptr(:) = 0. + this%fld_halo_array = ESMF_ArrayCreate(this%distgrid, this%fld_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create a halo route handle - only need one + call ESMF_ArrayHaloStore(this%fld_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create ESMF arrays for lon, lat and fld + allocate(this%lon_halo_arrayptr(endr-begr+1+num_halo)) + this%lon_halo_arrayptr(:) = 0. + this%lon_halo_array = ESMF_ArrayCreate(this%distgrid, this%lon_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + allocate(this%lat_halo_arrayptr(endr-begr+1+num_halo)) + this%lat_halo_arrayptr(:) = 0. + this%lat_halo_array = ESMF_ArrayCreate(this%distgrid, this%lat_halo_arrayptr, haloSeqIndexList=halo_list, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Set halo array for lon and lat - these do not change with time + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%lon_halo_arrayptr(n) = this%lonc(nr) + this%lat_halo_arrayptr(n) = this%latc(nr) + end do + call ESMF_ArrayHalo(this%lon_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_ArrayHalo(this%lat_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Deallocate memory + deallocate(halo_list) + deallocate(store_halo_index) + + ! Now do a test of the halo operation + call this%test_halo(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + deallocate(glo2loc) + deallocate(pocn) + + !------------------------------------------------------- + ! Determine mask, outletg and dsig + !------------------------------------------------------- + + allocate(this%mask(begr:endr), this%outletg(begr:endr), this%dsig(begr:endr)) + do nr = begr,endr + n = this%gindex(nr) + this%mask(nr) = gmask(n) + this%outletg(nr) = idxocn(n) + if (dnID_global(n) <= 0) then + this%dsig(nr) = 0 + else + this%dsig(nr) = dnID_global(n) + endif + end do + deallocate(gmask) + deallocate(dnID_global) + deallocate(idxocn) + + !------------------------------------------------------- + ! Write per-processor runoff bounds depending on dbug level + !------------------------------------------------------- + + if (mainproc) then + write(iulog,*) 'total runoff cells numr = ',numr + endif + call mpi_barrier(mpicom_rof,ier) + npmin = 0 + npmax = npes-1 + npint = 1 + if (dbug == 0) then + npmax = 0 + elseif (dbug == 1) then + npmax = min(npes-1,4) + elseif (dbug == 2) then + npint = npes/8 + elseif (dbug == 3) then + npint = 1 + endif + do np = npmin,npmax,npint + pid = np + if (dbug == 1) then + if (np == 2) pid=npes/2-1 + if (np == 3) pid=npes-2 + if (np == 4) pid=npes-1 + endif + pid = max(pid,0) + pid = min(pid,npes-1) +#ifndef NDEBUG + if (iam == pid) then + write(iulog,'(2a,i9,a,i9,a,i9,a,i9)')' mosart decomp info',& + ' proc = ',iam,' begr = ',begr,' endr = ',endr,' numr = ',lnumr + endif +#endif + call mpi_barrier(mpicom_rof,ier) + enddo + + end subroutine init_decomp + + !======================================================================== + + subroutine set_halo_index(global_index, halo_index, glo2loc, nr, begr, endr, pocn, store_halo_index, halo_arrayptr_index) + + ! Arguments + integer, intent(in) :: global_index + integer, intent(in) :: halo_index + integer, intent(in) :: glo2loc(:) + integer, intent(in) :: nr + integer, intent(in) :: begr, endr + integer, intent(in) :: pocn(:) + integer, intent(inout) :: store_halo_index(:) + integer, intent(inout) :: halo_arrayptr_index(:,:) + + ! Local variables + integer :: n + logical :: found_index + integer :: nsize + integer :: num_halo + !----------------------------------------------------------------------- + + nsize = endr-begr+1 + if (pocn(global_index) /= iam) then + found_index = .false. + do n = 1,size(store_halo_index) + if (store_halo_index(n) == global_index) then + num_halo = n + found_index = .true. + exit + else if (store_halo_index(n) == 0) then + store_halo_index(n) = global_index + num_halo = n + found_index = .true. + exit + end if + end do + if (.not. found_index) then + call shr_sys_abort('ERROR: global halo index not found') + end if + halo_arrayptr_index(nr-begr+1,halo_index) = nsize + num_halo + else + halo_arrayptr_index(nr-begr+1,halo_index) = glo2loc(global_index) - begr + 1 + end if + + end subroutine set_halo_index + + !======================================================================== + subroutine test_halo(this, rc) + + ! Arguments + class(control_type) :: this + integer, intent(out) :: rc + + ! Local variables + integer :: i,j + integer :: n, nr + integer :: nglob + integer :: halo_value + integer :: valid_value + real(r8) :: lon, lon_p1, lon_m1 + real(r8) :: lat, lat_p1, lat_m1 + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + n = 0 + do nr = this%begr,this%endr + n = n + 1 + this%fld_halo_arrayptr(n) = this%latc(nr)*10. + this%lonc(nr)/100. + end do + + call ESMF_ArrayHalo(this%fld_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + n = 0 + do nr = this%begr,this%endr + n = n+1 + nglob = this%gindex(nr) + i = mod(nglob-1,this%nlon) + 1 + j = (nglob-1)/this%nlon + 1 + if (j== 1) then + lat_m1 = this%rlat(1) + else + lat_m1 = this%rlat(j-1) + end if + if (j == this%nlat) then + lat_p1 = this%rlat(this%nlat) + else + lat_p1 = this%rlat(j+1) + end if + lat = this%rlat(j) + if (i == 1) then + lon_m1 = this%rlon(1) + else + lon_m1 = this%rlon(i-1) + end if + if (i == this%nlon) then + lon_p1 = this%rlon(this%nlon) + else + lon_p1 = this%rlon(i+1) + end if + lon = this%rlon(i) + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_sw)) + valid_value = lat_m1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_s)) + valid_value = lat_m1*10 + lon/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_se)) + valid_value = lat_m1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_e)) + valid_value = lat*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_ne)) + valid_value = lat_p1*10 + lon_p1/100. + if (halo_value /= valid_value) then + write(6,'(a,2f20.10)')'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + ! + halo_value = this%fld_halo_arrayptr(this%halo_arrayptr_index(n,halo_nw)) + valid_value = lat_p1*10 + lon_m1/100. + if (halo_value /= valid_value) then + write(6,*)'ERROR: halo, valid not the same = ',halo_value, valid_value + call shr_sys_abort('ERROR: invalid halo') + end if + end do + + end subroutine test_halo + + !======================================================================== + + subroutine calc_gradient(this, fld, fld_halo_array, dfld_dx, dfld_dy, rc) + + ! Calculate gradient from nine gridcells (center and surrounding) + + ! Uses + + ! Arguments: + class(control_type) :: this + real(r8), intent(in) :: fld(this%begr:this%endr) + type(ESMF_Array) :: fld_halo_array + real(r8), intent(out) :: dfld_dx(:) ! gradient x component + real(r8), intent(out) :: dfld_dy(:) ! gradient y component + integer , intent(out) :: rc + + ! Local variables + integer :: i, n, nr ! local indices + real(r8) :: deg2rad + real(r8) :: mean_dx, mean_dy, dlon, dlat + integer :: ax_indices(4) ! x indices to add + integer :: sx_indices(4) ! x indices to subtract + integer :: ay_indices(4) ! y indices to add + integer :: sy_indices(4) ! y indices to subtract + real(r8) :: fld_surrounding(max_num_halo) + real(r8) :: dx(max_num_halo) + real(r8) :: dy(max_num_halo) + integer :: index + real(r8), pointer :: fld_halo_arrayptr(:) + !----------------------------------------------------------------------- + + call t_startf('gradient') + + rc = ESMF_SUCCESS + + ! Define indices for addition/subtraction + ax_indices(:) = (/halo_ne,halo_e,halo_e,halo_se/) ! x indices to add + sx_indices(:) = (/halo_nw,halo_w,halo_w,halo_sw/) ! x indices to subtract + ay_indices(:) = (/halo_ne,halo_n,halo_n,halo_nw/) ! y indices to add + sy_indices(:) = (/halo_se,halo_s,halo_s,halo_sw/) ! y indices to subtract + + ! degrees to radians + deg2rad = shr_const_pi / 180._r8 + + ! Get pointer to data in ESMF array + call ESMF_ArrayGet(fld_halo_array, farrayPtr=fld_halo_arrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! update halo array for fld + n = 0 + do nr = this%begr,this%endr + n = n + 1 + fld_halo_arrayptr(n) = fld(nr) + end do + call ESMF_ArrayHalo(fld_halo_array, routehandle=this%haloHandle, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Initialize gradient components + dfld_dx(:) = 0._r8 + dfld_dy(:) = 0._r8 + + n = 0 + do nr = this%begr,this%endr + n = n+1 + + ! extract neighbors from halo array + do i = 1,max_num_halo + index = this%halo_arrayptr_index(n,i) + fld_surrounding(i) = fld_halo_arrayptr(index) + dlon = (this%lon_halo_arrayptr(n) - this%lon_halo_arrayptr(index)) + dlat = (this%lat_halo_arrayptr(n) - this%lat_halo_arrayptr(index)) + dx(i) = shr_const_rearth * abs(deg2rad*dlon) * cos(deg2rad*this%latc(nr)) + dy(i) = shr_const_rearth * abs(deg2rad*dlat) + enddo + + ! calculate mean spacing + mean_dx = 0.5_r8 * (dx(halo_w)+dx(halo_e)) ! average dx west and east + mean_dy = 0.5_r8 * (dy(halo_s)+dy(halo_n)) ! average dy south and north + + ! compute gradient values + ! for x gradient sum [NE,2xE,SE,-NW,-2xW,-SW] + ! for y gradient sum [NE,2xN,NW,-SE,-2xS,-SW] + do i = 1,4 + dfld_dx(n) = dfld_dx(n) + (fld_surrounding(ax_indices(i)) - fld_surrounding(sx_indices(i))) + dfld_dy(n) = dfld_dy(n) + (fld_surrounding(ay_indices(i)) - fld_surrounding(sy_indices(i))) + enddo + + dfld_dx(n) = dfld_dx(n) / (8._r8*mean_dx) + dfld_dy(n) = dfld_dy(n) / (8._r8*mean_dy) + + enddo ! end of nr loop + + call t_stopf('gradient') + + end subroutine calc_gradient + +end module mosart_control_type diff --git a/src/riverroute/mosart_data.F90 b/src/riverroute/mosart_data.F90 new file mode 100644 index 0000000..5650e2c --- /dev/null +++ b/src/riverroute/mosart_data.F90 @@ -0,0 +1,19 @@ +module mosart_data + + use mosart_control_type, only : control_type + use mosart_tctl_type, only : tctl_type + use mosart_tspatialunit_type, only : tspatialunit_type + use mosart_tstatusflux_type, only : tstatusflux_type + use mosart_tparameter_type, only : tparameter_type + + implicit none + private + + ! Derived types + type(Tctl_type), public :: Tctl + type(Tspatialunit_type), public :: TUnit + type(TstatusFlux_type), public :: TRunoff + type(Tparameter_type), public :: TPara + type(control_type), public :: ctl + +end module mosart_data diff --git a/src/riverroute/mosart_driver.F90 b/src/riverroute/mosart_driver.F90 new file mode 100644 index 0000000..652bf98 --- /dev/null +++ b/src/riverroute/mosart_driver.F90 @@ -0,0 +1,927 @@ +module mosart_driver + + !----------------------------------------------------------------------- + ! Mosart Routing Model + !----------------------------------------------------------------------- + + use shr_kind_mod , only : r8 => shr_kind_r8, CS => shr_kind_cs, CL => shr_kind_CL + use shr_sys_mod , only : shr_sys_abort + use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_CDAY + use mosart_vars , only : re, spval, iulog, ice_runoff, & + frivinp, nsrContinue, nsrBranch, nsrStartup, nsrest, & + inst_index, inst_suffix, inst_name, decomp_option, & + bypass_routing_option, qgwl_runoff_option, barrier_timers, & + mainproc, npes, iam, mpicom_rof, budget_frq, isecspday + use mosart_data , only : ctl, Tctl, Tunit, TRunoff, Tpara + use mosart_budget_type , only : budget_type + use mosart_fileutils , only : getfil + use mosart_timemanager , only : timemgr_init, get_nstep, get_curr_date + use mosart_histflds , only : mosart_histflds_init, mosart_histflds_set + use mosart_histfile , only : mosart_hist_updatehbuf, mosart_hist_htapeswrapup, mosart_hist_htapesbuild, & + ndens, mfilt, nhtfrq, avgflag_pertape, avgflag_pertape, & + fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, max_tapes, max_namlen + use mosart_restfile , only : mosart_rest_timemanager, mosart_rest_getfile, mosart_rest_fileread, & + mosart_rest_filewrite, mosart_rest_filename, finidat, nrevsn + use mosart_physics , only : updatestate_hillslope, updatestate_subnetwork, updatestate_mainchannel, Euler + use perf_mod , only : t_startf, t_stopf + use nuopc_shr_methods , only : chkerr + use ESMF , only : ESMF_SUCCESS, ESMF_FieldGet, ESMF_FieldSMMStore, ESMF_FieldSMM, & + ESMF_TERMORDER_SRCSEQ, ESMF_Mesh + use mosart_io , only : ncd_pio_openfile, ncd_inqdid, ncd_inqdlen, ncd_pio_closefile, ncd_decomp_init, & + pio_subsystem + use pio , only : file_desc_t + use mpi + + implicit none + private + + ! public member functions: + public :: mosart_read_namelist ! Read in mosart namelist + public :: mosart_init1 ! Initialize mosart grid + public :: mosart_init2 ! Initialize mosart maps + public :: mosart_run ! River routing model + + ! mosart namelists + integer :: coupling_period ! mosart coupling period + integer :: delt_mosart ! mosart internal timestep (->nsub) + logical :: use_halo_option ! enable halo capability using ESMF + character(len=CS) :: mosart_tracers ! colon delimited string of tracer names + character(len=CS) :: mosart_euler_calc ! colon delimited string of logicals for using Euler algorithm + + ! subcycling + integer :: nsub_save ! previous nsub + real(r8) :: delt_save ! previous delt + + ! global (glo) + integer , allocatable :: IDkey(:) ! translation key from ID to gindex + + ! budget + type(budget_type), public :: budget ! type containing vars and routines for budget checking + + character(len=CL) :: nlfilename_rof = 'mosart_in' + character(len=CL) :: fnamer ! name of netcdf restart file + + integer :: nt_liq, nt_ice + + character(*), parameter :: u_FILE_u = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine mosart_read_namelist() + ! + ! Read and distribute mosart namelist + ! + ! local variables + integer :: i + integer :: ier ! error code + integer :: unitn ! unit for namelist file + logical :: lexist ! File exists + character(len=CS) :: runtyp(4) ! run type + logical, allocatable :: do_euler_calc(:) ! turn on euler algorithm + character(len=*),parameter :: subname = '(mosart_read_namelist) ' + !----------------------------------------------------------------------- + + !------------------------------------------------------- + ! Read in mosart namelist + !------------------------------------------------------- + + namelist /mosart_inparm / frivinp, finidat, nrevsn, coupling_period, ice_runoff, & + ndens, mfilt, nhtfrq, fincl1, fincl2, fincl3, fexcl1, fexcl2, fexcl3, & + avgflag_pertape, decomp_option, bypass_routing_option, qgwl_runoff_option, & + use_halo_option, delt_mosart, mosart_tracers, mosart_euler_calc, budget_frq + + ! Preset values + ice_runoff = .true. + finidat = ' ' + nrevsn = ' ' + coupling_period = -1 + delt_mosart = 3600 + decomp_option = 'basin' + bypass_routing_option = 'direct_in_place' + qgwl_runoff_option = 'threshold' + use_halo_option = .false. + mosart_tracers = 'LIQ:ICE' + mosart_euler_calc = 'T:F' + + nlfilename_rof = "mosart_in" // trim(inst_suffix) + inquire (file = trim(nlfilename_rof), exist = lexist) + if ( .not. lexist ) then + write(iulog,*) subname // ' ERROR: nlfilename_rof does NOT exist: '//trim(nlfilename_rof) + call shr_sys_abort(trim(subname)//' ERROR nlfilename_rof does not exist') + end if + if (mainproc) then + write(iulog,*) 'Reading mosart_inparm namelist from: ', trim(nlfilename_rof) + open( newunit=unitn, file=trim(nlfilename_rof), status='old' ) + ier = 1 + do while ( ier /= 0 ) + read(unitn, mosart_inparm, iostat=ier) + if (ier < 0) then + call shr_sys_abort( subname//' encountered end-of-file on mosart_inparm read' ) + endif + end do + close(unitn) + end if + + call mpi_bcast (finidat, len(finidat), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (frivinp, len(frivinp), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (nrevsn, len(nrevsn), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (decomp_option, len(decomp_option), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (use_halo_option, 1, MPI_LOGICAL, 0, mpicom_rof, ier) + call mpi_bcast (coupling_period, 1, MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (delt_mosart, 1, MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (bypass_routing_option, len(bypass_routing_option), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (qgwl_runoff_option, len(qgwl_runoff_option), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (ice_runoff, 1, MPI_LOGICAL, 0, mpicom_rof, ier) + call mpi_bcast (nhtfrq, size(nhtfrq), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (mfilt, size(mfilt), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (ndens, size(ndens), MPI_INTEGER, 0, mpicom_rof, ier) + call mpi_bcast (fexcl1, (max_namlen+2)*size(fexcl1), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fexcl2, (max_namlen+2)*size(fexcl2), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fexcl3, (max_namlen+2)*size(fexcl3), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fincl1, (max_namlen+2)*size(fincl1), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fincl2, (max_namlen+2)*size(fincl2), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (fincl3, (max_namlen+2)*size(fincl3), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (avgflag_pertape, size(avgflag_pertape), MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (mosart_tracers, CS, MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (mosart_euler_calc, CS, MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (budget_frq,1,MPI_INTEGER,0,mpicom_rof,ier) + + ! Determine number of tracers and array of tracer names and initialize module variables + call ctl%init_tracer_names(mosart_tracers) + nt_liq = ctl%nt_liq + nt_ice = ctl%nt_ice + + runtyp(:) = 'missing' + runtyp(nsrStartup + 1) = 'initial' + runtyp(nsrContinue + 1) = 'restart' + runtyp(nsrBranch + 1) = 'branch ' + + if (mainproc) then + write(iulog,*) 'define run:' + write(iulog,'(a)' ) ' run type = '//trim(runtyp(nsrest+1)) + write(iulog,'(a,i8)') ' coupling_period = ',coupling_period + write(iulog,'(a,i8)') ' delt_mosart = ',delt_mosart + write(iulog,'(a)' ) ' decomp option = '//trim(decomp_option) + write(iulog,'(a,l1)') ' use_halo_option = ',use_halo_option + write(iulog,'(a)' ) ' bypass_routing option = '//trim(bypass_routing_option) + write(iulog,'(a)' ) ' qgwl runoff option = '//trim(qgwl_runoff_option) + write(iulog,'(a)' ) ' mosart tracers = '//trim(mosart_tracers) + write(iulog,'(a)' ) ' mosart euler calc = '//trim(mosart_euler_calc) + if (nsrest == nsrStartup .and. finidat /= ' ') then + write(iulog,'(a)') ' mosart initial data = '//trim(finidat) + end if + endif + + if (frivinp == ' ') then + call shr_sys_abort( subname//' ERROR: frivinp NOT set' ) + else + if (mainproc) then + write(iulog,*) ' mosart river data = ',trim(frivinp) + endif + end if + + if (trim(bypass_routing_option) == 'direct_to_outlet') then + if (trim(qgwl_runoff_option) == 'threshold') then + call shr_sys_abort( subname//' ERROR: qgwl_runoff_option & + CANNOT be threshold if bypass_routing_option==direct_to_outlet' ) + end if + else if (trim(bypass_routing_option) == 'none') then + if (trim(qgwl_runoff_option) /= 'all') then + call shr_sys_abort( subname//' ERROR: qgwl_runoff_option & + can only be all if bypass_routing_option==none' ) + end if + end if + + if (coupling_period <= 0) then + write(iulog,*) subname,' ERROR mosart coupling_period invalid',coupling_period + call shr_sys_abort( subname//' ERROR: coupling_period invalid' ) + endif + + if (delt_mosart <= 0) then + write(iulog,*) subname,' ERROR mosart delt_mosart invalid',delt_mosart + call shr_sys_abort( subname//' ERROR: delt_mosart invalid' ) + endif + + do i = 1, max_tapes + if (nhtfrq(i) == 0) then + mfilt(i) = 1 + else if (nhtfrq(i) < 0) then + nhtfrq(i) = nint(-nhtfrq(i)*SHR_CONST_CDAY/(24._r8*coupling_period)) + endif + end do + + end subroutine mosart_read_namelist + + !----------------------------------------------------------------------- + + subroutine mosart_init1(rc) + + !------------------------------------------------- + ! Initialize mosart grid, mask, decomp + ! + ! Arguments + integer, intent(out) :: rc + ! + ! Local variables + integer :: n, nr, nt ! indices + type(file_desc_t) :: ncid ! netcdf file id + character(len=CL) :: trstr ! tracer string + character(len=CL) :: locfn ! local file + integer :: dimid ! netcdf dimension identifier + character(len=*), parameter :: subname = '(mosart_init1) ' + !------------------------------------------------- + + rc = ESMF_SUCCESS + + !------------------------------------------------------- + ! Obtain restart file if appropriate + !------------------------------------------------------- + if ((nsrest == nsrStartup .and. finidat /= ' ') .or. & + (nsrest == nsrContinue) .or. (nsrest == nsrBranch )) then + call mosart_rest_getfile( file=fnamer ) + endif + + !------------------------------------------------------- + ! Initialize time manager + !------------------------------------------------------- + if (nsrest == nsrStartup) then + call timemgr_init(dtime_in=coupling_period) + else + call mosart_rest_timemanager(file=fnamer) + end if + + !------------------------------------------------------- + ! Write out tracers to stdout + !------------------------------------------------------- + if (mainproc) then + trstr = trim(ctl%tracer_names(1)) + do n = 2,ctl%ntracers + trstr = trim(trstr)//':'//trim(ctl%tracer_names(n)) + enddo + write(iulog,*)'mosart tracers = ',ctl%ntracers,trim(trstr) + end if + + !------------------------------------------------------- + ! Obtain global sizes of grid from river direction file + !------------------------------------------------------- + call getfil(frivinp, locfn, 0 ) + call ncd_pio_openfile(ncid, trim(locfn), 0) + call ncd_inqdid(ncid,'lon',dimid) + call ncd_inqdlen(ncid,dimid,ctl%nlon) + call ncd_inqdid(ncid,'lat',dimid) + call ncd_inqdlen(ncid,dimid,ctl%nlat) + call ncd_pio_closefile(ncid) + if (mainproc) then + write(iulog,'(a)') 'MOSART river data file name: ',trim(frivinp) + write(iulog,'(a)') 'Successfully read mosart dimensions' + write(iulog,'(a,i8,2x,i8)') 'Values for global nlon/nlat: ',ctl%nlon,ctl%nlat + endif + + !------------------------------------------------------- + ! Initialize ctl derived type allocatable variables + !------------------------------------------------------- + allocate(IDkey(ctl%nlon*ctl%nlat)) + call ctl%Init(locfn, decomp_option, use_halo_option, IDkey, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !------------------------------------------------------- + ! Initialize pio compDOF (module variable in mosart_io) + !------------------------------------------------------- + call ncd_decomp_init(ctl%begr, ctl%endr, ctl%numr, ctl%gindex) + + end subroutine mosart_init1 + + !----------------------------------------------------------------------- + + subroutine mosart_init2(Emesh, rc) + + ! Second phyas of mosart initialization + ! + ! Arguments + type(ESMF_Mesh), intent(in) :: Emesh + integer , intent(out) :: rc + ! + ! Local variables + integer :: nr, nt + integer :: begr, endr + integer :: ntracers + character(len=*),parameter :: subname = '(mosart_init2)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Set up local variables to be used below + begr = ctl%begr + endr = ctl%endr + ntracers = ctl%ntracers + + !------------------------------------------------------- + ! Initialize MOSART types TCtl, Tpara, TUnit and Trunoff + !------------------------------------------------------- + + call Tctl%Init() + + call Tpara%Init(begr, endr) + + call TRunoff%Init(begr, endr, ntracers) + + call Tunit%Init(begr, endr, ntracers, & + mosart_euler_calc, ctl%nlon, ctl%nlat, Emesh, trim(frivinp), IDKey, & + Tpara%c_twid, Tctl%DLevelR, ctl%area, ctl%gindex, ctl%outletg, pio_subsystem, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !------------------------------------------------------- + ! Read restart/initial info + !------------------------------------------------------- + + call t_startf('mosarti_restart') + if ((nsrest == nsrStartup .and. finidat /= ' ') .or. & + (nsrest == nsrContinue) .or. & + (nsrest == nsrBranch )) then + call mosart_rest_fileread( file=fnamer ) + endif + + do nt = 1,ntracers + do nr = begr,endr + call UpdateState_hillslope(nr,nt) + call UpdateState_subnetwork(nr,nt) + call UpdateState_mainchannel(nr,nt) + ctl%volr(nr,nt) = (TRunoff%wt(nr,nt) + TRunoff%wr(nr,nt) + TRunoff%wh(nr,nt)*ctl%area(nr)) + enddo + enddo + call t_stopf('mosarti_restart') + + !------------------------------------------------------- + ! Initialize mosart history handler and fields + !------------------------------------------------------- + + call t_startf('mosarti_histinit') + call mosart_histflds_init(begr, endr, ntracers) + if (nsrest==nsrStartup .or. nsrest==nsrBranch) then + call mosart_hist_HtapesBuild() + end if + call mosart_histflds_set(ntracers) + if (mainproc) write(iulog,*) subname,' done' + call t_stopf('mosarti_histinit') + + !------------------------------------------------------- + ! Initialize mosart budget + !------------------------------------------------------- + + call t_startf('mosarti_budgetinit') + call budget%Init(begr, endr, ntracers) + call t_stopf('mosarti_budgetinit') + + end subroutine mosart_init2 + + !----------------------------------------------------------------------- + + subroutine mosart_run(begr, endr, ntracers, rstwr, nlend, rdate, rc) + + ! Run mosart river routing model + ! + ! Arguments + integer , intent(in) :: begr, endr, ntracers + logical , intent(in) :: rstwr ! true => write restart file this step) + logical , intent(in) :: nlend ! true => end of run on this step + character(len=*) , intent(in) :: rdate ! restart file time stamp for name + integer , intent(out) :: rc + ! + ! Local variables + integer :: i, j, n, nr, ns, nt, n2, nf ! indices + logical :: budget_check ! if budget check needs to be performed + real(r8) :: volr_init ! temporary storage to compute dvolrdt + integer :: yr, mon, day, ymd, tod ! time information + integer :: nsub ! subcyling for cfl + real(r8) :: delt ! delt associated with subcycling + real(r8) :: delt_coupling ! real value of coupling_period + character(len=CL) :: filer ! restart file name + integer :: cnt ! counter for gridcells + integer :: ier ! error code + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) + + ! parameters used in negative runoff partitioning algorithm + real(r8) :: river_depth_minimum = 1.e-4 ! gridcell average minimum river depth [m] + real(r8) :: river_volume_minimum ! gridcell area multiplied by average river_depth_minimum [m3] + real(r8) :: qgwl_volume ! volume of runoff during time step [m3] + real(r8) :: irrig_volume ! volume of irrigation demand during time step [m3] + logical, save :: first_call = .true. ! first time flag (for backwards compatibility) + character(len=*),parameter :: subname = ' (mosart_run) ' + !----------------------------------------------------------------------- + + call t_startf('mosartr_tot') + + rc = ESMF_SUCCESS + + !----------------------------------------------------- + ! Get date info + !----------------------------------------------------- + + call get_curr_date(yr, mon, day, tod) + ymd = yr*10000 + mon*100 + day + if (tod == 0) then + if (mainproc) then + write(iulog,*) ' ' + write(iulog,'(2a,i10,i6)') trim(subname),' model date is',ymd,tod + end if + endif + + delt_coupling = coupling_period*1.0_r8 + + if (first_call) then + delt_save = delt_mosart + if (mainproc) then + write(iulog,'(2a,g20.12)') trim(subname),' mosart coupling period ',delt_coupling + end if + end if + + + ! BUDGET + + budget_check = .false. + if (budget_frq == 0) then + if (day == 1 .and. tod == 0) then + budget_check = .true. + endif + else if (budget_frq < 0) then + if (mod(get_nstep() * coupling_period, abs(budget_frq) * 3600) == 0) then + budget_check = .true. + endif + else + if (mod(get_nstep() , budget_frq) == 0) then + budget_check = .true. + endif + endif + if (first_call) then ! ignore budget during the first timestep + budget_check = .false. + endif + if (budget_check) then + call t_startf('mosartr_budgetset') + call budget%set_budget(begr,endr,ntracers, delt_coupling) + call t_stopf('mosartr_budgetset') + endif + + ! initialize data for euler solver, in m3/s here + do nr = begr,endr + do nt = 1,ntracers + TRunoff%qsur(nr,nt) = ctl%qsur(nr,nt) + TRunoff%qsub(nr,nt) = ctl%qsub(nr,nt) + TRunoff%qgwl(nr,nt) = ctl%qgwl(nr,nt) + enddo + enddo + + !----------------------------------- + ! Compute irrigation flux based on demand from clm + ! Must be calculated before volr is updated to be consistent with lnd + ! Just consider land points and only remove liquid water + !----------------------------------- + + call t_startf('mosartr_irrig') + ctl%qirrig_actual = 0._r8 + do nr = begr,endr + + ! calculate volume of irrigation flux during timestep + irrig_volume = -ctl%qirrig(nr) * coupling_period + + ! compare irrig_volume to main channel storage; + ! add overage to subsurface runoff + if(irrig_volume > TRunoff%wr(nr,nt_liq)) then + ctl%qsub(nr,nt_liq) = ctl%qsub(nr,nt_liq) + (TRunoff%wr(nr,nt_liq) - irrig_volume) / coupling_period + TRunoff%qsub(nr,nt_liq) = ctl%qsub(nr,nt_liq) + irrig_volume = TRunoff%wr(nr,nt_liq) + endif + + ! actual irrigation rate [m3/s] + ! i.e. the rate actually removed from the main channel + ! if irrig_volume is greater than TRunoff%wr + ctl%qirrig_actual(nr) = - irrig_volume / coupling_period + + ! remove irrigation from wr (main channel) + TRunoff%wr(nr,nt_liq) = TRunoff%wr(nr,nt_liq) - irrig_volume + + enddo + call t_stopf('mosartr_irrig') + + !----------------------------------- + ! Compute flood + ! Remove water from mosart and send back to clm + ! Just consider land points and only remove liquid water + ! ctl%flood is m3/s here + !----------------------------------- + + call t_startf('mosartr_flood') + ctl%flood = 0._r8 + do nr = begr,endr + ! initialize ctl%flood to zero + if (ctl%mask(nr) == 1) then + if (ctl%volr(nr,nt_liq) > ctl%fthresh(nr)) then + ! determine flux that is sent back to the land this is in m3/s + ctl%flood(nr) = (ctl%volr(nr,nt_liq)-ctl%fthresh(nr)) / (delt_coupling) + + ! ctl%flood will be sent back to land - so must subtract this + ! from the input runoff from land + ! tcraig, comment - this seems like an odd approach, you + ! might create negative forcing. why not take it out of + ! the volr directly? it's also odd to compute this + ! at the initial time of the time loop. why not do + ! it at the end or even during the run loop as the + ! new volume is computed. fluxout depends on volr, so + ! how this is implemented does impact the solution. + TRunoff%qsur(nr,nt_liq) = TRunoff%qsur(nr,nt_liq) - ctl%flood(nr) + endif + endif + enddo + call t_stopf('mosartr_flood') + + !----------------------------------------------------- + ! DIRECT transfer to outlet point + ! Remember to subtract water from TRunoff forcing + !----------------------------------------------------- + + if (barrier_timers) then + call t_startf('mosartr_SMdirect_barrier') + call mpi_barrier(mpicom_rof,ier) + call t_stopf ('mosartr_SMdirect_barrier') + endif + + call t_startf('mosartr_SMdirect') + + !----------------------------------------------------- + ! Set up pointer arrays into srcfield and dstfield + !----------------------------------------------------- + + call ESMF_FieldGet(Tunit%srcfield, farrayPtr=src_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(Tunit%dstfield, farrayPtr=dst_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !----------------------------------------------------- + !--- initialize ctl%direct + !----------------------------------------------------- + + ctl%direct(:,:) = 0._r8 + + !----------------------------------------------------- + !--- direct to outlet: all liquid and frozen runoff from glc + !----------------------------------------------------- + + if (ctl%rof_from_glc) then + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + src_direct(nt_liq,cnt) = ctl%qglc_liq(nr) + src_direct(nt_ice,cnt) = ctl%qglc_ice(nr) + enddo + + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! copy direct transfer water to output field + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + ctl%direct_glc(nr,nt_liq) = dst_direct(nt_liq,cnt) + ctl%direct_glc(nr,nt_ice) = dst_direct(nt_ice,cnt) + enddo + else + ctl%direct_glc(:,:) = 0._r8 + ctl%direct_glc(:,:) = 0._r8 + end if + + !----------------------------------------------------- + !--- direct to outlet: all frozen runoff from lnd + !----------------------------------------------------- + + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + src_direct(nt_ice,cnt) = TRunoff%qsur(nr,nt_ice) + TRunoff%qsub(nr,nt_ice) + TRunoff%qgwl(nr,nt_ice) + enddo + + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! copy direct transfer water to output field + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + ctl%direct(nr,nt_ice) = ctl%direct(nr,nt_ice) + dst_direct(nt_ice,cnt) + enddo + + ! set euler_calc = false for frozen runoff + ! TODO: will be reworked after addition of multiple tracers + Tunit%euler_calc(nt_ice) = .false. + + ! Set Trunoff%qsur, TRunoff%qsub and Trunoff%qgwl to zero for nt_ice + TRunoff%qsur(:,nt_ice) = 0._r8 + TRunoff%qsub(:,nt_ice) = 0._r8 + TRunoff%qgwl(:,nt_ice) = 0._r8 + + !----------------------------------------------------- + !--- direct to outlet: qgwl + !----------------------------------------------------- + + !-- liquid runoff components + if (trim(bypass_routing_option) == 'direct_to_outlet') then + + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + !--- copy direct transfer fields, convert kg/m2s to m3/s + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + if (trim(qgwl_runoff_option) == 'all') then + src_direct(nt_liq,cnt) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 + else if (trim(qgwl_runoff_option) == 'negative') then + if(TRunoff%qgwl(nr,nt_liq) < 0._r8) then + src_direct(nt_liq,cnt) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 + endif + endif + enddo + + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !--- copy direct transfer water to output field --- + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + ctl%direct(nr,nt_liq) = ctl%direct(nr,nt_liq) + dst_direct(nt_liq,cnt) + enddo + endif + + !----------------------------------------------------- + !--- direct in place qgwl, qgwl + !----------------------------------------------------- + + if (trim(bypass_routing_option) == 'direct_in_place') then + do nr = begr,endr + if (trim(qgwl_runoff_option) == 'all') then + ctl%direct(nr,nt_liq) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 + else if (trim(qgwl_runoff_option) == 'negative') then + if(TRunoff%qgwl(nr,nt_liq) < 0._r8) then + ctl%direct(nr,nt_liq) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 + endif + else if (trim(qgwl_runoff_option) == 'threshold') then + ! --- calculate volume of qgwl flux during timestep + qgwl_volume = TRunoff%qgwl(nr,nt_liq) * ctl%area(nr) * coupling_period + river_volume_minimum = river_depth_minimum * ctl%area(nr) + + ! if qgwl is negative, and adding it to the main channel + ! would bring main channel storage below a threshold, + ! send qgwl directly to ocean + if (((qgwl_volume + TRunoff%wr(nr,nt_liq)) < river_volume_minimum) .and. (TRunoff%qgwl(nr,nt_liq) < 0._r8)) then + ctl%direct(nr,nt_liq) = TRunoff%qgwl(nr,nt_liq) + TRunoff%qgwl(nr,nt_liq) = 0._r8 + endif + endif + enddo + endif + + !------------------------------------------------------- + !--- direct in place: add other direct terms, e.g. inputs outside of mosart mask, negative qsur + !------------------------------------------------------- + + if (trim(bypass_routing_option) == 'direct_in_place') then + do nt = 1,ntracers + do nr = begr,endr + if (TRunoff%qsub(nr,nt) < 0._r8) then + ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsub(nr,nt) + TRunoff%qsub(nr,nt) = 0._r8 + endif + if (TRunoff%qsur(nr,nt) < 0._r8) then + ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsur(nr,nt) + TRunoff%qsur(nr,nt) = 0._r8 + endif + ! Note Tunit%mask is set in Tunit%init and is obtained from reading in fdir + ! if fdir<0 then mask=0 (ocean), if fdir=0 then mask=2 (outlet) and if fdir>0 then mask=1 (land) + if (Tunit%mask(nr) > 0) then + ! mosart euler + else + ctl%direct(nr,nt) = ctl%direct(nr,nt) + TRunoff%qsub(nr,nt) + TRunoff%qsur(nr,nt) + TRunoff%qgwl(nr,nt) + TRunoff%qsub(nr,nt) = 0._r8 + TRunoff%qsur(nr,nt) = 0._r8 + TRunoff%qgwl(nr,nt) = 0._r8 + endif + enddo + enddo + endif + + !------------------------------------------------------- + !--- direct to outlet: add other direct terms, e.g. inputs outside of mosart mask, negative qsur + !------------------------------------------------------- + + if (trim(bypass_routing_option) == 'direct_to_outlet') then + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + do nt = 1,ntracers + !---- negative qsub water, remove from TRunoff --- + if (TRunoff%qsub(nr,nt) < 0._r8) then + src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsub(nr,nt) + TRunoff%qsub(nr,nt) = 0._r8 + endif + + !---- negative qsur water, remove from TRunoff --- + if (TRunoff%qsur(nr,nt) < 0._r8) then + src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsur(nr,nt) + TRunoff%qsur(nr,nt) = 0._r8 + endif + + !---- water outside the basin --- + !---- *** DO NOT TURN THIS ONE OFF, conservation will fail *** --- + + ! Note Tunit%mask is set in Tunit%init and is obtained from reading in fdir + ! if fdir<0 then mask=0 (ocean), if fdir=0 then mask=2 (outlet) and if fdir>0 then mask=1 (land) + if (Tunit%mask(nr) > 0) then + ! mosart euler + else + ! NOTE: that when nt = nt_ice, the TRunoff terms + ! below have already been set to zero in the frozen + ! runoff calculation above - where frozen runoff is always set to the outlet + src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsub(nr,nt) + TRunoff%qsur(nr,nt) + TRunoff%qgwl(nr,nt) + TRunoff%qsub(nr,nt) = 0._r8 + TRunoff%qsur(nr,nt) = 0._r8 + TRunoff%qgwl(nr,nt) = 0._r8 + end if + enddo + enddo + + call ESMF_FieldSMM(Tunit%srcfield, Tunit%dstfield, Tunit%rh_direct, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !--- copy direct transfer water to output field --- + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + do nt = 1,ntracers + ctl%direct(nr,nt) = ctl%direct(nr,nt) + dst_direct(nt,cnt) + enddo + enddo + endif + call t_stopf('mosartr_SMdirect') + + !----------------------------------- + ! mosart Subcycling + !----------------------------------- + + call t_startf('mosartr_subcycling') + + if (first_call .and. mainproc) then + do nt = 1,ntracers + write(iulog,'(2a,i6,l4)') trim(subname),' euler_calc for nt = ',nt,Tunit%euler_calc(nt) + enddo + endif + + nsub = coupling_period/delt_mosart + if (nsub*delt_mosart < coupling_period) then + nsub = nsub + 1 + end if + delt = delt_coupling/float(nsub) + if (delt /= delt_save) then + if (mainproc) then + write(iulog,'(2a,2g20.12,2i12)') trim(subname),' mosart delt update from/to',& + delt_save,delt,nsub_save,nsub + end if + endif + + nsub_save = nsub + delt_save = delt + Tctl%DeltaT = delt + + !----------------------------------- + ! mosart euler solver + !----------------------------------- + + ! convert TRunoff fields from m3/s to m/s before calling Euler + do nt = 1,ntracers + do nr = begr,endr + TRunoff%qsur(nr,nt) = TRunoff%qsur(nr,nt) / ctl%area(nr) + TRunoff%qsub(nr,nt) = TRunoff%qsub(nr,nt) / ctl%area(nr) + TRunoff%qgwl(nr,nt) = TRunoff%qgwl(nr,nt) / ctl%area(nr) + enddo + enddo + + ! Subcycle the call to Euler + call t_startf('mosartr_euler') + ctl%flow = 0._r8 + ctl%erout_prev = 0._r8 + ctl%eroutup_avg = 0._r8 + ctl%erlat_avg = 0._r8 + do ns = 1,nsub + ! solve the ODEs with Euler algorithm + call Euler(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! accumulate local flow field + do nt = 1,ntracers + do nr = begr,endr + ctl%flow(nr,nt) = ctl%flow(nr,nt) + TRunoff%flow(nr,nt) + ctl%erout_prev(nr,nt) = ctl%erout_prev(nr,nt) + TRunoff%erout_prev(nr,nt) + ctl%eroutup_avg(nr,nt) = ctl%eroutup_avg(nr,nt) + TRunoff%eroutup_avg(nr,nt) + ctl%erlat_avg(nr,nt) = ctl%erlat_avg(nr,nt) + TRunoff%erlat_avg(nr,nt) + enddo + enddo + enddo ! nsub + call t_stopf('mosartr_euler') + + ! average flow over subcycling + ctl%flow = ctl%flow / float(nsub) + ctl%erout_prev = ctl%erout_prev / float(nsub) + ctl%eroutup_avg = ctl%eroutup_avg / float(nsub) + ctl%erlat_avg = ctl%erlat_avg / float(nsub) + + ! update states when subsycling completed + ctl%runoff = 0._r8 + ctl%runofflnd = spval + ctl%runoffocn = spval + ctl%dvolrdt = 0._r8 + ctl%dvolrdtlnd = spval + ctl%dvolrdtocn = spval + do nt = 1,ntracers + do nr = begr,endr + volr_init = ctl%volr(nr,nt) + ctl%volr(nr,nt) = (TRunoff%wt(nr,nt) + TRunoff%wr(nr,nt) + TRunoff%wh(nr,nt)*ctl%area(nr)) + ctl%dvolrdt(nr,nt) = (ctl%volr(nr,nt) - volr_init) / delt_coupling + ctl%runoff(nr,nt) = ctl%flow(nr,nt) + ctl%runofftot(nr,nt) = ctl%direct(nr,nt) + if (ctl%mask(nr) == 1) then + ctl%runofflnd(nr,nt) = ctl%runoff(nr,nt) + ctl%dvolrdtlnd(nr,nt)= ctl%dvolrdt(nr,nt) + elseif (ctl%mask(nr) >= 2) then + ctl%runoffocn(nr,nt) = ctl%runoff(nr,nt) + ctl%runofftot(nr,nt) = ctl%runofftot(nr,nt) + ctl%runoff(nr,nt) + ctl%dvolrdtocn(nr,nt)= ctl%dvolrdt(nr,nt) + endif + enddo + enddo + + ! final update from glc input + do nr = begr,endr + ctl%runofftot(nr,nt_liq) = ctl%runofftot(nr,nt_liq) + ctl%direct_glc(nr,nt_liq) + ctl%runofftot(nr,nt_ice) = ctl%runofftot(nr,nt_ice) + ctl%direct_glc(nr,nt_ice) + end do + + call t_stopf('mosartr_subcycling') + + !----------------------------------- + ! BUDGET + !----------------------------------- + if (budget_check) then + call t_startf('mosartr_budgetcheck') + call budget%check_budget(begr,endr,ntracers,delt_coupling) + call t_stopf('mosartr_budgetcheck') + endif + + !----------------------------------- + ! Write out mosart history file + !----------------------------------- + + call t_startf('mosartr_hbuf') + call mosart_histflds_set(ntracers) + call mosart_hist_updatehbuf() + call t_stopf('mosartr_hbuf') + + call t_startf('mosartr_htapes') + call mosart_hist_htapeswrapup( rstwr, nlend ) + call t_stopf('mosartr_htapes') + + !----------------------------------- + ! Write out mosart restart file + !----------------------------------- + + if (rstwr) then + call t_startf('mosartr_rest') + filer = mosart_rest_filename(rdate=rdate) + call mosart_rest_filewrite( filer, rdate=rdate ) + call t_stopf('mosartr_rest') + end if + + !----------------------------------- + ! Done + !----------------------------------- + + first_call = .false. + + call t_stopf('mosartr_tot') + + end subroutine mosart_run + +end module mosart_driver diff --git a/src/riverroute/mosart_fileutils.F90 b/src/riverroute/mosart_fileutils.F90 new file mode 100644 index 0000000..f50032d --- /dev/null +++ b/src/riverroute/mosart_fileutils.F90 @@ -0,0 +1,92 @@ +module mosart_fileutils + + ! Module containing file I/O utilities + + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod, only : CL=>shr_kind_cl + use mosart_vars , only : iulog, mainproc + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS: + public :: get_filename !Returns filename given full pathname + public :: getfil !Obtain local copy of file + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + character(len=CL) function get_filename (fulpath) + + ! Returns filename given full pathname + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: fulpath !full pathname + ! + ! !LOCAL VARIABLES: + integer i !loop index + integer klen !length of fulpath character string + !---------------------------------------------------------- + + klen = len_trim(fulpath) + do i = klen, 1, -1 + if (fulpath(i:i) == '/') go to 10 + end do + i = 0 +10 get_filename = fulpath(i+1:klen) + + end function get_filename + + !------------------------------------------------------------------------ + + subroutine getfil (fulpath, locfn, iflag) + + ! Obtain local copy of file. First check current working directory, + ! Next check full pathname[fulpath] on disk + ! + ! !ARGUMENTS: + character(len=*), intent(in) :: fulpath !Archival or permanent disk full pathname + character(len=*), intent(out) :: locfn !output local file name + integer, intent(in) :: iflag !0=>abort if file not found 1=>do not abort + + ! !LOCAL VARIABLES: + integer i !loop index + logical lexist !true if local file exists + !-------------------------------------------------- + + ! get local file name from full name + locfn = get_filename( fulpath ) + if (len_trim(locfn) == 0) then + if (mainproc) write(iulog,*)'(GETFIL): local filename has zero length' + call shr_sys_abort() + else + if (mainproc) write(iulog,*)'(GETFIL): attempting to find local file ',trim(locfn) + endif + + ! first check if file is in current working directory. + inquire (file=locfn,exist=lexist) + if (lexist) then + if (mainproc) write(iulog,*) '(GETFIL): using ',trim(locfn),' in current working directory' + RETURN + endif + + ! second check for full pathname on disk + locfn = fulpath + + inquire (file=fulpath,exist=lexist) + if (lexist) then + if (mainproc) write(iulog,*) '(GETFIL): using ',trim(fulpath) + RETURN + else + if (mainproc) write(iulog,*)'(GETFIL): failed getting file from full path: ', fulpath + if (iflag==0) then + call shr_sys_abort ('GETFIL: FAILED to get '//trim(fulpath)) + else + RETURN + endif + endif + + end subroutine getfil + +end module mosart_fileutils diff --git a/src/riverroute/mosart_histfile.F90 b/src/riverroute/mosart_histfile.F90 new file mode 100644 index 0000000..316a5a3 --- /dev/null +++ b/src/riverroute/mosart_histfile.F90 @@ -0,0 +1,1741 @@ +module mosart_histfile + + ! Module containing methods to for MOSART history file handling. + + use shr_kind_mod, only : r8 => shr_kind_r8, CS => shr_kind_cs, CL => shr_kind_cl + use shr_sys_mod, only : shr_sys_abort + use shr_log_mod, only : errMsg => shr_log_errMsg + use mosart_vars, only : spval, ispval, secspday, frivinp, & + iulog, nsrest, caseid, inst_suffix, nsrStartup, nsrBranch, & + ctitle, version, hostname, username, conventions, source, & + model_doi_url, mainproc, isecspday + use mosart_data, only : ctl, Tunit + use mosart_fileutils, only : get_filename, getfil + use mosart_timemanager, only : get_nstep, get_curr_date, get_curr_time, get_ref_date, & + get_prev_time, get_prev_date, get_step_size, & + get_calendar, NO_LEAP_C, GREGORIAN_C + use pio, only : file_desc_t, var_desc_t + use mosart_io, only : ncd_pio_createfile, ncd_putatt, ncd_global, ncd_defdim, ncd_defvar, & + ncd_io, ncd_enddef, ncd_pio_closefile, ncd_pio_openfile, & + ncd_inqvid, ncd_inqdlen, ncd_nowrite, ncd_write, & + ncd_double, ncd_float, ncd_int, ncd_char, ncd_log, ncd_unlimited, & + ncd_getdatetime + + implicit none + private + + ! Constants + integer , public, parameter :: max_tapes = 3 ! max number of history tapes + integer , public, parameter :: max_flds = 1500 ! max number of history fields + integer , public, parameter :: max_namlen = CS ! maximum number of characters for field name + + ! Counters + integer , public :: ntapes = 0 ! index of max history file requested + + ! Namelist + integer :: ni + integer, public :: ndens(max_tapes) = 1 ! namelist: output density of netcdf history files + integer, public :: mfilt(max_tapes) = 30 ! namelist: number of time samples per tape + integer, public :: nhtfrq(max_tapes) = (/0, -24, -24/) ! namelist: history write freq(0=monthly) + character(len=1), public :: avgflag_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape averaging flag + + ! list of fields to add + character(len=max_namlen+2), public :: fincl1(max_flds) = ' ' + character(len=max_namlen+2), public :: fincl2(max_flds) = ' ' + character(len=max_namlen+2), public :: fincl3(max_flds) = ' ' + + ! time_period_freq variable + character(len=max_namlen+2), public :: time_period_freq = ' ' + + ! list of fields to remove + character(len=max_namlen+2), public :: fexcl1(max_flds) = ' ' + character(len=max_namlen+2), public :: fexcl2(max_flds) = ' ' + character(len=max_namlen+2), public :: fexcl3(max_flds) = ' ' + + ! equivalence list of fields to add/remove + character(len=max_namlen+2), public :: fexcl(max_flds,max_tapes) + character(len=max_namlen+2), public :: fincl(max_flds,max_tapes) + + ! Restart + logical, private :: if_close(max_tapes) ! true => save history file + + ! public member functions: + public :: mosart_hist_Addfld ! Add a field to the master field list + public :: mosart_hist_Printflds ! Print summary of master field list + public :: mosart_hist_HtapesBuild ! Initialize history file handler for initial or continue run + public :: mosart_hist_UpdateHbuf ! Updates history buffer for all fields and tapes + public :: mosart_hist_HtapesWrapup ! Write history tape(s) + public :: mosart_hist_Restart ! read/write history file restart data + + ! private member functions: + private :: htapes_fieldlist ! Define the contents of each history file based on namelist + private :: htape_addfld ! Add a field to the active list for a history tape + private :: htape_create ! Define contents of history file t + private :: htape_timeconst ! Write time constant values to history tape + private :: set_hist_filename ! Determine history dataset filenames + private :: list_index ! Find index of field in exclude list + private :: getname ! Retrieve name portion of input "inname" + private :: getflag ! Retrieve flag + private :: max_nFields ! The max number of fields on any tape + + ! !PRIVATE TYPES: + ! Constants + ! + integer, parameter :: max_length_filename = CL + integer, parameter :: max_chars = CL + ! + ! Subscript dimensions + ! + integer, parameter :: max_subs = 100 ! max number of subscripts + character(len=32) :: subs_name(max_subs) ! name of subscript + integer :: subs_dim(max_subs) ! dimension of subscript + ! + ! Derived types + ! + type field_info + character(len=max_namlen) :: name ! field name + character(len=max_chars) :: long_name ! long name + character(len=max_chars) :: units ! units + integer :: hpindex ! history pointer index + end type field_info + + type master_entry + type (field_info) :: field ! field information + logical :: actflag(max_tapes) ! active/inactive flag + character(len=1) :: avgflag(max_tapes) ! time averaging flag ("X","A","M" or "I",) + end type master_entry + + type history_entry + type (field_info) :: field ! field information + character(len=1) :: avgflag ! time averaging flag + real(r8), pointer :: hbuf(:) ! history buffer (dimensions: dim1d x 1) + integer , pointer :: nacs(:) ! accumulation counter (dimensions: dim1d x 1) + end type history_entry + + type history_tape + integer :: nflds ! number of active fields on tape + integer :: ntimes ! current number of time samples on tape + integer :: mfilt ! maximum number of time samples per tape + integer :: nhtfrq ! number of time samples per tape + integer :: ncprec ! netcdf output precision + logical :: is_endhist ! true => current time step is end of history interval + real(r8) :: begtime ! time at beginning of history averaging interval + type (history_entry) :: hlist(max_flds) ! array of active history tape entries + end type history_tape + + type mosart_pointer ! Pointer to real scalar data (1D) + real(r8), pointer :: ptr(:) + end type mosart_pointer + + ! Pointers + integer, parameter :: max_mapflds = 1500 ! Maximum number of fields to track + type (mosart_pointer) :: ptr(max_mapflds) ! Real scalar data (1D) + + ! Master list: an array of master_entry entities + type (master_entry) :: masterlist(max_flds) ! master field list + + ! History tape: an array of history_tape entities (only active fields) + type (history_tape) :: tape(max_tapes) ! array history tapes + + ! Namelist input + + ! Counters + integer :: nfmaster = 0 ! number of fields in master field list + + ! Other variables + character(len=max_length_filename) :: locfnh(max_tapes) ! local history file names + character(len=max_chars) :: locfnhr(max_tapes) ! local history restart file names + logical :: htapes_defined = .false. ! flag indicates history contents have been defined + + ! NetCDF Id's + type(file_desc_t), target :: nfid(max_tapes) ! file ids + type(file_desc_t), target :: ncid_hist(max_tapes) ! file ids for history restart files + integer :: time_dimid ! time dimension id + integer :: hist_interval_dimid ! time bounds dimension id + integer :: strlen_dimid ! string dimension id + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + + subroutine mosart_hist_Printflds() + + ! Print summary of master field list. + + ! !LOCAL VARIABLES: + integer nf + character(len=*),parameter :: subname = 'mosart_hist_printflds' + + if (mainproc) then + write(iulog,*) trim(subname),' : number of master fields = ',nfmaster + write(iulog,*)' ******* MASTER FIELD LIST *******' + do nf = 1,nfmaster + write(iulog,9000)nf, masterlist(nf)%field%name, masterlist(nf)%field%units +9000 format (i5,1x,a32,1x,a16) + end do + end if + + end subroutine mosart_hist_Printflds + + !----------------------------------------------------------------------- + + subroutine mosart_hist_HtapesBuild () + + ! Initialize ntapes history file for initial or branch run. + + ! !LOCAL VARIABLES: + integer :: i ! index + integer :: ier ! error code + integer :: t, f ! tape, field indices + integer :: day, sec ! day and seconds from base date + character(len=1) :: avgflag ! lcl equiv of avgflag_pertape(t) + character(len=*),parameter :: subname = 'hist_htapes_build' + !---------------------------------------------------------- + + if (mainproc) then + write(iulog,*) trim(subname),' Initializing MOSART history files' + write(iulog,'(72a1)') ("-",i=1,60) + endif + + ! Override averaging flag for all fields on a particular tape + ! if namelist input so specifies + + do t=1,max_tapes + if (avgflag_pertape(t) /= ' ') then + avgflag = avgflag_pertape(t) + do f = 1,nfmaster + select case (avgflag) + case ('A') + masterlist(f)%avgflag(t) = avgflag + case ('I') + masterlist(f)%avgflag(t) = avgflag + case ('X') + masterlist(f)%avgflag(t) = avgflag + case ('M') + masterlist(f)%avgflag(t) = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=',avgflag + call shr_sys_abort () + end select + end do + end if + end do + + fincl(:,1) = fincl1(:) + fincl(:,2) = fincl2(:) + fincl(:,3) = fincl3(:) + + fexcl(:,1) = fexcl1(:) + fexcl(:,2) = fexcl2(:) + fexcl(:,3) = fexcl3(:) + + ! Define field list information for all history files. + ! Update ntapes to reflect number of active history files + ! Note - branch runs can have additional auxiliary history files declared + + call htapes_fieldlist() + + ! Set number of time samples in each history file and + ! Note - the following entries will be overwritten by history restart + ! Note - with netcdf, only 1 (ncd_double) and 2 (ncd_float) are allowed + + do t=1,ntapes + tape(t)%ntimes = 0 + tape(t)%nhtfrq = nhtfrq(t) + tape(t)%mfilt = mfilt(t) + if (ndens(t) == 1) then + tape(t)%ncprec = ncd_double + else + tape(t)%ncprec = ncd_float + endif + end do + + ! Set time of beginning of current averaging interval + ! First etermine elapased time since reference date + call get_prev_time(day, sec) + do t=1,ntapes + tape(t)%begtime = day + sec/secspday + end do + + if (mainproc) then + write(iulog,*) trim(subname),' Successfully initialized MOSART history files' + write(iulog,'(72a1)') ("-",i=1,60) + endif + + end subroutine mosart_hist_HtapesBuild + + !----------------------------------------------------------------------- + + subroutine htapes_fieldlist() + + ! Define the contents of each history file based on namelist + ! input for initial or branch run, and restart data if a restart run. + ! Use arrays fincl and fexcl to modify default history tape contents. + ! Then sort the result alphanumerically. + + ! !LOCAL VARIABLES: + integer :: t, f ! tape, field indices + integer :: ff ! index into include, exclude and fprec list + character(len=max_namlen) :: name ! field name portion of fincl (i.e. no avgflag separator) + character(len=max_namlen) :: mastername ! name from masterlist field + character(len=1) :: avgflag ! averaging flag + character(len=1) :: prec_acc ! history buffer precision flag + character(len=1) :: prec_wrt ! history buffer write precision flag + type (history_entry) :: tmp ! temporary used for swapping + character(len=*),parameter :: subname = 'htapes_fieldlist' + !--------------------------------------------------------- + + ! First ensure contents of fincl and fexcl are valid names + do t = 1,max_tapes + f = 1 + do while (f < max_flds .and. fincl(f,t) /= ' ') + name = getname (fincl(f,t)) !namelist + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (name == mastername) exit + end do + if (name /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', trim(name), ' in fincl(', f, ') ',& + 'for history tape ',t,' not found' + call shr_sys_abort() + end if + f = f + 1 + end do + + f = 1 + do while (f < max_flds .and. fexcl(f,t) /= ' ') + do ff = 1,nfmaster + mastername = masterlist(ff)%field%name + if (fexcl(f,t) == mastername) exit + end do + if (fexcl(f,t) /= mastername) then + write(iulog,*) trim(subname),' ERROR: ', fexcl(f,t), ' in fexcl(', f, ') ', & + 'for history tape ',t,' not found' + call shr_sys_abort() + end if + f = f + 1 + end do + end do + + tape(:)%nflds = 0 + do t = 1,max_tapes + + ! Loop through the masterlist set of field names and determine if any of those + ! are in the FINCL or FEXCL arrays + ! The call to list_index determines the index in the FINCL or FEXCL arrays + ! that the masterlist field corresponds to + ! Add the field to the tape if specified via namelist (FINCL[1-max_tapes]), + ! or if it is on by default and was not excluded via namelist (FEXCL[1-max_tapes]). + + do f = 1,nfmaster + mastername = masterlist(f)%field%name + call list_index (fincl(1,t), mastername, ff) + if (ff > 0) then + ! if field is in include list, ff > 0 and htape_addfld + ! will not be called for field + avgflag = getflag (fincl(ff,t)) + call htape_addfld (t, f, avgflag) + else + ! find index of field in exclude list + call list_index (fexcl(1,t), mastername, ff) + + ! if field is in exclude list, ff > 0 and htape_addfld + ! will not be called for field + ! if field is not in exclude list, ff =0 and htape_addfld + ! will be called for field (note that htape_addfld will be + ! called below only if field is not in exclude list OR in + ! include list + if (ff == 0 .and. masterlist(f)%actflag(t)) then + call htape_addfld (t, f, ' ') + end if + end if + end do + + ! Specification of tape contents now complete. + ! Sort each list of active entries + + do f = tape(t)%nflds-1,1,-1 + do ff = 1,f + if (tape(t)%hlist(ff)%field%name > tape(t)%hlist(ff+1)%field%name) then + tmp = tape(t)%hlist(ff) + tape(t)%hlist(ff ) = tape(t)%hlist(ff+1) + tape(t)%hlist(ff+1) = tmp + else if (tape(t)%hlist(ff)%field%name == tape(t)%hlist(ff+1)%field%name) then + write(iulog,*) trim(subname),' ERROR: Duplicate field ', & + tape(t)%hlist(ff)%field%name, & + 't,ff,name=',t,ff,tape(t)%hlist(ff+1)%field%name + call shr_sys_abort() + end if + end do + end do + + if (mainproc) then + if (tape(t)%nflds > 0) then + write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds + end if + do f = 1,tape(t)%nflds + write(iulog,*) f,' ',tape(t)%hlist(f)%field%name,' ',tape(t)%hlist(f)%avgflag + end do + end if + end do + + ! Determine total number of active history tapes + + ntapes = 0 + do t = max_tapes,1,-1 + if (tape(t)%nflds > 0) then + ntapes = t + exit + end if + end do + + ! Ensure there are no "holes" in tape specification, i.e. empty tapes. + ! Enabling holes should not be difficult if necessary. + + do t = 1,ntapes + if (tape(t)%nflds == 0) then + write(iulog,*) trim(subname),' ERROR: Tape ',t,' is empty' + call shr_sys_abort() + end if + end do + + ! Check that the number of history files declared does not exceed + ! the maximum allowed. + + if (ntapes > max_tapes) then + write(iulog,*) trim(subname),' ERROR: Too many history files declared, max_tapes=',max_tapes + call shr_sys_abort() + end if + + if (mainproc) then + write(iulog,*) 'There will be a total of ',ntapes,'MOSART history tapes' + do t=1,ntapes + write(iulog,*) + if (nhtfrq(t) == 0) then + write(iulog,*)'MOSART History tape ',t,' write frequency is MONTHLY' + else + write(iulog,*)'MOSART History tape ',t,' write frequency = ',nhtfrq(t) + endif + write(iulog,*)'Number of time samples on MOSART history tape ',t,' is ',mfilt(t) + write(iulog,*)'Output precision on MOSART history tape ',t,'=',ndens(t) + write(iulog,*) + end do + end if + + ! Set flag indicating h-tape contents are now defined + + htapes_defined = .true. + + end subroutine htapes_fieldlist + + !----------------------------------------------------------------------- + + subroutine htape_addfld (t, f, avgflag) + + ! Add a field to the active list for a history tape. Copy the data from + ! the master field list to the active list for the tape. + + ! !ARGUMENTS: + integer, intent(in) :: t ! history tape index + integer, intent(in) :: f ! field index from master field list + character(len=1), intent(in) :: avgflag ! time averaging flag + + ! !LOCAL VARIABLES: + integer :: n ! field index on defined tape + integer :: begr ! per-proc beginning land runoff index + integer :: endr ! per-proc ending land runoff index + character(len=1) :: avgflag_temp ! local copy of avgflag_pertape(t) + character(len=*),parameter :: subname = 'htape_addfld' + !------------------------------------------------------- + + ! Ensure that it is not to late to add a field to the history tape + if (htapes_defined) then + write(iulog,*) trim(subname),' ERROR: attempt to add field ', & + masterlist(f)%field%name, ' after history files are set' + call shr_sys_abort() + end if + + ! Determine bounds + begr = ctl%begr + endr = ctl%endr + + tape(t)%nflds = tape(t)%nflds + 1 + n = tape(t)%nflds + tape(t)%hlist(n)%field = masterlist(f)%field + allocate (tape(t)%hlist(n)%hbuf(begr:endr)) + allocate (tape(t)%hlist(n)%nacs(begr:endr)) + tape(t)%hlist(n)%hbuf(:) = 0._r8 + tape(t)%hlist(n)%nacs(:) = 0 + + ! Set time averaging flag based on masterlist setting or + ! override the default averaging flag with namelist setting + select case (avgflag) + case (' ') + tape(t)%hlist(n)%avgflag = masterlist(f)%avgflag(t) + case ('A','I','X','M') + tape(t)%hlist(n)%avgflag = avgflag + case default + write(iulog,*) trim(subname),' ERROR: unknown avgflag=', avgflag + call shr_sys_abort() + end select + + ! Override this tape's avgflag if nhtfrq == 1 + if (tape(t)%nhtfrq == 1) then ! output is instantaneous + avgflag_pertape(t) = 'I' + end if + ! Override this field's avgflag if the namelist has set this tape to + ! - instantaneous + avgflag_temp = avgflag_pertape(t) + if (avgflag_temp == 'I') then + tape(t)%hlist(n)%avgflag = avgflag_temp + end if + + end subroutine htape_addfld + + !----------------------------------------------------------------------- + + subroutine mosart_hist_UpdateHbuf() + + ! Accumulate (or take min, max, etc. as appropriate) input field + ! into its history buffer for appropriate tapes. + + ! !LOCAL VARIABLES: + integer :: t ! tape index + integer :: f ! field index + integer :: k ! index + integer :: hpindex ! history pointer index + integer :: begr,endr ! beginning and ending indices + character(len=1) :: avgflag ! time averaging flag + real(r8), pointer :: hbuf(:) ! history buffer + integer , pointer :: nacs(:) ! accumulation counter + real(r8), pointer :: field(:) ! 1d pointer field + integer j + character(len=*),parameter :: subname = 'mosart_hist_UpdateHbuf' + !---------------------------------------------------------- + + begr = ctl%begr + endr = ctl%endr + + do t = 1,ntapes + do f = 1,tape(t)%nflds + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + hpindex = tape(t)%hlist(f)%field%hpindex + field => ptr(hpindex)%ptr + + select case (avgflag) + case ('I') ! Instantaneous + do k = begr,endr + if (field(k) /= spval) then + hbuf(k) = field(k) + else + hbuf(k) = spval + end if + nacs(k) = 1 + end do + case ('A') ! Time average + do k = begr,endr + if (field(k) /= spval) then + if (nacs(k) == 0) hbuf(k) = 0._r8 + hbuf(k) = hbuf(k) + field(k) + nacs(k) = nacs(k) + 1 + else + if (nacs(k) == 0) hbuf(k) = spval + end if + end do + case ('X') ! Maximum over time + do k = begr,endr + if (field(k) /= spval) then + if (nacs(k) == 0) hbuf(k) = -1.e50_r8 + hbuf(k) = max( hbuf(k), field(k) ) + else + if (nacs(k) == 0) hbuf(k) = spval + end if + nacs(k) = 1 + end do + case ('M') ! Minimum over time + do k = begr,endr + if (field(k) /= spval) then + if (nacs(k) == 0) hbuf(k) = +1.e50_r8 + hbuf(k) = min( hbuf(k), field(k) ) + else + if (nacs(k) == 0) hbuf(k) = spval + end if + nacs(k) = 1 + end do + case default + write(iulog,*) trim(subname),' ERROR: invalid time averaging flag ', avgflag + call shr_sys_abort() + end select + end do + end do + + end subroutine mosart_hist_UpdateHbuf + + !----------------------------------------------------------------------- + + subroutine htape_create (t, histrest) + + ! Define contents of history file t. Issue the required netcdf + ! wrapper calls to define the history file contents. + + ! !ARGUMENTS: + integer, intent(in) :: t ! tape index + logical, intent(in), optional :: histrest ! if creating the history restart file + + ! !LOCAL VARIABLES: + integer :: f ! field index + integer :: p,c,l,n ! indices + integer :: ier ! error code + integer :: dimid ! dimension id temporary + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: ndims ! dimension counter + integer :: omode ! returned mode from netCDF call + integer :: ncprec ! output netCDF write precision + integer :: ret ! netCDF error status + integer :: dtime ! timestep size + integer :: sec_hist_nhtfrq ! nhtfrq converted to seconds + logical :: lhistrest ! local history restart flag + type(file_desc_t), pointer :: lnfid ! local file id + character(len= 8) :: curdate ! current date + character(len= 8) :: curtime ! current time + character(len=CL) :: name ! name of attribute + character(len=CL) :: units ! units of attribute + character(len=CL) :: str ! global attribute string + character(len=*),parameter :: subname = 'htape_create' + !----------------------------------------------------- + + if ( present(histrest) )then + lhistrest = histrest + else + lhistrest = .false. + end if + + ! Define output write precsion for tape + ncprec = tape(t)%ncprec + if (lhistrest) then + lnfid => ncid_hist(t) + else + lnfid => nfid(t) + endif + + ! Create new netCDF file. It will be in define mode + if ( .not. lhistrest )then + if (mainproc) then + write(iulog,*) trim(subname),' : Opening netcdf htape ',trim(locfnh(t)) + end if + call ncd_pio_createfile(lnfid, trim(locfnh(t))) + call ncd_putatt(lnfid, ncd_global, 'title', 'MOSART History file information' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "NOTE: None of the variables are weighted by land fraction!" ) + else + if (mainproc) then + write(iulog,*) trim(subname),' : Opening netcdf rhtape ',trim(locfnhr(t)) + end if + call ncd_pio_createfile(lnfid, trim(locfnhr(t))) + call ncd_putatt(lnfid, ncd_global, 'title', & + 'MOSART Restart History information, required to continue a simulation' ) + call ncd_putatt(lnfid, ncd_global, 'comment', & + "This entire file NOT needed for startup or branch simulations") + end if + + ! Create global attributes. Attributes are used to store information + ! about the data set. Global attributes are information about the + ! data set as a whole, as opposed to a single variable + + call ncd_putatt(lnfid, ncd_global, 'Conventions', trim(conventions)) + call ncd_getdatetime(curdate, curtime) + str = 'created on ' // curdate // ' ' // curtime + call ncd_putatt(lnfid, ncd_global, 'history' , trim(str)) + call ncd_putatt(lnfid, ncd_global, 'source' , trim(source)) + call ncd_putatt(lnfid, ncd_global, 'hostname' , trim(hostname)) + call ncd_putatt(lnfid, ncd_global, 'username' , trim(username)) + call ncd_putatt(lnfid, ncd_global, 'version' , trim(version)) + call ncd_putatt(lnfid, ncd_global, 'model_doi_url', trim(model_doi_url)) + + call ncd_putatt(lnfid, ncd_global, 'case_title', trim(ctitle)) + call ncd_putatt(lnfid, ncd_global, 'case_id', trim(caseid)) + + str = get_filename(frivinp) + call ncd_putatt(lnfid, ncd_global, 'input_dataset', trim(str)) + + ! + ! add global attribute time_period_freq + ! + if (nhtfrq(t) < 0) then !hour need to convert to seconds + sec_hist_nhtfrq = abs(nhtfrq(t))*3600 + else + sec_hist_nhtfrq = nhtfrq(t) + end if + + dtime = get_step_size() + if (sec_hist_nhtfrq == 0) then !month + time_period_freq = 'month_1' + else if (mod(sec_hist_nhtfrq*dtime,isecspday) == 0) then ! day + write(time_period_freq,999) 'day_',sec_hist_nhtfrq*dtime/isecspday + else if (mod(sec_hist_nhtfrq*dtime,3600) == 0) then ! hour + write(time_period_freq,999) 'hour_',(sec_hist_nhtfrq*dtime)/3600 + else if (mod(sec_hist_nhtfrq*dtime,60) == 0) then ! minute + write(time_period_freq,999) 'minute_',(sec_hist_nhtfrq*dtime)/60 + else ! second + write(time_period_freq,999) 'second_',sec_hist_nhtfrq*dtime + end if +999 format(a,i0) + + call ncd_putatt(lnfid, ncd_global, 'time_period_freq', trim(time_period_freq)) + + ! Define dimensions. + ! Time is an unlimited dimension. Character string is treated as an array of characters. + + ! Global uncompressed dimensions (including non-land points) + call ncd_defdim(lnfid, 'lon' , ctl%nlon , dimid) + call ncd_defdim(lnfid, 'lat' , ctl%nlat , dimid) + call ncd_defdim(lnfid, 'allrof', ctl%numr , dimid) + call ncd_defdim(lnfid, 'string_length', 8, strlen_dimid) + + if ( .not. lhistrest )then + call ncd_defdim(lnfid, 'hist_interval', 2, hist_interval_dimid) + call ncd_defdim(lnfid, 'time', ncd_unlimited, time_dimid) + if (mainproc)then + write(iulog,*) trim(subname),' : Successfully defined netcdf history file ',t + end if + else + if (mainproc)then + write(iulog,*) trim(subname),' : Successfully defined netcdf restart history file ',t + end if + end if + + end subroutine htape_create + + !----------------------------------------------------------------------- + + subroutine htape_timeconst(t, mode) + + ! Write time constant values to primary history tape. + + ! !ARGUMENTS: + integer, intent(in) :: t ! tape index + character(len=*), intent(in) :: mode ! 'define' or 'write' + + ! !LOCAL VARIABLES: + integer :: vid,n,i,j,m ! indices + integer :: nstep ! current step + integer :: mcsec ! seconds of current date + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcdate ! current date + integer :: dtime ! timestep size + integer :: yr,mon,day,nbsec ! year,month,day,seconds components of a date + integer :: hours,minutes,secs ! hours,minutes,seconds of hh:mm:ss + character(len= 12) :: step_or_bounds ! string used in long_name of several time variables + character(len= 10) :: basedate ! base date (yyyymmdd) + character(len= 8) :: basesec ! base seconds + character(len= 8) :: cdate ! system date + character(len= 8) :: ctime ! system time + real(r8):: time ! current time + real(r8):: timedata(2) ! time interval boundaries + integer :: dim1id(1) ! netCDF dimension id + integer :: dim2id(2) ! netCDF dimension id + integer :: varid ! netCDF variable id + type(Var_desc_t) :: vardesc ! netCDF variable description + character(len=max_chars) :: long_name ! variable long name + character(len=max_namlen):: varname ! variable name + character(len=max_namlen):: units ! variable units + character(len=max_namlen):: cal ! calendar type from time-manager + character(len=max_namlen):: caldesc ! calendar description to put on file + character(len=CL):: str ! global attribute string + integer :: status + character(len=*),parameter :: subname = 'htape_timeconst' + !-------------------------------------------------------- + + ! For define mode -- only do this for first time-sample + if (mode == 'define' .and. tape(t)%ntimes == 1) then + + call get_ref_date(yr, mon, day, nbsec) + nstep = get_nstep() + hours = nbsec / 3600 + minutes = (nbsec - hours*3600) / 60 + secs = (nbsec - hours*3600 - minutes*60) + write(basedate,80) yr,mon,day +80 format(i4.4,'-',i2.2,'-',i2.2) + write(basesec ,90) hours, minutes, secs +90 format(i2.2,':',i2.2,':',i2.2) + + dim1id(1) = time_dimid + str = 'days since ' // basedate // " " // basesec + if (tape(t)%hlist(1)%avgflag /= 'I') then ! NOT instantaneous fields tape + step_or_bounds = 'time_bounds' + long_name = 'time at exact middle of ' // step_or_bounds + call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & + long_name=long_name, units=str) + call ncd_putatt(nfid(t), varid, 'bounds', 'time_bounds') + else ! instantaneous fields tape + step_or_bounds = 'time step' + long_name = 'time at end of ' // step_or_bounds + call ncd_defvar(nfid(t), 'time', tape(t)%ncprec, 1, dim1id, varid, & + long_name=long_name, units=str) + end if + cal = get_calendar() + if ( trim(cal) == NO_LEAP_C )then + caldesc = "noleap" + else if ( trim(cal) == GREGORIAN_C )then + caldesc = "gregorian" + end if + call ncd_putatt(nfid(t), varid, 'calendar', caldesc) + + dim1id(1) = time_dimid + long_name = 'current date (YYYYMMDD) at end of ' // step_or_bounds + call ncd_defvar(nfid(t) , 'mcdate', ncd_int, 1, dim1id , varid, & + long_name = long_name) + long_name = 'current seconds of current date at end of ' // step_or_bounds + call ncd_defvar(nfid(t) , 'mcsec' , ncd_int, 1, dim1id , varid, & + long_name = long_name, units='s') + long_name = 'current day (from base day) at end of ' // step_or_bounds + call ncd_defvar(nfid(t) , 'mdcur' , ncd_int, 1, dim1id , varid, & + long_name = long_name) + long_name = 'current seconds of current day at end of ' // step_or_bounds + call ncd_defvar(nfid(t) , 'mscur' , ncd_int, 1, dim1id , varid, & + long_name = long_name) + call ncd_defvar(nfid(t) , 'nstep' , ncd_int, 1, dim1id , varid, & + long_name = 'time step') + + dim2id(1) = hist_interval_dimid; dim2id(2) = time_dimid + if (tape(t)%hlist(1)%avgflag /= 'I') then ! NOT instantaneous fields tape + call ncd_defvar(nfid(t), 'time_bounds', ncd_double, 2, dim2id, varid, & + long_name = 'history time interval endpoints') + end if + + dim2id(1) = strlen_dimid; dim2id(2) = time_dimid + call ncd_defvar(nfid(t), 'date_written', ncd_char, 2, dim2id, varid) + call ncd_defvar(nfid(t), 'time_written', ncd_char, 2, dim2id, varid) + + call ncd_defvar(varname='lon', xtype=tape(t)%ncprec, dim1name='lon', & + long_name='runoff coordinate longitude', units='degrees_east', ncid=nfid(t)) + call ncd_defvar(varname='lat', xtype=tape(t)%ncprec, dim1name='lat', & + long_name='runoff coordinate latitude', units='degrees_north', ncid=nfid(t)) + call ncd_defvar(varname='mask', xtype=ncd_int, dim1name='lon', dim2name='lat', & + long_name='runoff mask', units='unitless', ncid=nfid(t), ifill_value=ispval) + call ncd_defvar(varname='area', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & + long_name='runoff grid area', units='m2', ncid=nfid(t), fill_value=spval) + call ncd_defvar(varname='areatotal', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & + long_name='basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) + call ncd_defvar(varname='areatotal2', xtype=tape(t)%ncprec, dim1name='lon', dim2name='lat', & + long_name='computed basin upstream areatotal', units='m2', ncid=nfid(t), fill_value=spval) + + else if (mode == 'write') then + + call get_curr_time (mdcur, mscur) + call get_curr_date (yr, mon, day, mcsec) + mcdate = yr*10000 + mon*100 + day + nstep = get_nstep() + + call ncd_io('mcdate', mcdate, 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mcsec' , mcsec , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mdcur' , mdcur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('mscur' , mscur , 'write', nfid(t), nt=tape(t)%ntimes) + call ncd_io('nstep' , nstep , 'write', nfid(t), nt=tape(t)%ntimes) + + timedata(1) = tape(t)%begtime ! beginning time + timedata(2) = mdcur + mscur / secspday ! end time + if (tape(t)%hlist(1)%avgflag /= 'I') then ! NOT instantaneous fields tape + time = (timedata(1) + timedata(2)) * 0.5_r8 + call ncd_io('time_bounds', timedata, 'write', nfid(t), nt=tape(t)%ntimes) + else + time = timedata(2) + end if + call ncd_io('time' , time , 'write', nfid(t), nt=tape(t)%ntimes) + + call ncd_getdatetime (cdate, ctime) + call ncd_io('date_written', cdate, 'write', nfid(t), nt=tape(t)%ntimes) + + call ncd_io('time_written', ctime, 'write', nfid(t), nt=tape(t)%ntimes) + + call ncd_io(varname='lon', data=ctl%rlon, ncid=nfid(t), flag='write') + call ncd_io(varname='lat', data=ctl%rlat, ncid=nfid(t), flag='write') + call ncd_io(flag='write', varname='mask', dim1name='allrof', & + data=ctl%mask, ncid=nfid(t)) + call ncd_io(flag='write', varname='area', dim1name='allrof', & + data=ctl%area, ncid=nfid(t)) + call ncd_io(flag='write', varname='areatotal', dim1name='allrof', & + data=Tunit%areatotal, ncid=nfid(t)) + call ncd_io(flag='write', varname='areatotal2', dim1name='allrof', & + data=Tunit%areatotal2, ncid=nfid(t)) + + endif + + end subroutine htape_timeconst + + !----------------------------------------------------------------------- + + subroutine mosart_hist_HtapesWrapup( rstwr, nlend ) + + ! Write history tape(s) + ! Determine if next time step is beginning of history interval and if so: + ! increment the current time sample counter, open a new history file + ! and if needed (i.e., when ntim = 1), write history data to current + ! history file, reset field accumulation counters to zero. + ! If primary history file is full or at the last time step of the simulation, + ! write restart dataset and close all history fiels. + ! If history file is full or at the last time step of the simulation: + ! close history file + ! and reset time sample counter to zero if file is full. + ! Daily-averaged data for the first day in September are written on + ! date = 00/09/02 with mscur = 0. + ! Daily-averaged data for the first day in month mm are written on + ! date = yyyy/mm/02 with mscur = 0. + ! Daily-averaged data for the 30th day (last day in September) are written + ! on date = 0000/10/01 mscur = 0. + ! Daily-averaged data for the last day in month mm are written on + ! date = yyyy/mm+1/01 with mscur = 0. + + ! !ARGUMENTS: + logical, intent(in) :: rstwr ! true => write restart file this step + logical, intent(in) :: nlend ! true => end of run on this step + + ! !LOCAL VARIABLES: + integer :: begr, endr ! beg and end rof indices + integer :: t,f,k,nt ! indices + integer :: nstep ! current step + integer :: day ! current day (1 -> 31) + integer :: mon ! current month (1 -> 12) + integer :: yr ! current year (0 -> ...) + integer :: mdcur ! current day + integer :: mscur ! seconds of current day + integer :: mcsec ! current time of day [seconds] + integer :: daym1 ! nstep-1 day (1 -> 31) + integer :: monm1 ! nstep-1 month (1 -> 12) + integer :: yrm1 ! nstep-1 year (0 -> ...) + integer :: mcsecm1 ! nstep-1 time of day [seconds] + real(r8):: time ! current time + character(len=CL) :: str ! global attribute string + character(len=1) :: avgflag ! averaging flag + real(r8), pointer :: histo(:) ! temporary + real(r8), pointer :: hbuf(:) ! history buffer + integer , pointer :: nacs(:) ! accumulation counter + character(len=32) :: avgstr ! time averaging type + character(len=max_chars) :: long_name ! long name + character(len=max_chars) :: units ! units + character(len=max_namlen):: varname ! variable name + character(len=*),parameter :: subname = 'hist_htapes_wrapup' + !----------------------------------------------------------- + + begr = ctl%begr + endr = ctl%endr + + ! get current step + nstep = get_nstep() + + ! Set calendar for current time step + call get_curr_date (yr, mon, day, mcsec) + call get_curr_time (mdcur, mscur) + time = mdcur + mscur/secspday + + ! Set calendar for current for previous time step + call get_prev_date (yrm1, monm1, daym1, mcsecm1) + + ! Loop over active history tapes, create new history files if necessary + ! and write data to history files if end of history interval. + do t = 1, ntapes + + ! Determine if end of history interval + tape(t)%is_endhist = .false. + if (tape(t)%nhtfrq==0) then !monthly average + if (mon /= monm1) then + tape(t)%is_endhist = .true. + end if + else + if (mod(nstep,tape(t)%nhtfrq) == 0) then + tape(t)%is_endhist = .true. + end if + end if + + ! If end of history interval + if (tape(t)%is_endhist) then + + ! Normalize by number of accumulations for time averaged case + do f = 1,tape(t)%nflds + avgflag = tape(t)%hlist(f)%avgflag + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + do k = begr, endr + if ((avgflag == 'A') .and. nacs(k) /= 0) then + hbuf(k) = hbuf(k) / float(nacs(k)) + end if + end do + end do + + ! Increment current time sample counter. + tape(t)%ntimes = tape(t)%ntimes + 1 + + ! Create history file if appropriate and build time comment + + ! If first time sample, generate unique history file name, open file, + ! define dims, vars, etc. + + if (tape(t)%ntimes == 1) then + locfnh(t) = set_hist_filename (hist_freq=tape(t)%nhtfrq, & + mfilt=tape(t)%mfilt, hist_file=t) + if (mainproc) then + write(iulog,*) trim(subname),' : Creating history file ', trim(locfnh(t)), & + ' at nstep = ',get_nstep() + write(iulog,*)'calling htape_create for file t = ',t + endif + call htape_create (t) + + ! Define time-constant field variables + call htape_timeconst(t, mode='define') + + ! Define model field variables + + do f = 1,tape(t)%nflds + varname = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + avgflag = tape(t)%hlist(f)%avgflag + + select case (avgflag) + case ('A') + avgstr = 'mean' + case ('I') + avgstr = 'instantaneous' + case ('X') + avgstr = 'maximum' + case ('M') + avgstr = 'minimum' + case default + write(iulog,*) trim(subname),& + ' ERROR: unknown time averaging flag (avgflag)=',avgflag + call shr_sys_abort() + end select + call ncd_defvar(ncid=nfid(t), varname=varname, xtype=tape(t)%ncprec, & + dim1name='lon', dim2name='lat', dim3name='time', & + long_name=long_name, units=units, cell_method=avgstr, & + missing_value=spval, fill_value=spval) + end do + + ! Exit define model + call ncd_enddef(nfid(t)) + + endif + + ! Write time constant history variables + call htape_timeconst(t, mode='write') + + if (mainproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & + trim(locfnh(t)),' at nstep = ',get_nstep(), & + ' for history time interval beginning at ', tape(t)%begtime, & + ' and ending at ',time + write(iulog,*) + endif + + ! Update beginning time of next interval + tape(t)%begtime = time + + ! Write history time slice + do f = 1,tape(t)%nflds + varname = tape(t)%hlist(f)%field%name + nt = tape(t)%ntimes + histo => tape(t)%hlist(f)%hbuf + call ncd_io(flag='write', varname=varname, dim1name='allrof', & + data=histo, ncid=nfid(t), nt=nt) + end do + + ! Zero necessary history buffers + do f = 1,tape(t)%nflds + tape(t)%hlist(f)%hbuf(:) = 0._r8 + tape(t)%hlist(f)%nacs(:) = 0 + end do + + end if + + end do ! end loop over history tapes + + ! Close open history files + ! Auxilary files may have been closed and saved off without being full, + ! must reopen the files + + do t = 1, ntapes + if (nlend) then + if_close(t) = .true. + else if (rstwr) then + if_close(t) = .true. + else + if (tape(t)%ntimes == tape(t)%mfilt) then + if_close(t) = .true. + else + if_close(t) = .false. + end if + endif + if (if_close(t)) then + if (tape(t)%ntimes /= 0) then + if (mainproc) then + write(iulog,*) + write(iulog,*) trim(subname),' : Closing local history file ',& + trim(locfnh(t)),' at nstep = ', get_nstep() + write(iulog,*) + endif + call ncd_pio_closefile(nfid(t)) + if ((.not.nlend) .and. (tape(t)%ntimes/=tape(t)%mfilt)) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + else + if (mainproc) then + write(iulog,*) trim(subname),' : history tape ',t,': no open file to close' + end if + endif + if (tape(t)%ntimes==tape(t)%mfilt) then + tape(t)%ntimes = 0 + end if + endif + end do + + end subroutine mosart_hist_HtapesWrapup + + !----------------------------------------------------------------------- + + subroutine mosart_hist_Restart (ncid, flag, rdate) + + ! Read/write history file restart data. + ! If the current history file(s) are not full, file(s) are opened + ! so that subsequent time samples are added until the file is full. + ! A new history file is used on a branch run. + + ! !ARGUMENTS: + type(file_desc_t), intent(inout) :: ncid ! netcdf file + character(len=*) , intent(in) :: flag !'read' or 'write' + character(len=*) , intent(in), optional :: rdate ! restart file time stamp for name + + ! !LOCAL VARIABLES: + integer :: max_nflds ! max number of fields + integer :: begr ! per-proc beginning ocean runoff index + integer :: endr ! per-proc ending ocean runoff index + character(len=max_namlen) :: name ! variable name + character(len=max_namlen) :: name_acc ! accumulator variable name + character(len=max_namlen) :: long_name ! long name of variable + character(len=max_chars) :: long_name_acc ! long name for accumulator + character(len=max_chars) :: units ! units of variable + character(len=max_chars) :: units_acc ! accumulator units + character(len=max_chars) :: fname ! full name of history file + character(len=max_chars) :: locrest(max_tapes) ! local history restart file names + character(len=1) :: hnum ! history file index + type(var_desc_t) :: name_desc ! variable descriptor for name + type(var_desc_t) :: longname_desc ! variable descriptor for long_name + type(var_desc_t) :: units_desc ! variable descriptor for units + type(var_desc_t) :: avgflag_desc ! variable descriptor for avgflag + integer :: status ! error status + integer :: dimid ! dimension ID + integer :: start(2) ! Start array index + integer :: k ! 1d index + integer :: t ! tape index + integer :: f ! field index + integer :: varid ! variable id + integer, allocatable :: itemp2d(:,:) ! 2D temporary + real(r8), pointer :: hbuf(:) ! history buffer + integer , pointer :: nacs(:) ! accumulation counter + character(len=*),parameter :: subname = 'hist_restart_ncd' + !--------------------------------------------------------- + + ! If branch run, initialize file times and return + + if (flag == 'read') then + if (nsrest == nsrBranch) then + do t = 1,ntapes + tape(t)%ntimes = 0 + end do + RETURN + end if + ! If startup run just return + if (nsrest == nsrStartup) then + RETURN + end if + endif + + ! Read history file data only for restart run (not for branch run) + + ! First when writing out and in define mode, create files and define all variables + !================================================ + if (flag == 'define') then + !================================================ + + if (.not. present(rdate)) then + call shr_sys_abort('variable rdate must be present for writing restart files') + end if + + ! + ! On master restart file add ntapes/max_chars dimension + ! and then add the history and history restart filenames + ! + call ncd_defdim( ncid, 'ntapes' , ntapes , dimid) + call ncd_defdim( ncid, 'max_chars' , max_chars , dimid) + + call ncd_defvar(ncid=ncid, varname='locfnh', xtype=ncd_char, & + long_name="History filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + call ncd_defvar(ncid=ncid, varname='locfnhr', xtype=ncd_char, & + long_name="Restart history filename", & + comment="This variable NOT needed for startup or branch simulations", & + dim1name='max_chars', dim2name="ntapes" ) + + ! max_nflds is the maximum number of fields on any tape + ! max_flds is the maximum number possible number of fields + max_nflds = max_nFields() + + ! Loop over tapes - write out namelist information to each restart-history tape + ! only read/write accumulators and counters if needed + + do t = 1,ntapes + ! + ! Create the restart history filename and open it + ! + write(hnum,'(i1.1)') t-1 + locfnhr(t) = "./" // trim(caseid) //".mosart"// trim(inst_suffix) & + // ".rh" // hnum //"."// trim(rdate) //".nc" + call htape_create( t, histrest=.true. ) + ! + ! Add read/write accumultators and counters if needed + ! + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + long_name = tape(t)%hlist(f)%field%long_name + units = tape(t)%hlist(f)%field%units + name_acc = trim(name) // "_acc" + units_acc = "unitless positive integer" + long_name_acc = trim(long_name) // " accumulator number of samples" + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name), xtype=ncd_double, & + dim1name='lon', dim2name='lat', & + long_name=trim(long_name), units=trim(units)) + call ncd_defvar(ncid=ncid_hist(t), varname=trim(name_acc), xtype=ncd_int, & + dim1name='lon', dim2name='lat', & + long_name=trim(long_name_acc), units=trim(units_acc)) + end do + endif + + ! + ! Add namelist information to each restart history tape + ! + call ncd_defdim( ncid_hist(t), 'fname_lenp2' , max_namlen+2, dimid) + call ncd_defdim( ncid_hist(t), 'fname_len' , max_namlen , dimid) + call ncd_defdim( ncid_hist(t), 'len1' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'scalar' , 1 , dimid) + call ncd_defdim( ncid_hist(t), 'max_chars' , max_chars , dimid) + call ncd_defdim( ncid_hist(t), 'max_nflds' , max_nflds , dimid) + call ncd_defdim( ncid_hist(t), 'max_flds' , max_flds , dimid) + + call ncd_defvar(ncid=ncid_hist(t), varname='nhtfrq', xtype=ncd_int, & + long_name="Frequency of history writes", & + comment="Namelist item", & + units="absolute value of negative is in hours, 0=monthly, positive is time-steps", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='mfilt', xtype=ncd_int, & + long_name="Number of history time samples on a file", units="unitless", & + comment="Namelist item", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ncprec', xtype=ncd_int, & + long_name="Flag for data precision", flag_values=(/1,2/), & + comment="Namelist item", & + nvalid_range=(/1,2/), & + flag_meanings=(/"single-precision", "double-precision"/), & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='fincl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to include", & + dim1name='fname_lenp2', dim2name='max_flds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='fexcl', xtype=ncd_char, & + comment="Namelist item", & + long_name="Fieldnames to exclude", & + dim1name='fname_lenp2', dim2name='max_flds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='nflds', xtype=ncd_int, & + long_name="Number of fields on file", units="unitless", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='ntimes', xtype=ncd_int, & + long_name="Number of time steps on file", units="time-step", & + dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='is_endhist', xtype=ncd_log, & + long_name="End of history file", dim1name='scalar') + call ncd_defvar(ncid=ncid_hist(t), varname='begtime', xtype=ncd_double, & + long_name="Beginning time", units="time units", & + dim1name='scalar') + + call ncd_defvar(ncid=ncid_hist(t), varname='hpindex', xtype=ncd_int, & + long_name="History pointer index", units="unitless", & + dim1name='max_nflds' ) + + call ncd_defvar(ncid=ncid_hist(t), varname='avgflag', xtype=ncd_char, & + long_name="Averaging flag", & + units="A=Average, X=Maximum, M=Minimum, I=Instantaneous", & + dim1name='len1', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='name', xtype=ncd_char, & + long_name="Fieldnames", & + dim1name='fname_len', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='long_name', xtype=ncd_char, & + long_name="Long descriptive names for fields", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_defvar(ncid=ncid_hist(t), varname='units', xtype=ncd_char, & + long_name="Units for each history field output", & + dim1name='max_chars', dim2name='max_nflds' ) + call ncd_enddef(ncid_hist(t)) + + end do ! end of ntapes loop + + RETURN + + !================================================ + else if (flag == 'write') then + !================================================ + ! Add history filenames to master restart file + do t = 1,ntapes + call ncd_io('locfnh', locfnh(t), 'write', ncid, nt=t) + call ncd_io('locfnhr', locfnhr(t), 'write', ncid, nt=t) + end do + + fincl(:,1) = fincl1(:) + fincl(:,2) = fincl2(:) + fincl(:,3) = fincl3(:) + + fexcl(:,1) = fexcl1(:) + fexcl(:,2) = fexcl2(:) + fexcl(:,3) = fexcl3(:) + + max_nflds = max_nFields() + + start(1)=1 + + + ! Add history namelist data to each history restart tape + allocate(itemp2d(max_nflds,ntapes)) + do t = 1,ntapes + call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) + call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) + call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) + call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) + + call ncd_io(varname='fincl' , data=fincl(:,t) , ncid=ncid_hist(t), flag='write') + call ncd_io(varname='fexcl' , data=fexcl(:,t) , ncid=ncid_hist(t), flag='write') + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='write') + + itemp2d(:,:) = 0 + do f=1,tape(t)%nflds + itemp2d(f,t) = tape(t)%hlist(f)%field%hpindex + end do + call ncd_io(varname='hpindex', data=itemp2d(:,t), ncid=ncid_hist(t), flag='write') + + call ncd_io('nflds' , tape(t)%nflds, 'write', ncid_hist(t)) + call ncd_io('ntimes', tape(t)%ntimes, 'write', ncid_hist(t)) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'write', ncid_hist(t)) + call ncd_io('mfilt' , tape(t)%mfilt, 'write', ncid_hist(t)) + call ncd_io('ncprec', tape(t)%ncprec, 'write', ncid_hist(t)) + call ncd_io('begtime', tape(t)%begtime, 'write', ncid_hist(t)) + do f=1,tape(t)%nflds + start(2) = f + call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & + 'write', ncid_hist(t), start ) + call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & + 'write', ncid_hist(t), start ) + call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & + 'write', ncid_hist(t), start ) + call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & + 'write', ncid_hist(t), start ) + end do + end do + deallocate(itemp2d) + + !================================================ + else if (flag == 'read') then + !================================================ + + call ncd_inqdlen(ncid,dimid,ntapes, name='ntapes') + call ncd_io('locfnh', locfnh(1:ntapes), 'read', ncid ) + call ncd_io('locfnhr', locrest(1:ntapes), 'read', ncid ) + do t = 1,ntapes + call strip_null(locrest(t)) + call strip_null(locfnh(t)) + end do + + ! Determine necessary indices - the following is needed if model decomposition + ! is different on restart + begr = ctl%begr + endr = ctl%endr + + start(1)=1 + do t = 1,ntapes + call getfil( locrest(t), locfnhr(t), 0 ) + call ncd_pio_openfile (ncid_hist(t), trim(locfnhr(t)), ncd_nowrite) + + if ( t == 1 )then + call ncd_inqdlen(ncid_hist(1),dimid,max_nflds,name='max_nflds') + allocate(itemp2d(max_nflds,ntapes)) + end if + + call ncd_inqvid(ncid_hist(t), 'name', varid, name_desc) + call ncd_inqvid(ncid_hist(t), 'long_name', varid, longname_desc) + call ncd_inqvid(ncid_hist(t), 'units', varid, units_desc) + call ncd_inqvid(ncid_hist(t), 'avgflag', varid, avgflag_desc) + + call ncd_io(varname='fincl', data=fincl(:,t), ncid=ncid_hist(t), flag='read') + call ncd_io(varname='fexcl', data=fexcl(:,t), ncid=ncid_hist(t), flag='read') + + call ncd_io('nflds', tape(t)%nflds, 'read', ncid_hist(t) ) + call ncd_io('ntimes', tape(t)%ntimes, 'read', ncid_hist(t) ) + call ncd_io('nhtfrq', tape(t)%nhtfrq, 'read', ncid_hist(t) ) + call ncd_io('mfilt', tape(t)%mfilt, 'read', ncid_hist(t) ) + call ncd_io('ncprec', tape(t)%ncprec, 'read', ncid_hist(t) ) + call ncd_io('begtime', tape(t)%begtime,'read', ncid_hist(t) ) + + call ncd_io(varname='is_endhist', data=tape(t)%is_endhist, ncid=ncid_hist(t), flag='read') + call ncd_io(varname='hpindex' , data=itemp2d(:,t) , ncid=ncid_hist(t), flag='read') + do f=1,tape(t)%nflds + tape(t)%hlist(f)%field%hpindex = itemp2d(f,t) + end do + + do f=1,tape(t)%nflds + start(2) = f + call ncd_io( name_desc, tape(t)%hlist(f)%field%name, & + 'read', ncid_hist(t), start ) + call ncd_io( longname_desc, tape(t)%hlist(f)%field%long_name, & + 'read', ncid_hist(t), start ) + call ncd_io( units_desc, tape(t)%hlist(f)%field%units, & + 'read', ncid_hist(t), start ) + call ncd_io( avgflag_desc, tape(t)%hlist(f)%avgflag, & + 'read', ncid_hist(t), start ) + call strip_null(tape(t)%hlist(f)%field%name) + call strip_null(tape(t)%hlist(f)%field%long_name) + call strip_null(tape(t)%hlist(f)%field%units) + call strip_null(tape(t)%hlist(f)%avgflag) + + allocate (tape(t)%hlist(f)%hbuf(begr:endr), & + tape(t)%hlist(f)%nacs(begr:endr), stat=status) + if (status /= 0) then + write(iulog,*) trim(subname),' ERROR: allocation error for hbuf,nacs at t,f=',t,f + call shr_sys_abort() + endif + tape(t)%hlist(f)%hbuf(:) = 0._r8 + tape(t)%hlist(f)%nacs(:) = 0 + end do ! end of flds loop + + ! If history file is not full, open it + + if (tape(t)%ntimes /= 0) then + call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) + end if + + end do ! end of tapes loop + + fincl1(:) = fincl(:,1) + fincl2(:) = fincl(:,2) + fincl3(:) = fincl(:,3) + + fexcl1(:) = fexcl(:,1) + fexcl2(:) = fexcl(:,2) + fexcl3(:) = fexcl(:,3) + + if ( allocated(itemp2d) ) deallocate(itemp2d) + + end if + + ! Read/write history file restart data. + ! If the current history file(s) are not full, file(s) are opened + ! so that subsequent time samples are added until the file is full. + ! A new history file is used on a branch run. + + if (flag == 'write') then + + do t = 1,ntapes + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name), & + dim1name='allrof', data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='write', varname=trim(name_acc), & + dim1name='allrof', data=nacs) + end do + end if ! end of is_endhist block + call ncd_pio_closefile(ncid_hist(t)) + end do ! end of ntapes loop + + else if (flag == 'read') then + + ! Read history restart information if history files are not full + do t = 1,ntapes + if (.not. tape(t)%is_endhist) then + do f = 1,tape(t)%nflds + name = tape(t)%hlist(f)%field%name + name_acc = trim(name) // "_acc" + nacs => tape(t)%hlist(f)%nacs + hbuf => tape(t)%hlist(f)%hbuf + + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name), & + dim1name='allrof', data=hbuf) + call ncd_io(ncid=ncid_hist(t), flag='read', varname=trim(name_acc), & + dim1name='allrof', data=nacs) + end do + end if + call ncd_pio_closefile(ncid_hist(t)) + end do + + end if + + end subroutine mosart_hist_Restart + + !----------------------------------------------------------------------- + + integer function max_nFields() + + ! Get the maximum number of fields on all tapes. + + ! LOCAL VARIABLES: + integer :: t ! index + character(len=*),parameter :: subname = 'max_nFields' + + max_nFields = 0 + do t = 1,ntapes + max_nFields = max(max_nFields, tape(t)%nflds) + end do + + end function max_nFields + + !----------------------------------------------------------------------- + + character(len=max_namlen) function getname (inname) + + ! Retrieve name portion of inname. If an averaging flag separater character + ! is present (:) in inname, lop it off. + + ! ARGUMENTS: + character(len=*), intent(in) :: inname + + integer :: length + integer :: i + character(len=*),parameter :: subname = 'getname' + + length = len (inname) + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call shr_sys_abort() + end if + + getname = ' ' + do i = 1,max_namlen + if (inname(i:i) == ':') exit + getname(i:i) = inname(i:i) + end do + + end function getname + + !----------------------------------------------------------------------- + + character(len=1) function getflag (inname) + + ! Retrieve flag portion of inname. If an averaging flag separater character + ! is present (:) in inname, return the character after it as the flag + + ! ARGUMENTS: + character(len=*) inname ! character string + + ! LOCAL VARIABLES: + integer :: length ! length of inname + integer :: i ! loop index + character(len=*),parameter :: subname = 'getflag' + + length = len (inname) + if (length < max_namlen .or. length > max_namlen+2) then + write(iulog,*) trim(subname),' ERROR: bad length=',length + call shr_sys_abort() + end if + + getflag = ' ' + do i = 1,length + if (inname(i:i) == ':') then + getflag = inname(i+1:i+1) + exit + end if + end do + + end function getflag + + !----------------------------------------------------------------------- + + subroutine list_index (list, name, index) + + ! ARGUMENTS: + character(len=*), intent(in) :: list(max_flds) ! input list of names, possibly ":" delimited + character(len=max_namlen), intent(in) :: name ! name to be searched for + integer, intent(out) :: index ! index of "name" in "list" + + ! !LOCAL VARIABLES: + character(len=max_namlen) :: listname ! input name with ":" stripped off. + integer f ! field index + character(len=*),parameter :: subname = 'list_index' + + ! Only list items + index = 0 + do f=1,max_flds + listname = getname (list(f)) + if (listname == ' ') exit + if (listname == name) then + index = f + exit + end if + end do + + end subroutine list_index + + !----------------------------------------------------------------------- + + character(len=max_length_filename) function set_hist_filename (hist_freq, mfilt, hist_file) + + ! Determine history dataset filenames. + + ! !ARGUMENTS: + integer, intent(in) :: hist_freq !history file frequency + integer, intent(in) :: mfilt !history file number of time-samples + integer, intent(in) :: hist_file !history file index + + ! !LOCAL VARIABLES: + character(len=CL) :: cdate !date char string + character(len= 1) :: hist_index !p,1 or 2 (currently) + integer :: day !day (1 -> 31) + integer :: mon !month (1 -> 12) + integer :: yr !year (0 -> ...) + integer :: sec !seconds into current day + integer :: filename_length + character(len=*),parameter :: subname = 'set_hist_filename' + + if (hist_freq == 0 .and. mfilt == 1) then !monthly + call get_prev_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2)') yr,mon + else !other + call get_curr_date (yr, mon, day, sec) + write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec + endif + write(hist_index,'(i1.1)') hist_file - 1 + set_hist_filename = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//& + ".h"//hist_index//"."//trim(cdate)//".nc" + + ! check to see if the concatenated filename exceeded the + ! length. Simplest way to do this is ensure that the file + ! extension is '.nc'. + filename_length = len_trim(set_hist_filename) + if (set_hist_filename(filename_length-2:filename_length) /= '.nc') then + write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & + ' : expected file extension ".nc", received extension "', & + set_hist_filename(filename_length-2:filename_length), '"' + write(iulog, '(a,a,a,a,a)') 'ERROR: ', subname, & + ' : filename : "', set_hist_filename, '"' + write(iulog, '(a,a,a,i3,a,i3)') 'ERROR: ', subname, & + ' Did the constructed filename exceed the maximum length? : filename length = ', & + filename_length, ', max length = ', max_length_filename + call shr_sys_abort(errMsg(__FILE__, __LINE__)) + end if + end function set_hist_filename + + !------------------------------------------------------------------------ + + subroutine mosart_hist_Addfld (fname, units, avgflag, long_name, ptr_rof, default) + + ! Initialize a single level history field. + + ! !ARGUMENTS: + character(len=*), intent(in) :: fname ! field name + character(len=*), intent(in) :: units ! units of field + character(len=1), intent(in) :: avgflag ! time averaging flag + character(len=*), intent(in) :: long_name ! long name of field + real(r8) , pointer :: ptr_rof(:) ! pointer to channel runoff + character(len=*), optional, intent(in) :: default ! if set to 'inactive, + ! field will not appear on primary tape + + ! !LOCAL VARIABLES: + integer :: n ! loop index + integer :: f ! masterlist index + integer :: hpindex ! history buffer pointer index + logical :: found ! flag indicates field found in masterlist + integer, save :: lastindex = 1 + character(len=*),parameter :: subname = 'mosart_hist_Addfld' + !------------------------------------------------------ + + ! History buffer pointer + + hpindex = lastindex + ptr(hpindex)%ptr => ptr_rof + lastindex = lastindex + 1 + if (lastindex > max_mapflds) then + write(iulog,*) trim(subname),' ERROR: ',& + ' lastindex = ',lastindex,' greater than max_mapflds= ',max_mapflds + call shr_sys_abort() + endif + + ! Add field to masterlist + + if (fname == ' ') then + write(iulog,*) trim(subname),' ERROR: blank field name not allowed' + call shr_sys_abort() + end if + do n = 1,nfmaster + if (masterlist(n)%field%name == fname) then + write(iulog,*) trim(subname),' ERROR:', fname, ' already on list' + call shr_sys_abort() + end if + end do + nfmaster = nfmaster + 1 + f = nfmaster + if (nfmaster > max_flds) then + write(iulog,*) trim(subname),' ERROR: too many fields for primary history file ', & + '-- max_flds,nfmaster=', max_flds, nfmaster + call shr_sys_abort() + end if + masterlist(f)%field%name = fname + masterlist(f)%field%long_name = long_name + masterlist(f)%field%units = units + masterlist(f)%field%hpindex = hpindex + + ! The next two fields are only in master field list, NOT in runtime active field list + ! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE FLAG SET TO FALSE + masterlist(f)%avgflag(:) = avgflag + masterlist(f)%actflag(:) = .false. + + if (present(default)) then + if (trim(default) == 'inactive') return + endif + + ! Look through master list for input field name. + ! When found, set active flag for that tape to true. + found = .false. + do f = 1,nfmaster + if (trim(fname) == trim(masterlist(f)%field%name)) then + masterlist(f)%actflag(1) = .true. + found = .true. + exit + end if + end do + if (.not. found) then + write(iulog,*) trim(subname),' ERROR: field=', fname, ' not found' + call shr_sys_abort() + end if + + end subroutine mosart_hist_Addfld + + !----------------------------------------------------------------------- + + subroutine strip_null(str) + character(len=*), intent(inout) :: str + integer :: i + do i=1,len(str) + if(ichar(str(i:i))==0) str(i:i)=' ' + end do + end subroutine strip_null + +end module mosart_histfile diff --git a/src/riverroute/mosart_histflds.F90 b/src/riverroute/mosart_histflds.F90 new file mode 100644 index 0000000..18534f1 --- /dev/null +++ b/src/riverroute/mosart_histflds.F90 @@ -0,0 +1,203 @@ +module mosart_histflds + + ! Module containing initialization of history fields and files + ! This is the module that the user must modify in order to add new + ! history fields or modify defaults associated with existing history + ! fields. + + use shr_kind_mod , only : r8 => shr_kind_r8 + use mosart_histfile , only : mosart_hist_addfld, mosart_hist_printflds + use mosart_data , only : ctl, Trunoff + + implicit none + private + + public :: mosart_histflds_init + public :: mosart_histflds_set + + type, public :: hist_pointer_type + real(r8), pointer :: data(:) => null() + end type hist_pointer_type + + type(hist_pointer_type), allocatable :: h_runofflnd(:) + type(hist_pointer_type), allocatable :: h_runoffocn(:) + type(hist_pointer_type), allocatable :: h_runofftot(:) + type(hist_pointer_type), allocatable :: h_direct(:) + type(hist_pointer_type), allocatable :: h_direct_glc(:) + type(hist_pointer_type), allocatable :: h_dvolrdtlnd(:) + type(hist_pointer_type), allocatable :: h_dvolrdtocn(:) + type(hist_pointer_type), allocatable :: h_volr(:) + type(hist_pointer_type), allocatable :: h_qsur(:) + type(hist_pointer_type), allocatable :: h_qsub(:) + type(hist_pointer_type), allocatable :: h_qgwl(:) + + real(r8), pointer :: h_volr_mch(:) + real(r8), pointer :: h_qglc_liq_input(:) + real(r8), pointer :: h_qglc_ice_input(:) + +!------------------------------------------------------------------------ +contains +!----------------------------------------------------------------------- + + subroutine mosart_histflds_init(begr, endr, ntracers) + + ! Arguments + integer, intent(in) :: begr + integer, intent(in) :: endr + integer, intent(in) :: ntracers + + ! Local variables + integer :: nt + + !------------------------------------------------------- + ! Allocate memory for module variables + !------------------------------------------------------- + + allocate(h_runofflnd(ntracers)) + allocate(h_runoffocn(ntracers)) + allocate(h_runofftot(ntracers)) + allocate(h_direct(ntracers)) + allocate(h_dvolrdtlnd(ntracers)) + allocate(h_dvolrdtocn(ntracers)) + allocate(h_volr(ntracers)) + allocate(h_qsur(ntracers)) + allocate(h_qsub(ntracers)) + allocate(h_qgwl(ntracers)) + allocate(h_direct_glc(2)) + + do nt = 1,ntracers + allocate(h_runofflnd(nt)%data(begr:endr)) + allocate(h_runoffocn(nt)%data(begr:endr)) + allocate(h_runofftot(nt)%data(begr:endr)) + allocate(h_direct(nt)%data(begr:endr)) + allocate(h_dvolrdtlnd(nt)%data(begr:endr)) + allocate(h_dvolrdtocn(nt)%data(begr:endr)) + allocate(h_volr(nt)%data(begr:endr)) + allocate(h_qsur(nt)%data(begr:endr)) + allocate(h_qsub(nt)%data(begr:endr)) + allocate(h_qgwl(nt)%data(begr:endr)) + end do + allocate(h_direct_glc(ctl%nt_liq)%data(begr:endr)) + allocate(h_direct_glc(ctl%nt_ice)%data(begr:endr)) + + allocate(h_volr_mch(begr:endr)) + allocate(h_qglc_liq_input(begr:endr)) + allocate(h_qglc_ice_input(begr:endr)) + + !------------------------------------------------------- + ! Build master field list of all possible fields in a history file. + ! Each field has associated with it a ``long\_name'' netcdf attribute that + ! describes what the field is, and a ``units'' attribute. A subroutine is + ! called to add each field to the masterlist. + !------------------------------------------------------- + + do nt = 1,ctl%ntracers + + call mosart_hist_addfld (fname='RIVER_DISCHARGE_OVER_LAND'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART river basin flow: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_runofflnd(nt)%data, default='active') + + call mosart_hist_addfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART river discharge into ocean: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_runoffocn(nt)%data, default='active') + + call mosart_hist_addfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART total discharge into ocean: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_runofftot(nt)%data, default='active') + + call mosart_hist_addfld (fname='DIRECT_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_direct(nt)%data, default='active') + + call mosart_hist_addfld (fname='DIRECT_DISCHARGE_TO_OCEAN_GLC'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART direct discharge into ocean from glc: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_direct_glc(nt)%data, default='active') + + call mosart_hist_addfld (fname='STORAGE'//'_'//trim(ctl%tracer_names(nt)), units='m3', & + avgflag='A', long_name='MOSART storage: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_volr(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='DVOLRDT_LND'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART land change in storage: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_dvolrdtlnd(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='DVOLRDT_OCN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART ocean change of storage: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_dvolrdtocn(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='QSUR'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART input surface runoff: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_qsur(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='QSUB'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART input subsurface runoff: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_qsub(nt)%data, default='inactive') + + call mosart_hist_addfld (fname='QGWL'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & + avgflag='A', long_name='MOSART input GWL runoff: '//trim(ctl%tracer_names(nt)), & + ptr_rof=h_qgwl(nt)%data, default='inactive') + end do + + call mosart_hist_addfld (fname='STORAGE_MCH', units='m3', & + avgflag='A', long_name='MOSART main channelstorage', & + ptr_rof=h_volr_mch, default='inactive') + + call mosart_hist_addfld (fname='QIRRIG_FROM_COUPLER', units='m3/s', & + avgflag='A', long_name='Amount of water used for irrigation (total flux received from coupler)', & + ptr_rof=ctl%qirrig, default='inactive') + + call mosart_hist_addfld (fname='QIRRIG_ACTUAL', units='m3/s', & + avgflag='A', long_name='Actual irrigation (if limited by river storage)', & + ptr_rof=ctl%qirrig_actual, default='inactive') + + call mosart_hist_addfld (fname='QGLC_LIQ_INPUT', units='m3', & + avgflag='A', long_name='liquid runoff from glc input', & + ptr_rof=h_qglc_liq_input, default='active') + + call mosart_hist_addfld (fname='QGLC_ICE_INPUT', units='m3', & + avgflag='A', long_name='ice runoff from glc input', & + ptr_rof=h_qglc_ice_input, default='active') + + ! print masterlist of history fields + call mosart_hist_printflds() + + end subroutine mosart_histflds_init + + !----------------------------------------------------------------------- + + subroutine mosart_histflds_set(ntracers) + + !----------------------------------------------------------------------- + ! Set mosart history fields as 1d pointer arrays + !----------------------------------------------------------------------- + + ! Arguments + integer, intent(in) :: ntracers + + ! Local variables + integer :: nt + integer :: nt_liq, nt_ice + + nt_liq = ctl%nt_liq + nt_ice = ctl%nt_ice + + do nt = 1,ntracers + h_runofflnd(nt)%data(:) = ctl%runofflnd(:,nt) + h_runoffocn(nt)%data(:) = ctl%runoffocn(:,nt) + h_runofftot(nt)%data(:) = ctl%runofftot(:,nt) + h_direct(nt)%data(:) = ctl%direct(:,nt) + h_dvolrdtlnd(nt)%data(:) = ctl%dvolrdtlnd(:,nt) + h_dvolrdtocn(nt)%data(:) = ctl%dvolrdtocn(:,nt) + h_qsub(nt)%data(:) = ctl%qsub(:,nt) + h_qsur(nt)%data(:) = ctl%qsur(:,nt) + h_qgwl(nt)%data(:) = ctl%qgwl(:,nt) + end do + h_volr_mch(:) = Trunoff%wr(:,1) + h_qglc_liq_input(:) = ctl%qglc_liq(:) + h_qglc_ice_input(:) = ctl%qglc_ice(:) + h_direct_glc(nt_liq)%data(:) = ctl%direct_glc(:,nt_liq) + h_direct_glc(nt_ice)%data(:) = ctl%direct_glc(:,nt_ice) + + end subroutine mosart_histflds_set + +end module mosart_histflds diff --git a/src/riverroute/mosart_io.F90 b/src/riverroute/mosart_io.F90 new file mode 100644 index 0000000..06945ea --- /dev/null +++ b/src/riverroute/mosart_io.F90 @@ -0,0 +1,1935 @@ +module mosart_io + + ! Generic interfaces to write fields to netcdf files + ! + use shr_kind_mod , only : r8 => shr_kind_r8, i8=>shr_kind_i8, r4=>shr_kind_r4 + use shr_kind_mod , only : CS=>shr_kind_cs, CL=>shr_kind_cl + use shr_sys_mod , only : shr_sys_flush, shr_sys_abort + use shr_file_mod , only : shr_file_getunit, shr_file_freeunit + use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat + use mosart_vars , only : spval, ispval, iulog, mainproc, mpicom_rof, iam, npes + use perf_mod , only : t_startf, t_stopf + use pio , only : file_desc_t, var_desc_t, io_desc_t, iosystem_desc_t, pio_initdecomp, & + pio_openfile, pio_iotask_rank, pio_closefile, pio_createfile, & + pio_seterrorhandling, pio_inq_dimid, pio_inq_dimlen, pio_inq_dimname, & + pio_def_dim, pio_inq_dimname, pio_enddef, pio_def_var, pio_put_att, & + pio_get_var, pio_put_var, pio_inq_varndims, pio_inq_vardimid, & + pio_inq_vartype, pio_inq_varname, pio_inq_varid, pio_inquire, & + pio_setframe, pio_read_darray, pio_write_darray, & + PIO_CLOBBER, PIO_IOTYPE_NETCDF, PIO_IOTYPE_PNETCDF, PIO_NOERR, & + PIO_BCAST_ERROR, PIO_OFFSET_KIND, pio_INTERNAL_ERROR, & + pio_int, pio_real, pio_double, pio_char, pio_global, & + pio_write, pio_nowrite, pio_noclobber, pio_nofill, pio_unlimited + use mpi + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS: + public :: check_var ! determine if variable is on netcdf file + public :: check_dim ! validity check on dimension + public :: ncd_pio_openfile ! open a file + public :: ncd_pio_createfile ! create a new file + public :: ncd_pio_closefile ! close a file + public :: ncd_pio_init ! initialize pio + public :: ncd_decomp_init ! initialize module variables for iosdesc + public :: ncd_enddef ! end define mode + public :: ncd_putatt ! put attribute + public :: ncd_defdim ! define dimension + public :: ncd_inqdid ! inquire dimension id + public :: ncd_inqdname ! inquire dimension name + public :: ncd_inqdlen ! inquire dimension length + public :: ncd_inqfdims ! inquire file dimnesions + public :: ncd_defvar ! define variables + public :: ncd_inqvid ! inquire variable id + public :: ncd_inqvname ! inquire variable name + public :: ncd_inqvdims ! inquire variable ndims + public :: ncd_inqvdids ! inquire variable dimids + public :: ncd_io ! write local data + public :: ncd_getdatetime ! get date and time + + integer, parameter, public :: ncd_int = pio_int + integer, parameter, public :: ncd_log =-pio_int + integer, parameter, public :: ncd_float = pio_real + integer, parameter, public :: ncd_double = pio_double + integer, parameter, public :: ncd_char = pio_char + integer, parameter, public :: ncd_global = pio_global + integer, parameter, public :: ncd_write = pio_write + integer, parameter, public :: ncd_nowrite = pio_nowrite + integer, parameter, public :: ncd_clobber = pio_clobber + integer, parameter, public :: ncd_noclobber = pio_noclobber + integer, parameter, public :: ncd_nofill = pio_nofill + integer, parameter, public :: ncd_unlimited = pio_unlimited + + ! !PRIVATE MEMBER FUNCTIONS: + interface ncd_putatt + module procedure ncd_putatt_int + module procedure ncd_putatt_real + module procedure ncd_putatt_char + end interface ncd_putatt + + interface ncd_defvar + module procedure ncd_defvar_bynf + module procedure ncd_defvar_bygrid + end interface ncd_defvar + + interface ncd_io + ! global scalar + module procedure ncd_io_log_var0_nf + module procedure ncd_io_int_var0_nf + module procedure ncd_io_real_var0_nf + + ! global 1d + module procedure ncd_io_log_var1_nf + module procedure ncd_io_int_var1_nf + module procedure ncd_io_real_var1_nf + module procedure ncd_io_char_var1_nf + module procedure ncd_io_char_varn_strt_nf + + ! global 2d + module procedure ncd_io_int_var2_nf + module procedure ncd_io_real_var2_nf + module procedure ncd_io_char_var2_nf + + ! local 1d + module procedure ncd_io_log_var1 + module procedure ncd_io_int_var1 + module procedure ncd_io_real_var1 + end interface ncd_io + + private :: ncd_getiodesc ! obtain iodesc + + integer , parameter, private :: debug = 0 ! local debug level + real(r8) , parameter, public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields + + integer :: io_type, io_format + type(iosystem_desc_t), pointer, public :: pio_subsystem + + type iodesc_plus_type + character(len=CS) :: name + type(io_desc_t) :: iodesc + integer :: type + integer :: ndims + integer :: dims(4) + integer :: dimids(4) + end type iodesc_plus_type + integer,parameter ,private :: max_iodesc = 100 + integer ,private :: num_iodesc = 0 + type(iodesc_plus_type) ,private, target :: iodesc_list(max_iodesc) + + ! Decomposition data needed to generate iodesc + integer, pointer, public, protected :: compDOF(:) + +!----------------------------------------------------------------------- +contains +!----------------------------------------------------------------------- + + subroutine ncd_pio_init(rofid) + + !----------------------------------------------------------------------- + ! Initialize mosart pio + ! + ! Arguments + integer, intent(in) :: rofid + + ! Local variables + character(len=*),parameter :: subname='ncd_pio_init' ! subroutine name + !----------------------------------------------------------------------- + + pio_subsystem => shr_pio_getiosys(rofid) + io_type = shr_pio_getiotype(rofid) + io_format = shr_pio_getioformat(rofid) + + end subroutine ncd_pio_init + + !----------------------------------------------------------------------- + + subroutine ncd_decomp_init(begr, endr, gsize, gindex) + + ! Initialize module variable compDOF used to set iodesc + + ! Arguments + integer, intent(in) :: begr + integer, intent(in) :: endr + integer, intent(in) :: gsize + integer, intent(in) :: gindex(begr:endr) + + ! Local variables + integer :: m + integer :: cnt + integer :: lsize + integer :: status ! error code + character(len=*),parameter :: subname='ncd_decomp_init' + !------------------------------------------------------ + + lsize = endr - begr + 1 + allocate(compDOF(lsize)) + cnt = 0 + do m = begr, endr + cnt = cnt + 1 + compDOF(cnt) = gindex(m) + enddo + if (debug > 1) then + do m = 0,npes-1 + if (iam == m) then + write(iulog,*) trim(subname),' sizes1 = ',& + iam,gsize,lsize,npes + write(iulog,*) trim(subname),' compDOF = ',& + iam,size(compDOF),minval(compDOF),maxval(compDOF) + endif + call mpi_barrier(mpicom_rof, status) + enddo + endif + + end subroutine ncd_decomp_init + + !----------------------------------------------------------------------- + + subroutine ncd_pio_openfile(file, fname, mode) + + !----------------------------------------------------------------------- + ! Open a NetCDF PIO file + ! + ! Arguments + type(file_desc_t), intent(inout) :: file ! Output PIO file handle + character(len=*) , intent(in) :: fname ! Input filename to open + integer , intent(in) :: mode ! file mode + + ! Local variables + integer :: oldmethod + integer :: ierr + character(len=*),parameter :: subname='ncd_pio_openfile' ! subroutine name + !----------------------------------------------------------------------- + + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) + ierr = pio_openfile(pio_subsystem, file, io_type, fname, mode) + if(ierr/= PIO_NOERR) then + call shr_sys_abort(subname//'ERROR: Failed to open file') + else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then + write(iulog,*) 'Opened existing file ', trim(fname), file%fh + end if + call pio_seterrorhandling(pio_subsystem, oldmethod) + + end subroutine ncd_pio_openfile + + !----------------------------------------------------------------------- + + subroutine ncd_pio_closefile(file) + + !----------------------------------------------------------------------- + ! Close a NetCDF PIO file + ! + ! Arguments + type(file_desc_t), intent(inout) :: file ! PIO file handle to close + !----------------------------------------------------------------------- + + call pio_closefile(file) + + end subroutine ncd_pio_closefile + + !----------------------------------------------------------------------- + + subroutine ncd_pio_createfile(file, fname) + + !----------------------------------------------------------------------- + ! Create a new NetCDF file with PIO + ! + ! Arguments + type(file_desc_t), intent(inout) :: file ! PIO file descriptor + character(len=*), intent(in) :: fname ! File name to create + + ! Local variables + integer :: oldmethod + integer :: ierr + integer :: iomode + character(len=*),parameter :: subname='ncd_pio_createfile' ! subroutine name + !----------------------------------------------------------------------- + + + iomode = PIO_CLOBBER + if(io_type == PIO_IOTYPE_NETCDF .or. io_type == PIO_IOTYPE_PNETCDF) then + iomode = ior(iomode, io_format) + endif + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) + ierr = pio_createfile(pio_subsystem, file, io_type, fname, iomode) + if(ierr/= PIO_NOERR) then + call shr_sys_abort( subname//' ERROR: Failed to open file to write: '//trim(fname)) + else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then + write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh + end if + call pio_seterrorhandling(pio_subsystem, oldmethod) + + end subroutine ncd_pio_createfile + + !----------------------------------------------------------------------- + + subroutine check_var(ncid, varname, vardesc, readvar, print_err ) + + !----------------------------------------------------------------------- + ! Check if variable is on netcdf file + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor + character(len=*) , intent(in) :: varname ! Varible name to check + type(Var_desc_t) , intent(out) :: vardesc ! Output variable descriptor + logical , intent(out) :: readvar ! If variable exists or not + logical, optional, intent(in) :: print_err ! If should print about error + + ! Local variables + integer :: oldmethod + integer :: ret ! return value + logical :: log_err ! if should log error + character(len=*),parameter :: subname='check_var' ! subroutine name + !----------------------------------------------------------------------- + + + if ( present(print_err) )then + log_err = print_err + else + log_err = .true. + end if + readvar = .true. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) + ret = pio_inq_varid (ncid, varname, vardesc) + if (ret /= PIO_NOERR) then + readvar = .false. + if (mainproc .and. log_err) then + write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' + end if + end if + call pio_seterrorhandling(ncid, oldmethod) + + end subroutine check_var + + !----------------------------------------------------------------------- + + subroutine check_dim(ncid, dimname, value) + + ! Validity check on dimension + ! + ! Arguments + type(file_desc_t),intent(in) :: ncid ! PIO file handle + character(len=*), intent(in) :: dimname ! Dimension name + integer, intent(in) :: value ! Expected dimension size + + ! Local variables + integer :: dimid, dimlen ! temporaries + integer :: status ! error code + character(len=*),parameter :: subname='check_dim' ! subroutine name + !----------------------------------------------------------------------- + + status = pio_inq_dimid (ncid, trim(dimname), dimid) + status = pio_inq_dimlen (ncid, dimid, dimlen) + if (dimlen /= value) then + write(iulog,*) subname//' ERROR: mismatch of input dimension ',dimlen, & + ' with expected value ',value,' for variable ',trim(dimname) + call shr_sys_abort() + end if + + end subroutine check_dim + + !----------------------------------------------------------------------- + + subroutine ncd_enddef(ncid) + + !----------------------------------------------------------------------- + ! enddef netcdf file + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + + ! Local variables + integer :: status ! error status + character(len=*),parameter :: subname='ncd_enddef' ! subroutine name + !----------------------------------------------------------------------- + + status = pio_enddef(ncid) + + end subroutine ncd_enddef + + !----------------------------------------------------------------------- + + subroutine ncd_inqdid(ncid,name,dimid,dimexist) + + !----------------------------------------------------------------------- + ! inquire on a dimension id + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: name ! dimension name + integer , intent(out):: dimid ! dimension id + logical,optional, intent(out):: dimexist ! if this dimension exists or not + + ! Local variables + integer :: oldmethod + integer :: status + !----------------------------------------------------------------------- + + if ( present(dimexist) )then + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) + end if + status = PIO_inq_dimid(ncid,name,dimid) + if ( present(dimexist) )then + if ( status == PIO_NOERR)then + dimexist = .true. + else + dimexist = .false. + end if + call pio_seterrorhandling(ncid, oldmethod) + end if + + end subroutine ncd_inqdid + + !----------------------------------------------------------------------- + + subroutine ncd_inqdlen(ncid,dimid,len,name) + + !----------------------------------------------------------------------- + ! enddef netcdf file + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + integer , intent(inout) :: dimid ! dimension id + integer , intent(out) :: len ! dimension len + character(len=*), optional, intent(in) :: name ! dimension name + ! + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + if ( present(name) )then + call ncd_inqdid(ncid,name,dimid) + end if + len = -1 + status = pio_inq_dimlen(ncid,dimid,len) + + end subroutine ncd_inqdlen + + !----------------------------------------------------------------------- + + subroutine ncd_inqdname(ncid,dimid,dname) + + !----------------------------------------------------------------------- + ! inquire dim name + ! + ! Arguments + type(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(in) :: dimid ! dimension id + character(len=*) , intent(out):: dname ! dimension name + + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + status = pio_inq_dimname(ncid,dimid,dname) + + end subroutine ncd_inqdname + + !----------------------------------------------------------------------- + + subroutine ncd_inqfdims(ncid, isgrid2d, ni, nj, ns) + + !----------------------------------------------------------------------- + ! Arguments + type(file_desc_t), intent(inout):: ncid + logical , intent(out) :: isgrid2d + integer , intent(out) :: ni + integer , intent(out) :: nj + integer , intent(out) :: ns + ! Local variables + integer :: oldmethod + integer :: dimid ! netCDF id + integer :: ier ! error status + character(len=CS) :: subname = 'surfrd_filedims' ! subroutine name + !----------------------------------------------------------------------- + + ni = 0 + nj = 0 + + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR, oldmethod) + ier = pio_inq_dimid (ncid, 'lon', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'lat', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'lsmlon', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'lsmlat', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'ni', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, ni) + ier = pio_inq_dimid (ncid, 'nj', dimid) + if (ier == PIO_NOERR) ier = pio_inq_dimlen(ncid, dimid, nj) + + ier = pio_inq_dimid (ncid, 'gridcell', dimid) + if (ier == PIO_NOERR) then + ier = pio_inq_dimlen(ncid, dimid, ni) + if (ier == PIO_NOERR) nj = 1 + end if + + call pio_seterrorhandling(ncid, oldmethod) + + if (ni == 0 .or. nj == 0) then + write(iulog,*) trim(subname),' ERROR: ni,nj = ',ni,nj,' cannot be zero ' + call shr_sys_abort() + end if + + if (nj == 1) then + isgrid2d = .false. + else + isgrid2d = .true. + end if + + ns = ni*nj + + end subroutine ncd_inqfdims + + !----------------------------------------------------------------------- + + subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) + + !----------------------------------------------------------------------- + ! Inquire on a variable ID + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: name ! variable name + integer , intent(out) :: varid ! variable id + type(Var_desc_t) , intent(out) :: vardesc ! variable descriptor + logical, optional, intent(out) :: readvar ! does variable exist + + ! Local variables + integer :: oldmethod + integer :: ret ! return code + character(len=*),parameter :: subname='ncd_inqvid' ! subroutine name + !----------------------------------------------------------------------- + + if (present(readvar)) then + readvar = .false. + call pio_seterrorhandling(pio_subsystem, PIO_BCAST_ERROR, oldmethod) + ret = pio_inq_varid(ncid,name,vardesc) + if (ret /= PIO_NOERR) then + if (mainproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' + readvar = .false. + else + readvar = .true. + end if + call pio_seterrorhandling(ncid, oldmethod) + else + ret = pio_inq_varid(ncid,name,vardesc) + endif + varid = vardesc%varid + + end subroutine ncd_inqvid + + !----------------------------------------------------------------------- + + subroutine ncd_inqvdims(ncid,ndims,vardesc) + + !----------------------------------------------------------------------- + ! inquire variable dimensions + ! + ! Arguments + type(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(out) :: ndims ! variable ndims + type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor + ! + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + ndims = -1 + status = pio_inq_varndims(ncid,vardesc,ndims) + + end subroutine ncd_inqvdims + + !----------------------------------------------------------------------- + + subroutine ncd_inqvname(ncid,varid,vname,vardesc) + + !----------------------------------------------------------------------- + ! inquire variable name + ! + ! Arguments + type(file_desc_t), intent(in) :: ncid ! netcdf file id + integer , intent(in) :: varid ! variable id + character(len=*) , intent(out) :: vname ! variable vname + type(Var_desc_t) , intent(inout):: vardesc ! variable descriptor + + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + vname = '' + status = pio_inq_varname(ncid,vardesc,vname) + + end subroutine ncd_inqvname + + !----------------------------------------------------------------------- + + subroutine ncd_inqvdids(ncid,dids,vardesc) + + !----------------------------------------------------------------------- + ! inquire variable dimension ids + ! + ! Arguments + type(file_desc_t),intent(in) :: ncid ! netcdf file id + integer ,intent(out) :: dids(:) ! variable dids + type(Var_desc_t),intent(inout):: vardesc ! variable descriptor + + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + dids = -1 + status = pio_inq_vardimid(ncid,vardesc,dids) + + end subroutine ncd_inqvdids + + !----------------------------------------------------------------------- + subroutine ncd_putatt_int(ncid,varid,attrib,value,xtype) + + !----------------------------------------------------------------------- + ! put integer attributes + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + integer ,intent(in) :: value ! netcdf attrib value + integer,optional ,intent(in) :: xtype ! netcdf data type + ! + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + status = pio_put_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_putatt_int + + !----------------------------------------------------------------------- + + subroutine ncd_putatt_char(ncid,varid,attrib,value,xtype) + + !----------------------------------------------------------------------- + ! put character attributes + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + character(len=*) ,intent(in) :: value ! netcdf attrib value + integer,optional ,intent(in) :: xtype ! netcdf data type + ! + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + status = pio_put_att(ncid,varid,trim(attrib),value) + + end subroutine ncd_putatt_char + + !----------------------------------------------------------------------- + + subroutine ncd_putatt_real(ncid,varid,attrib,value,xtype) + + !----------------------------------------------------------------------- + ! put real attributes + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + integer ,intent(in) :: varid ! netcdf var id + character(len=*) ,intent(in) :: attrib ! netcdf attrib + real(r8) ,intent(in) :: value ! netcdf attrib value + integer ,intent(in) :: xtype ! netcdf data type + ! + ! Local variables + integer :: status + real(r4) :: value4 + !----------------------------------------------------------------------- + + value4 = real(value, kind=r4) + + if (xtype == pio_double) then + status = pio_put_att(ncid,varid,trim(attrib),value) + else + status = pio_put_att(ncid,varid,trim(attrib),value4) + endif + + end subroutine ncd_putatt_real + + !----------------------------------------------------------------------- + + subroutine ncd_defdim(ncid,attrib,value,dimid) + + !----------------------------------------------------------------------- + ! define dimension + ! + ! Arguments + type(file_desc_t), intent(in) :: ncid ! netcdf file id + character(len=*) , intent(in) :: attrib ! netcdf attrib + integer , intent(in) :: value ! netcdf attrib value + integer , intent(out):: dimid ! netcdf dimension id + ! + ! Local variables + integer :: status + !----------------------------------------------------------------------- + + status = pio_def_dim(ncid,attrib,value,dimid) + + end subroutine ncd_defdim + + !----------------------------------------------------------------------- + + subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & + long_name, units, cell_method, missing_value, fill_value, & + imissing_value, ifill_value, comment, flag_meanings, & + flag_values, nvalid_range ) + + !----------------------------------------------------------------------- + ! Define a netcdf variable + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + integer , intent(in) :: ndims ! number of dims + integer , intent(inout) :: varid ! returned var id + integer , intent(in), optional :: dimid(:) ! dimids + character(len=*) , intent(in), optional :: long_name ! attribute + character(len=*) , intent(in), optional :: units ! attribute + character(len=*) , intent(in), optional :: cell_method ! attribute + character(len=*) , intent(in), optional :: comment ! attribute + character(len=*) , intent(in), optional :: flag_meanings(:) ! attribute + real(r8) , intent(in), optional :: missing_value ! attribute for real + real(r8) , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int + integer , intent(in), optional :: flag_values(:) ! attribute for int + integer , intent(in), optional :: nvalid_range(2) ! attribute for int + + ! + ! Local variables + integer :: n ! indices + integer :: ldimid(4) ! local dimid + integer :: dimid0(1) ! local dimid + integer :: status ! error status + integer :: lxtype ! local external type (in case logical variable) + type(var_desc_t) :: vardesc ! local vardesc + character(len=CL) :: dimname ! temporary + character(len=CL) :: str ! temporary + character(len=*),parameter :: subname='ncd_defvar_bynf' ! subroutine name + !----------------------------------------------------------------------- + + varid = -1 + + dimid0 = 0 + ldimid = 0 + if (present(dimid)) then + ldimid(1:ndims) = dimid(1:ndims) + else ! ndims must be zero if dimid not present + if (ndims /= 0) then + write(iulog,*) subname//' ERROR: dimid not supplied and ndims ne 0 ',trim(varname),ndims + call shr_sys_abort() + endif + endif + + if ( xtype == ncd_log )then + lxtype = ncd_int + else + lxtype = xtype + end if + if (mainproc .and. debug > 1) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + write(iulog,*) subname//' ',trim(varname),lxtype,ndims,ldimid(1:ndims) + endif + + if (ndims > 0) then + status = pio_inq_dimname(ncid,ldimid(ndims),dimname) + end if + + ! Define variable + if (present(dimid)) then + status = pio_def_var(ncid,trim(varname),lxtype,dimid(1:ndims),vardesc) + else + status = pio_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) + endif + varid = vardesc%varid + ! + ! Add attributes + ! + if (present(long_name)) then + call ncd_putatt(ncid, varid, 'long_name', trim(long_name)) + end if + if (present(flag_values)) then + status = pio_put_att(ncid,varid,'flag_values',flag_values) + if ( .not. present(flag_meanings)) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_values set -- but not flag_meanings" ) + end if + end if + if (present(flag_meanings)) then + if ( .not. present(flag_values)) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_meanings set -- but not flag_values" ) + end if + if ( size(flag_values) /= size(flag_meanings) ) then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_meanings and flag_values dimension different") + end if + str = flag_meanings(1) + do n = 1, size(flag_meanings) + if ( index(flag_meanings(n), ' ') /= 0 )then + write(iulog,*) 'Error in defining variable = ', trim(varname) + call shr_sys_abort( subname//" ERROR:: flag_meanings has an invalid space in it" ) + end if + if ( n > 1 ) str = trim(str)//" "//flag_meanings(n) + end do + status = pio_put_att(ncid,varid,'flag_meanings', trim(str) ) + end if + if (present(comment)) then + call ncd_putatt(ncid, varid, 'comment', trim(comment)) + end if + if (present(units)) then + call ncd_putatt(ncid, varid, 'units', trim(units)) + end if + if (present(cell_method)) then + str = 'time: ' // trim(cell_method) + call ncd_putatt(ncid, varid, 'cell_methods', trim(str)) + end if + if (present(fill_value)) then + call ncd_putatt(ncid, varid, '_FillValue', fill_value, lxtype) + end if + if (present(missing_value)) then + call ncd_putatt(ncid, varid, 'missing_value', missing_value, lxtype) + end if + if (present(ifill_value)) then + call ncd_putatt(ncid, varid, '_FillValue', ifill_value, lxtype) + end if + if (present(imissing_value)) then + call ncd_putatt(ncid, varid, 'missing_value', imissing_value, lxtype) + end if + if (present(nvalid_range)) then + status = pio_put_att(ncid,varid,'valid_range', nvalid_range ) + end if + if ( xtype == ncd_log )then + status = pio_put_att(ncid,varid,'flag_values', (/0, 1/) ) + status = pio_put_att(ncid,varid,'flag_meanings', "FALSE TRUE" ) + status = pio_put_att(ncid,varid,'valid_range', (/0, 1/) ) + end if + + end subroutine ncd_defvar_bynf + + !----------------------------------------------------------------------- + + subroutine ncd_defvar_bygrid(ncid, varname, xtype, & + dim1name, dim2name, dim3name, dim4name, dim5name, & + long_name, units, cell_method, missing_value, fill_value, & + imissing_value, ifill_value, comment, & + flag_meanings, flag_values, nvalid_range ) + + !------------------------------------------------------------------------ + ! Define a netcdf variable + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + character(len=*), intent(in), optional :: dim1name ! dimension name + character(len=*), intent(in), optional :: dim2name ! dimension name + character(len=*), intent(in), optional :: dim3name ! dimension name + character(len=*), intent(in), optional :: dim4name ! dimension name + character(len=*), intent(in), optional :: dim5name ! dimension name + character(len=*), intent(in), optional :: long_name ! attribute + character(len=*), intent(in), optional :: units ! attribute + character(len=*), intent(in), optional :: cell_method ! attribute + character(len=*), intent(in), optional :: comment ! attribute + character(len=*), intent(in), optional :: flag_meanings(:) ! attribute + real(r8) , intent(in), optional :: missing_value ! attribute for real + real(r8) , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int + integer , intent(in), optional :: flag_values(:) ! attribute for int + integer , intent(in), optional :: nvalid_range(2) ! attribute for int + ! + ! !REVISION HISTORY: + ! + ! + ! Local variables + !EOP + integer :: n ! indices + integer :: ndims ! dimension counter + integer :: dimid(5) ! dimension ids + integer :: varid ! variable id + integer :: itmp ! temporary + character(len=CL) :: str ! temporary + character(len=*),parameter :: subname='ncd_defvar_bygrid' ! subroutine name + !----------------------------------------------------------------------- + + dimid(:) = 0 + + ! Determine dimension ids for variable + + if (present(dim1name)) call ncd_inqdid(ncid, dim1name, dimid(1)) + if (present(dim2name)) call ncd_inqdid(ncid, dim2name, dimid(2)) + if (present(dim3name)) call ncd_inqdid(ncid, dim3name, dimid(3)) + if (present(dim4name)) call ncd_inqdid(ncid, dim4name, dimid(4)) + if (present(dim5name)) call ncd_inqdid(ncid, dim5name, dimid(5)) + + ! Define variable + ndims = 0 + if (present(dim1name)) then + do n = 1, size(dimid) + if (dimid(n) /= 0) ndims = ndims + 1 + end do + end if + + call ncd_defvar_bynf(ncid,varname,xtype,ndims,dimid,varid, & + long_name=long_name, units=units, cell_method=cell_method, & + missing_value=missing_value, fill_value=fill_value, & + imissing_value=imissing_value, ifill_value=ifill_value, & + comment=comment, flag_meanings=flag_meanings, & + flag_values=flag_values, nvalid_range=nvalid_range ) + + end subroutine ncd_defvar_bygrid + + !------------------------------------------------------------------------ + + subroutine ncd_io_log_var0_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer variable + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + logical , intent(inout) :: data ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(1), count(1) ! output bounds + integer :: status ! error code + integer :: idata ! raw integer data + logical :: varpresent ! if true, variable is on tape + integer :: temp(1) ! temporary + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_log_var0_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, idata) + if ( idata == 0 )then + data = .false. + else if ( idata == 1 )then + data = .true. + else + call shr_sys_abort( subname//' ERROR: bad integer value for logical data' ) + end if + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if ( data )then + temp(1) = 1 + else + temp(1) = 0 + end if + if (present(nt)) then + start(1) = nt + count(1) = 1 + status = pio_put_var(ncid, varid, start, count, temp) + else + status = pio_put_var(ncid, varid, temp(1)) + end if + + + endif ! flag + + end subroutine ncd_io_log_var0_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_int_var0_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer variable + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , intent(inout) :: data ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(1), count(1) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + integer :: temp(1) ! temporary + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_int_var0_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if (present(nt)) then + start(1) = nt + count(1) = 1 + temp(1) = data + status = pio_put_var(ncid, varid, start, count, temp) + else + status = pio_put_var(ncid, varid, data) + end if + + endif ! flag + + end subroutine ncd_io_int_var0_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_real_var0_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global real variable + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + real(r8) , intent(inout) :: data ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(1), count(1) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + real(r8):: temp(1) ! temporary + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_real_var0_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, vardesc, data) + endif + if (present(readvar)) readvar = varpresent + + else if (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if (present(nt)) then + start(1) = nt + count(1) = 1 + temp(1) = data + status = pio_put_var(ncid, varid, start, count, temp) + else + status = pio_put_var(ncid, varid, data) + end if + + endif ! flag + + end subroutine ncd_io_real_var0_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_int_var1_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer array + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , intent(inout) :: data(:) ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(2), count(2) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_int_var1_nf' + integer :: ndims + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + count(1) = size(data) + start(2) = nt + count(2) = 1 + ndims = 2 + else + start(1) = 1 + count(1) = size(data) + start(2) = 1 + count(2) = 1 + ndims = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) + + endif ! flag + + end subroutine ncd_io_int_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_log_var1_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer array + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + logical , intent(inout) :: data(:) ! raw data + logical, optional, intent(out) :: readvar ! was var read? + integer, optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(2), count(2) ! output bounds + integer :: status ! error code + integer, pointer :: idata(:) ! Temporary integer data to send to file + logical :: varpresent ! if true, variable is on tape + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_log_var1_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + allocate( idata(size(data)) ) + status = pio_get_var(ncid, varid, idata) + data = (idata == 1) + if ( any(idata /= 0 .and. idata /= 1) )then + call shr_sys_abort(subname//'ERROR: read in bad integer value(s) for logical data') + end if + deallocate( idata ) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + count(1) = size(data) + start(2) = nt + count(2) = 1 + else + start(1) = 1 + count(1) = size(data) + start(2) = 1 + count(2) = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + allocate( idata(size(data)) ) + where( data ) + idata = 1 + elsewhere + idata = 0 + end where + status = pio_put_var(ncid, varid, start, count, idata) + deallocate( idata ) + + endif ! flag + + end subroutine ncd_io_log_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_real_var1_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global real array + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + real(r8) , intent(inout) :: data(:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(2), count(2) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_real_var1_nf' + integer :: ndims + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + start(2) = nt + count(1) = size(data) + count(2) = 1 + ndims = 2 + else + start(1) = 1 + start(2) = 1 + count(1) = size(data) + count(2) = 1 + ndims = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) + + endif ! flag + + end subroutine ncd_io_real_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_char_var1_nf(varname, data, flag, ncid, readvar, nt ) + + !------------------------------------------------------------------------ + ! netcdf I/O of global char array + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + character(len=*) , intent(inout) :: data ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: m ! indices + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=CS) :: vname ! variable error checking + character(len=1) :: tmpString(CL) ! temp for manipulating output string + type(var_desc_t) :: vardesc ! local vardesc pointer + character(len=*),parameter :: subname='ncd_io_char_var1_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + + if (present(nt)) then + status = pio_put_var(ncid, varid, (/1,nt/), ival=data) + else + status = pio_put_var(ncid, varid, data ) + end if + + endif ! flag + + end subroutine ncd_io_char_var1_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_int_var2_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global integer 2D array + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , intent(inout) :: data(:,:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(3), count(3) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + logical :: found ! if true, found lat/lon dims on file + character(len=*),parameter :: subname='ncd_io_int_var2_nf' + integer :: ndims + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + start(2) = 1 + start(3) = nt + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + ndims = 3 + else + start(1) = 1 + start(2) = 1 + start(3) = 1 + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + ndims = 2 + end if + call ncd_inqvid(ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start(1:ndims), count(1:ndims), data) + + endif + + end subroutine ncd_io_int_var2_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_real_var2_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global real 2D array + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + real(r8) , intent(inout) :: data(:,:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(3), count(3) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + logical :: found ! if true, found lat/lon dims on file + character(len=*),parameter :: subname='ncd_io_real_var2_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + if (present(nt)) then + start(1) = 1 + start(2) = 1 + start(3) = nt + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + else + start(1) = 1 + start(2) = 1 + start(3) = 1 + count(1) = size(data, dim=1) + count(2) = size(data, dim=2) + count(3) = 1 + end if + call ncd_inqvid (ncid, varname, varid, vardesc) + status = pio_put_var(ncid, varid, start, count, data) + + endif + + end subroutine ncd_io_real_var2_nf + + !------------------------------------------------------------------------ + + subroutine ncd_io_char_var2_nf(varname, data, flag, ncid, readvar, nt) + + !------------------------------------------------------------------------ + ! netcdf I/O of global character array + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + character(len=*), intent(inout) :: data(:) ! raw data + logical , optional, intent(out):: readvar ! was var read? + integer , optional, intent(in) :: nt ! time sample index + ! + ! Local variables + integer :: varid ! netCDF variable id + integer :: start(3), count(3) ! output bounds + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + character(len=CS) :: vname ! variable error checking + type(var_desc_t) :: vardesc ! local vardesc pointer + logical :: found ! if true, found lat/lon dims on file + character(len=*),parameter :: subname='ncd_io_char_var2_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + data = ' ' + status = pio_get_var(ncid, varid, data) + endif + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid (ncid, varname, varid, vardesc) + if (present(nt)) then + start(1) = 1 + start(2) = 1 + start(3) = nt + count(1) = size(data) + count(2) = len(data) + count(3) = 1 + status = pio_put_var(ncid, varid, start, count, data) + else + status = pio_put_var(ncid, varid, data) + end if + + endif + + end subroutine ncd_io_char_var2_nf + + !------------------------------------------------------------------------ + subroutine ncd_io_char_varn_strt_nf(vardesc, data, flag, ncid, start ) + + ! netcdf I/O of global character array with start indices input + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + type(var_desc_t), intent(in) :: vardesc ! local vardesc pointer + character(len=*), intent(inout) :: data ! raw data for this index + integer , intent(in) :: start(:) ! output bounds + ! + ! Local variables + integer :: status ! error code + character(len=*),parameter :: subname='ncd_io_char_varn_strt_nf' + !----------------------------------------------------------------------- + + if (flag == 'read') then + status = pio_get_var(ncid, vardesc, start, data ) + elseif (flag == 'write') then + status = pio_put_var(ncid, vardesc, start, data ) + endif + + end subroutine ncd_io_char_varn_strt_nf + + !----------------------------------------------------------------------- + + subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) + + !----------------------------------------------------------------------- + ! I/O for 1d integer field + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + integer , pointer :: data(:) ! local decomposition data + character(len=*) , intent(in) :: dim1name ! dimension name + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! + ! Local variables + character(len=CS) :: dimname ! temporary + integer :: n ! index + integer :: iodnum ! iodesc num in list + integer :: varid ! varid + integer :: ndims ! ndims for var + integer :: ndims_iod ! ndims iodesc for var + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: start(3) ! netcdf start index + integer :: count(3) ! netcdf count index + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + integer :: xtype ! netcdf data type + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_int_var1' ! subroutine name + !----------------------------------------------------------------------- + + if (mainproc .and. debug > 1) then + write(iulog,*) subname//' ',trim(flag),' ',trim(varname),' ',trim(dim1name) + end if + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_OFFSET_KIND)) + end if + call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) + end if + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_OFFSET_KIND)) + end if + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=ispval) + + else + + if (mainproc) then + write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) + call shr_sys_abort() + endif + + endif + + end subroutine ncd_io_int_var1 + + !----------------------------------------------------------------------- + + subroutine ncd_io_log_var1(varname, data, dim1name, & + flag, ncid, nt, readvar) + + !----------------------------------------------------------------------- + ! I/O for 1d integer field + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! netcdf file id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + character(len=*) , intent(in) :: varname ! variable name + logical , pointer :: data(:) ! local decomposition data + character(len=*) , intent(in) :: dim1name ! dimension name + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! + ! Local variables + character(len=CS) :: dimname ! temporary + integer :: n ! index + integer :: iodnum ! iodesc num in list + integer :: varid ! varid + integer :: ndims ! ndims for var + integer :: ndims_iod ! ndims iodesc for var + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: start(3) ! netcdf start index + integer :: count(3) ! netcdf count index + integer :: status ! error code + integer, pointer :: idata(:) ! Temporary integer data to send to file + logical :: varpresent ! if true, variable is on tape + integer :: xtype ! netcdf data type + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_log_var1' ! subroutine name + !----------------------------------------------------------------------- + + if (mainproc .and. debug > 1) then + write(iulog,*) subname//' ',trim(flag),' ',trim(varname) + end if + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + allocate( idata(size(data)) ) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_OFFSET_KIND)) + end if + call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status) + data = (idata == 1) + if ( any(idata /= 0 .and. idata /= 1) )then + call shr_sys_abort( subname//' ERROR: read in bad integer value(s) for logical data' ) + end if + deallocate( idata ) + end if + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_OFFSET_KIND)) + end if + allocate( idata(size(data)) ) + where( data ) + idata = 1 + elsewhere + idata = 0 + end where + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, idata, status, fillval=0) + deallocate( idata ) + + else + + if (mainproc) then + write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) + call shr_sys_abort() + endif + + endif + + end subroutine ncd_io_log_var1 + + !----------------------------------------------------------------------- + + subroutine ncd_io_real_var1(varname, data, dim1name, & + flag, ncid, nt, readvar) + + !----------------------------------------------------------------------- + ! I/O for 1d real field + ! + ! Arguments + type(file_desc_t),intent(inout) :: ncid ! netcdf file id + character(len=*), intent(in) :: flag ! 'read' or 'write' + character(len=*), intent(in) :: varname ! variable name + real(r8) , pointer :: data(:) ! local decomposition data + character(len=*), intent(in) :: dim1name ! dimension name + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + ! + ! Local variables + character(len=CS) :: dimname ! temporary + integer :: iodnum ! iodesc num in list + integer :: varid ! varid + integer :: ndims ! ndims for var + integer :: ndims_iod ! ndims iodesc for var + integer :: n ! index + integer :: dims(4) ! dim sizes + integer :: dids(4) ! dim ids + integer :: start(3) ! netcdf start index + integer :: count(3) ! netcdf count index + integer :: status ! error code + logical :: varpresent ! if true, variable is on tape + integer :: xtype ! netcdf data type + type(iodesc_plus_type) , pointer :: iodesc_plus + type(var_desc_t) :: vardesc + character(len=*),parameter :: subname='ncd_io_real_var1' ! subroutine name + !----------------------------------------------------------------------- + + if (mainproc .and. debug > 1) then + write(iulog,*) trim(subname),' ',trim(flag),' ',trim(varname) + endif + + if (flag == 'read') then + + call ncd_inqvid(ncid, varname, varid, vardesc, readvar=varpresent) + if (varpresent) then + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid,vardesc, dids) + status = pio_inq_vartype(ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid, vardesc, int(nt,kind=PIO_OFFSET_KIND)) + end if + call pio_read_darray(ncid, vardesc, iodesc_plus%iodesc, data, status) + end if + if (present(readvar)) readvar = varpresent + + elseif (flag == 'write') then + + call ncd_inqvid(ncid, varname ,varid, vardesc) + status = pio_inq_varndims(ncid, vardesc, ndims) + status = pio_inq_vardimid(ncid, vardesc, dids) + status = pio_inq_vartype (ncid, vardesc, xtype) + status = pio_inq_dimname(ncid,dids(ndims),dimname) + if ('time' == trim(dimname)) then + ndims_iod = ndims - 1 + else + ndims_iod = ndims + end if + do n = 1,ndims_iod + status = pio_inq_dimlen(ncid,dids(n),dims(n)) + enddo + call ncd_getiodesc(ncid, ndims_iod, dims(1:ndims_iod), dids(1:ndims_iod), & + xtype, iodnum) + iodesc_plus => iodesc_list(iodnum) + if (present(nt)) then + call pio_setframe(ncid,vardesc, int(nt,kind=PIO_OFFSET_KIND)) + end if + if(xtype == ncd_float) then + call shr_sys_abort( subname//' error: Attempt to write out single-precision data which is current NOT implemented (see issue #18)' ) + else + call pio_write_darray(ncid, vardesc, iodesc_plus%iodesc, data, status, fillval=spval) + endif + else + + if (mainproc) then + write(iulog,*) subname,' error: unsupported flag ',trim(flag) + call shr_sys_abort() + endif + + endif + + end subroutine ncd_io_real_var1 + + !------------------------------------------------------------------------ + + subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) + + !------------------------------------------------------------------------ + ! Returns an index to an io descriptor + ! + ! Arguments + type(file_desc_t), intent(inout) :: ncid ! PIO file descriptor + integer , intent(in) :: ndims ! ndims for var + integer , intent(in) :: dims(:) ! dim sizes + integer , intent(in) :: dimids(:) ! dim ids + integer , intent(in) :: xtype ! file external type + integer , intent(out) :: iodnum ! iodesc num in list + + ! Local variables + integer :: k,m,n ! indices + integer :: status ! error status + logical :: found ! true => found created iodescriptor + integer :: ndims_file ! temporary + character(len=CS) dimname_file ! dimension name on file + character(len=CS) dimname_iodesc ! dimension name from io descriptor + character(len=CS) :: subname = 'ncd_getiodesc' + !------------------------------------------------------------------------ + + ! Determining if need to create a new io descriptor + + n = 1 + found = .false. + do while (n <= num_iodesc .and. .not.found) + if (ndims == iodesc_list(n)%ndims .and. xtype == iodesc_list(n)%type) then + found = .true. + ! First found implies that dimension sizes are the same + do m = 1,ndims + if (dims(m) /= iodesc_list(n)%dims(m)) then + found = .false. + endif + enddo + ! If found - then also check that dimension names are equal - + ! dimension ids in iodescriptor are only used to query dimension + ! names associated with that iodescriptor + if (found) then + do m = 1,ndims + status = pio_inq_dimname(ncid,dimids(m),dimname_file) + status = pio_inquire(ncid, ndimensions=ndims_file) + if (iodesc_list(n)%dimids(m) > ndims_file) then + found = .false. + exit + else + status = pio_inq_dimname(ncid,iodesc_list(n)%dimids(m),dimname_iodesc) + if (trim(dimname_file) .ne. trim(dimname_iodesc)) then + found = .false. + exit + end if + end if + end do + end if + if (found) then + iodnum = n + if (iodnum > num_iodesc) then + write(iulog,*) trim(subname),' ERROR: iodnum out of range ',iodnum,num_iodesc + call shr_sys_abort() + endif + RETURN + endif + endif + n = n + 1 + enddo + + ! Creating a new io descriptor + + if (ndims > 0) then + num_iodesc = num_iodesc + 1 + if (num_iodesc > max_iodesc) then + write(iulog,*) trim(subname),' ERROR num_iodesc gt max_iodesc ',max_iodesc + call shr_sys_abort() + endif + iodnum = num_iodesc + if (mainproc .and. debug > 1) then + write(iulog,*) trim(subname),' creating iodesc at iodnum,ndims,dims(1:ndims),xtype',& + iodnum,ndims,dims(1:ndims),xtype + endif + end if + + ! Initialize the decomposition for PIO + call pio_initdecomp(pio_subsystem, xTYPE, dims(1:ndims), compDOF, iodesc_list(iodnum)%iodesc) + + iodesc_list(iodnum)%type = xtype + iodesc_list(iodnum)%ndims = ndims + iodesc_list(iodnum)%dims = 0 + iodesc_list(iodnum)%dims(1:ndims) = dims(1:ndims) + iodesc_list(iodnum)%dimids(1:ndims) = dimids(1:ndims) + + end subroutine ncd_getiodesc + + !----------------------------------------------------------------------- + + subroutine ncd_getdatetime (cdate, ctime) + ! + ! Get date and time + ! + ! Arguments + character(len=*), intent(out) :: cdate !current date + character(len=*), intent(out) :: ctime !current time + ! + ! Local variables + character(len=8) :: date !current date + character(len=10) :: time !current time + character(len=5) :: zone !zone + integer :: values(8) !temporary + integer :: ier !MPI error code + !----------------------------------------------------------------------- + + if (mainproc) then + call date_and_time (date, time, zone, values) + + cdate(1:2) = date(5:6) + cdate(3:3) = '/' + cdate(4:5) = date(7:8) + cdate(6:6) = '/' + cdate(7:8) = date(3:4) + + ctime(1:2) = time(1:2) + ctime(3:3) = ':' + ctime(4:5) = time(3:4) + ctime(6:6) = ':' + ctime(7:8) = time(5:6) + endif + + call mpi_bcast (cdate,len(cdate),MPI_CHARACTER, 0, mpicom_rof, ier) + call mpi_bcast (ctime,len(ctime),MPI_CHARACTER, 0, mpicom_rof, ier) + + end subroutine ncd_getdatetime + +end module mosart_io diff --git a/src/riverroute/mosart_physics.F90 b/src/riverroute/mosart_physics.F90 new file mode 100644 index 0000000..3700d42 --- /dev/null +++ b/src/riverroute/mosart_physics.F90 @@ -0,0 +1,574 @@ +module mosart_physics + + !----------------------------------------------------------------------- + ! Description: core code of MOSART. + ! Contains routines for solving diffusion wave and update the state of + ! hillslope, subnetwork and main channel variables + ! Developed by Hongyi Li, 12/29/2011. + !----------------------------------------------------------------------- + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod , only : SHR_CONST_REARTH, SHR_CONST_PI + use shr_sys_mod , only : shr_sys_abort + use mosart_vars , only : iulog, barrier_timers, mpicom_rof, bypass_routing_option + use mosart_data , only : Tctl, TUnit, TRunoff, TPara, ctl + use perf_mod , only : t_startf, t_stopf + use nuopc_shr_methods , only : chkerr + use ESMF , only : ESMF_FieldGet, ESMF_FieldSMM, ESMF_Finalize, & + ESMF_SUCCESS, ESMF_END_ABORT, ESMF_TERMORDER_SRCSEQ + + implicit none + private + + public :: Euler + public :: updatestate_hillslope + public :: updatestate_subnetwork + public :: updatestate_mainchannel + public :: hillsloperouting + public :: subnetworkrouting + public :: mainchannelrouting + + private :: Routing_KW + private :: CRVRMAN_nosqrt + private :: CREHT_nosqrt + private :: GRMR + private :: GRHT + private :: GRPT + private :: GRRR + private :: GRPR + + real(r8), parameter :: TINYVALUE = 1.0e-14_r8 ! double precision variable has a significance of about 16 decimal digits + real(r8), parameter :: SLOPE1def = 0.1_r8 ! here give it a small value in order to avoid the abrupt change of hydraulic radidus etc. + real(r8) :: sinatanSLOPE1defr ! 1.0/sin(atan(slope1)) + + character(*), parameter :: u_FILE_u = & + __FILE__ + +!----------------------------------------------------------------------- +contains +!----------------------------------------------------------------------- + + subroutine Euler(rc) + + ! solve the ODEs with Euler algorithm + + ! Arguments + integer, intent(out) :: rc + + ! Local variables + integer :: nt, nr, m, k, unitUp, cnt, ier !local index + real(r8) :: temp_erout, localDeltaT + real(r8) :: negchan + real(r8), pointer :: src_eroutUp(:,:) + real(r8), pointer :: dst_eroutUp(:,:) + + !------------------ + ! hillslope + !------------------ + + rc = ESMF_SUCCESS + + call t_startf('mosartr_hillslope') + do nt=1,ctl%ntracers + if (TUnit%euler_calc(nt)) then + do nr=ctl%begr,ctl%endr + if(TUnit%mask(nr) > 0) then + call hillslopeRouting(nr,nt,Tctl%DeltaT) + TRunoff%wh(nr,nt) = TRunoff%wh(nr,nt) + TRunoff%dwh(nr,nt) * Tctl%DeltaT + call UpdateState_hillslope(nr,nt) + TRunoff%etin(nr,nt) = (-TRunoff%ehout(nr,nt) + TRunoff%qsub(nr,nt)) * TUnit%area(nr) * TUnit%frac(nr) + endif + end do + endif + end do + call t_stopf('mosartr_hillslope') + + call ESMF_FieldGet(Tunit%srcfield, farrayPtr=src_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(Tunit%dstfield, farrayPtr=dst_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_eroutUp(:,:) = 0._r8 + dst_eroutUp(:,:) = 0._r8 + + TRunoff%flow = 0._r8 + TRunoff%erout_prev = 0._r8 + TRunoff%eroutup_avg = 0._r8 + TRunoff%erlat_avg = 0._r8 + negchan = 9999.0_r8 + + do m=1,Tctl%DLevelH2R + + ! accumulate/average erout at prior timestep (used in eroutUp calc) for budget analysis + do nt=1,ctl%ntracers + if (TUnit%euler_calc(nt)) then + do nr=ctl%begr,ctl%endr + TRunoff%erout_prev(nr,nt) = TRunoff%erout_prev(nr,nt) + TRunoff%erout(nr,nt) + end do + end if + end do + + !------------------ + ! subnetwork + !------------------ + + call t_startf('mosartr_subnetwork') + TRunoff%erlateral(:,:) = 0._r8 + do nt=1,ctl%ntracers + if (TUnit%euler_calc(nt)) then + do nr=ctl%begr,ctl%endr + if(TUnit%mask(nr) > 0) then + localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_t(nr) + do k=1,TUnit%numDT_t(nr) + call subnetworkRouting(nr,nt,localDeltaT) + TRunoff%wt(nr,nt) = TRunoff%wt(nr,nt) + TRunoff%dwt(nr,nt) * localDeltaT + call UpdateState_subnetwork(nr,nt) + TRunoff%erlateral(nr,nt) = TRunoff%erlateral(nr,nt)-TRunoff%etout(nr,nt) + end do ! numDT_t + TRunoff%erlateral(nr,nt) = TRunoff%erlateral(nr,nt) / TUnit%numDT_t(nr) + endif + end do ! nr + endif ! euler_calc + end do ! nt + call t_stopf('mosartr_subnetwork') + + !------------------ + ! upstream interactions + !------------------ + + if (barrier_timers) then + call t_startf('mosartr_SMeroutUp_barrier') + call mpi_barrier(mpicom_rof,ier) + call t_stopf('mosartr_SMeroutUp_barrier') + endif + + call t_startf('mosartr_SMeroutUp') + + !--- copy erout into src_eroutUp --- + TRunoff%eroutUp = 0._r8 + src_eroutUp(:,:) = 0._r8 + cnt = 0 + do nr = ctl%begr,ctl%endr + cnt = cnt + 1 + do nt = 1,ctl%ntracers + src_eroutUp(nt,cnt) = TRunoff%erout(nr,nt) + enddo + enddo + + ! --- map src_eroutUp to dst_eroutUp + call ESMF_FieldSMM(TUnit%srcfield, TUnit%dstField, TUnit%rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !--- copy mapped eroutUp to TRunoff --- + cnt = 0 + do nr = ctl%begr,ctl%endr + cnt = cnt + 1 + do nt = 1,ctl%ntracers + TRunoff%eroutUp(nr,nt) = dst_eroutUp(nt,cnt) + enddo + enddo + + call t_stopf('mosartr_SMeroutUp') + + TRunoff%eroutup_avg = TRunoff%eroutup_avg + TRunoff%eroutUp + TRunoff%erlat_avg = TRunoff%erlat_avg + TRunoff%erlateral + + !------------------ + ! channel routing + !------------------ + + call t_startf('mosartr_chanroute') + do nt=1,ctl%ntracers + if (TUnit%euler_calc(nt)) then + do nr=ctl%begr,ctl%endr + if(TUnit%mask(nr) > 0) then + localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_r(nr) + temp_erout = 0._r8 + do k=1,TUnit%numDT_r(nr) + ! TODO: is it positive (TRunoff%wr) and negative afterwards + call mainchannelRouting(nr,nt,localDeltaT) + TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) + TRunoff%dwr(nr,nt) * localDeltaT + ! check for negative channel storage + ! if(TRunoff%wr(nr,1) < -1.e-10) then + ! write(iulog,*) 'Negative channel storage! ', nr, TRunoff%wr(nr,1) + ! call shr_sys_abort('mosart: negative channel storage') + ! end if + call UpdateState_mainchannel(nr,nt) + ! erout here might be inflow to some downstream subbasin, so treat it differently than erlateral + temp_erout = temp_erout + TRunoff%erout(nr,nt) + end do + temp_erout = temp_erout / TUnit%numDT_r(nr) + TRunoff%erout(nr,nt) = temp_erout + TRunoff%flow(nr,nt) = TRunoff%flow(nr,nt) - TRunoff%erout(nr,nt) + endif + end do ! nr + endif ! euler_calc + end do ! nt + negchan = min(negchan, minval(TRunoff%wr(:,:))) + + call t_stopf('mosartr_chanroute') + end do + + ! check for negative channel storage + if (negchan < -1.e-10) then + write(iulog,*) 'Warning: Negative channel storage found! ',negchan + ! call shr_sys_abort('mosart: negative channel storage') + endif + TRunoff%flow = TRunoff%flow / Tctl%DLevelH2R + TRunoff%erout_prev = TRunoff%erout_prev / Tctl%DLevelH2R + TRunoff%eroutup_avg = TRunoff%eroutup_avg / Tctl%DLevelH2R + TRunoff%erlat_avg = TRunoff%erlat_avg / Tctl%DLevelH2R + + end subroutine Euler + + !----------------------------------------------------------------------- + + subroutine hillslopeRouting(nr, nt, theDeltaT) + ! Hillslope routing considering uniform runoff generation across hillslope + + ! Arguments + integer, intent(in) :: nr, nt + real(r8), intent(in) :: theDeltaT + + TRunoff%ehout(nr,nt) = -CREHT_nosqrt(TUnit%hslpsqrt(nr), TUnit%nh(nr), TUnit%Gxr(nr), TRunoff%yh(nr,nt)) + if(TRunoff%ehout(nr,nt) < 0._r8 .and. & + TRunoff%wh(nr,nt) + (TRunoff%qsur(nr,nt) + TRunoff%ehout(nr,nt)) * theDeltaT < TINYVALUE) then + TRunoff%ehout(nr,nt) = -(TRunoff%qsur(nr,nt) + TRunoff%wh(nr,nt) / theDeltaT) + end if + TRunoff%dwh(nr,nt) = (TRunoff%qsur(nr,nt) + TRunoff%ehout(nr,nt)) + + end subroutine hillslopeRouting + + !----------------------------------------------------------------------- + + subroutine subnetworkRouting(nr,nt,theDeltaT) + ! subnetwork channel routing + + ! Arguments + integer, intent(in) :: nr,nt + real(r8), intent(in) :: theDeltaT + + if(TUnit%tlen(nr) <= TUnit%hlen(nr)) then ! if no tributaries, not subnetwork channel routing + TRunoff%etout(nr,nt) = -TRunoff%etin(nr,nt) + else + TRunoff%vt(nr,nt) = CRVRMAN_nosqrt(TUnit%tslpsqrt(nr), TUnit%nt(nr), TRunoff%rt(nr,nt)) + TRunoff%etout(nr,nt) = -TRunoff%vt(nr,nt) * TRunoff%mt(nr,nt) + if(TRunoff%wt(nr,nt) + (TRunoff%etin(nr,nt) + TRunoff%etout(nr,nt)) * theDeltaT < TINYVALUE) then + TRunoff%etout(nr,nt) = -(TRunoff%etin(nr,nt) + TRunoff%wt(nr,nt)/theDeltaT) + if(TRunoff%mt(nr,nt) > 0._r8) then + TRunoff%vt(nr,nt) = -TRunoff%etout(nr,nt)/TRunoff%mt(nr,nt) + end if + end if + end if + TRunoff%dwt(nr,nt) = TRunoff%etin(nr,nt) + TRunoff%etout(nr,nt) + + ! check stability + ! if(TRunoff%vt(nr,nt) < -TINYVALUE .or. TRunoff%vt(nr,nt) > 30) then + ! write(iulog,*) "Numerical error in subnetworkRouting, ", nr,nt,TRunoff%vt(nr,nt) + ! end if + + end subroutine subnetworkRouting + + !----------------------------------------------------------------------- + + subroutine mainchannelRouting(nr, nt, theDeltaT) + ! main channel routing + + ! Arguments + integer, intent(in) :: nr, nt + real(r8), intent(in) :: theDeltaT + + if(Tctl%RoutingMethod == 1) then + call Routing_KW(nr, nt, theDeltaT) + else + call shr_sys_abort( "mosart: Please check the routing method! There is only 1 method currently available." ) + end if + + end subroutine mainchannelRouting + + !----------------------------------------------------------------------- + + subroutine Routing_KW(nr, nt, theDeltaT) + ! classic kinematic wave routing method + + ! Arguments + integer, intent(in) :: nr, nt + real(r8), intent(in) :: theDeltaT + + ! Local variables + integer :: k + real(r8) :: temp_gwl, temp_dwr, temp_gwl0 + + ! estimate the inflow from upstream units + TRunoff%erin(nr,nt) = 0._r8 + TRunoff%erin(nr,nt) = TRunoff%erin(nr,nt) - TRunoff%eroutUp(nr,nt) + + ! estimate the outflow + if(TUnit%rlen(nr) <= 0._r8) then ! no river network, no channel routing + TRunoff%vr(nr,nt) = 0._r8 + TRunoff%erout(nr,nt) = -TRunoff%erin(nr,nt)-TRunoff%erlateral(nr,nt) + else + if(TUnit%areaTotal2(nr)/TUnit%rwidth(nr)/TUnit%rlen(nr) > 1e6_r8) then + TRunoff%erout(nr,nt) = -TRunoff%erin(nr,nt)-TRunoff%erlateral(nr,nt) + else + TRunoff%vr(nr,nt) = CRVRMAN_nosqrt(TUnit%rslpsqrt(nr), TUnit%nr(nr), TRunoff%rr(nr,nt)) + TRunoff%erout(nr,nt) = -TRunoff%vr(nr,nt) * TRunoff%mr(nr,nt) + if(-TRunoff%erout(nr,nt) > TINYVALUE .and. TRunoff%wr(nr,nt) + & + (TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt)) * theDeltaT < TINYVALUE) then + TRunoff%erout(nr,nt) = -(TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%wr(nr,nt) / theDeltaT) + if(TRunoff%mr(nr,nt) > 0._r8) then + TRunoff%vr(nr,nt) = -TRunoff%erout(nr,nt) / TRunoff%mr(nr,nt) + end if + end if + end if + end if + + temp_gwl = TRunoff%qgwl(nr,nt) * TUnit%area(nr) * TUnit%frac(nr) + + TRunoff%dwr(nr,nt) = TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt) + temp_gwl + + if ((TRunoff%wr(nr,nt)/theDeltaT + TRunoff%dwr(nr,nt)) < -TINYVALUE .and. (trim(bypass_routing_option)/='none') ) then + write(iulog,*) 'mosart: ERROR main channel going negative: ', nr, nt + write(iulog,*) theDeltaT, TRunoff%wr(nr,nt), & + TRunoff%wr(nr,nt)/theDeltaT, TRunoff%dwr(nr,nt), temp_gwl + write(iulog,*) ' ' + endif + + ! check for stability + ! if(TRunoff%vr(nr,nt) < -TINYVALUE .or. TRunoff%vr(nr,nt) > 30) then + ! write(iulog,*) "Numerical error inRouting_KW, ", nr,nt,TRunoff%vr(nr,nt) + ! end if + + ! check for negative wr + ! if(TRunoff%wr(nr,nt) > 1._r8 .and. & + ! (TRunoff%wr(nr,nt)/theDeltaT + TRunoff%dwr(nr,nt))/TRunoff%wr(nr,nt) < -TINYVALUE) then + ! write(iulog,*) 'negative wr!', TRunoff%wr(nr,nt), TRunoff%dwr(nr,nt), temp_dwr, temp_gwl, temp_gwl0, theDeltaT + ! stop + ! end if + + end subroutine Routing_KW + + !----------------------------------------------------------------------- + + subroutine updateState_hillslope(nr,nt) + ! update the state variables at hillslope + + ! Arguments + integer, intent(in) :: nr, nt + + TRunoff%yh(nr,nt) = TRunoff%wh(nr,nt) !/ TUnit%area(nr) / TUnit%frac(nr) + + end subroutine updateState_hillslope + + !----------------------------------------------------------------------- + + subroutine updateState_subnetwork(nr,nt) + ! update the state variables in subnetwork channel + + ! Arguments + integer, intent(in) :: nr,nt + + if(TUnit%tlen(nr) > 0._r8 .and. TRunoff%wt(nr,nt) > 0._r8) then + TRunoff%mt(nr,nt) = GRMR(TRunoff%wt(nr,nt), TUnit%tlen(nr)) + TRunoff%yt(nr,nt) = GRHT(TRunoff%mt(nr,nt), TUnit%twidth(nr)) + TRunoff%pt(nr,nt) = GRPT(TRunoff%yt(nr,nt), TUnit%twidth(nr)) + TRunoff%rt(nr,nt) = GRRR(TRunoff%mt(nr,nt), TRunoff%pt(nr,nt)) + else + TRunoff%mt(nr,nt) = 0._r8 + TRunoff%yt(nr,nt) = 0._r8 + TRunoff%pt(nr,nt) = 0._r8 + TRunoff%rt(nr,nt) = 0._r8 + end if + end subroutine updateState_subnetwork + + !----------------------------------------------------------------------- + + subroutine updateState_mainchannel(nr, nt) + ! update the state variables in main channel + + ! Arguments + integer, intent(in) :: nr, nt + + if(TUnit%rlen(nr) > 0._r8 .and. TRunoff%wr(nr,nt) > 0._r8) then + TRunoff%mr(nr,nt) = GRMR(TRunoff%wr(nr,nt), TUnit%rlen(nr)) + TRunoff%yr(nr,nt) = GRHR(TRunoff%mr(nr,nt), TUnit%rwidth(nr), TUnit%rwidth0(nr), TUnit%rdepth(nr)) + TRunoff%pr(nr,nt) = GRPR(TRunoff%yr(nr,nt), TUnit%rwidth(nr), TUnit%rwidth0(nr), TUnit%rdepth(nr)) + TRunoff%rr(nr,nt) = GRRR(TRunoff%mr(nr,nt), TRunoff%pr(nr,nt)) + else + TRunoff%mr(nr,nt) = 0._r8 + TRunoff%yr(nr,nt) = 0._r8 + TRunoff%pr(nr,nt) = 0._r8 + TRunoff%rr(nr,nt) = 0._r8 + end if + end subroutine updateState_mainchannel + + !----------------------------------------------------------------------- + + function CRVRMAN_nosqrt(sqrtslp_, n_, rr_) result(v_) + ! Function for calculating channel velocity according to Manning's equation. + + ! Arguments + real(r8), intent(in) :: sqrtslp_, n_, rr_ ! sqrt(slope), manning's roughness coeff., hydraulic radius + real(r8) :: v_ ! v_ is discharge + + ! Local varaibles + real(r8) :: ftemp, vtemp + + if(rr_ <= 0._r8) then + v_ = 0._r8 + else + v_ = ((rr_*rr_)**(1._r8/3._r8)) * sqrtslp_ / n_ + end if + + end function CRVRMAN_nosqrt + + !----------------------------------------------------------------------- + + function CREHT_nosqrt(sqrthslp_, nh_, Gxr_, yh_) result(eht_) + ! Function for overland from hillslope into the sub-network channels + + ! Arguments + real(r8), intent(in) :: sqrthslp_, nh_, Gxr_, yh_ ! topographic slope, manning's roughness coeff., drainage density, overland flow depth + real(r8) :: eht_ ! velocity, specific discharge + + real(r8) :: vh_ + vh_ = CRVRMAN_nosqrt(sqrthslp_,nh_,yh_) + eht_ = Gxr_*yh_*vh_ + + end function CREHT_nosqrt + + !----------------------------------------------------------------------- + + function GRMR(wr_, rlen_) result(mr_) + ! Function for estimate wetted channel area + + ! Arguments + real(r8), intent(in) :: wr_, rlen_ ! storage of water, channel length + real(r8) :: mr_ ! wetted channel area + + mr_ = wr_ / rlen_ + end function GRMR + + !----------------------------------------------------------------------- + + function GRHT(mt_, twid_) result(ht_) + ! Function for estimating water depth assuming rectangular channel + + ! Arguments + real(r8), intent(in) :: mt_, twid_ ! wetted channel area, channel width + real(r8) :: ht_ ! water depth + + if(mt_ <= TINYVALUE) then + ht_ = 0._r8 + else + ht_ = mt_ / twid_ + end if + end function GRHT + + !----------------------------------------------------------------------- + + function GRPT(ht_, twid_) result(pt_) + ! Function for estimating wetted perimeter assuming rectangular channel + + ! Arguments + real(r8), intent(in) :: ht_, twid_ ! water depth, channel width + real(r8) :: pt_ ! wetted perimeter + + if(ht_ <= TINYVALUE) then + pt_ = 0._r8 + else + pt_ = twid_ + 2._r8 * ht_ + end if + end function GRPT + + !----------------------------------------------------------------------- + + function GRRR(mr_, pr_) result(rr_) + ! Function for estimating hydraulic radius + + ! Arguments + real(r8), intent(in) :: mr_, pr_ ! wetted area and perimeter + real(r8) :: rr_ ! hydraulic radius + + if(pr_ <= TINYVALUE) then + rr_ = 0._r8 + else + rr_ = mr_ / pr_ + end if + end function GRRR + + !----------------------------------------------------------------------- + + function GRHR(mr_, rwidth_, rwidth0_, rdepth_) result(hr_) + ! Function for estimating maximum water depth assuming rectangular channel and tropezoidal flood plain + ! here assuming the channel cross-section consists of three parts, from bottom to up, + ! part 1 is a rectangular with bankfull depth (rdep) and bankfull width (rwid) + ! part 2 is a tropezoidal, bottom width rwid and top width rwid0, height 0.1*((rwid0-rwid)/2), assuming slope is 0.1 + ! part 3 is a rectagular with the width rwid0 + + ! Arguments + real(r8), intent(in) :: mr_, rwidth_, rwidth0_, rdepth_ ! wetted channel area, channel width, flood plain wid, water depth + real(r8) :: hr_ ! water depth + + ! Local variables + real(r8) :: SLOPE1 ! slope of flood plain, TO DO + real(r8) :: deltamr_ + + SLOPE1 = SLOPE1def + if(mr_ <= TINYVALUE) then + hr_ = 0._r8 + else + if(mr_ - rdepth_*rwidth_ <= TINYVALUE) then ! not flooded + hr_ = mr_/rwidth_ + else ! if flooded, the find out the equivalent depth + if(mr_ > rdepth_*rwidth_ + (rwidth_ + rwidth0_)*SLOPE1*((rwidth0_-rwidth_)/2._r8)/2._r8 + TINYVALUE) then + deltamr_ = mr_ - rdepth_*rwidth_ - (rwidth_ + rwidth0_)*SLOPE1*((rwidth0_ - rwidth_)/2._r8)/2._r8; + hr_ = rdepth_ + SLOPE1*((rwidth0_ - rwidth_)/2._r8) + deltamr_/(rwidth0_); + else + deltamr_ = mr_ - rdepth_*rwidth_; + hr_ = rdepth_ + (-rwidth_+sqrt((rwidth_*rwidth_)+4._r8*deltamr_/SLOPE1))*SLOPE1/2._r8 + end if + end if + end if + end function GRHR + + !----------------------------------------------------------------------- + + function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) + ! Function for estimating maximum water depth assuming rectangular channel and tropezoidal flood plain + ! here assuming the channel cross-section consists of three parts, from bottom to up, + ! part 1 is a rectangular with bankfull depth (rdep) and bankfull width (rwid) + ! part 2 is a tropezoidal, bottom width rwid and top width rwid0, height 0.1*((rwid0-rwid)/2), assuming slope is 0.1 + ! part 3 is a rectagular with the width rwid0 + + ! Arguments + real(r8), intent(in) :: hr_, rwidth_, rwidth0_, rdepth_ ! wwater depth, channel width, flood plain wid, water depth + real(r8) :: pr_ ! water depth + + ! Local variables + real(r8) :: SLOPE1 ! slope of flood plain, TO DO + real(r8) :: deltahr_ + logical, save :: first_call = .true. + + SLOPE1 = SLOPE1def + if (first_call) then + sinatanSLOPE1defr = 1.0_r8/(sin(atan(SLOPE1def))) + endif + first_call = .false. + + if(hr_ < TINYVALUE) then + pr_ = 0._r8 + else + if(hr_ <= rdepth_ + TINYVALUE) then ! not flooded + pr_ = rwidth_ + 2._r8*hr_ + else + if(hr_ > rdepth_ + ((rwidth0_-rwidth_)/2._r8)*SLOPE1 + TINYVALUE) then + deltahr_ = hr_ - rdepth_ - ((rwidth0_-rwidth_)/2._r8)*SLOPE1 + pr_ = rwidth_ + 2._r8*(rdepth_ + ((rwidth0_-rwidth_)/2._r8)*SLOPE1*sinatanSLOPE1defr + deltahr_) + else + pr_ = rwidth_ + 2._r8*(rdepth_ + (hr_ - rdepth_)*sinatanSLOPE1defr) + end if + end if + end if + end function GRPR + +end module mosart_physics diff --git a/src/riverroute/mosart_restfile.F90 b/src/riverroute/mosart_restfile.F90 new file mode 100644 index 0000000..3e5c39d --- /dev/null +++ b/src/riverroute/mosart_restfile.F90 @@ -0,0 +1,460 @@ +module mosart_restfile + + ! Read from and write to the MOSART restart file. + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => shr_kind_cl, CS => shr_kind_cs + use shr_sys_mod, only : shr_sys_abort + use mosart_vars, only : iulog, inst_suffix, caseid, nsrest, & + spval, mainproc, nsrContinue, nsrBranch, nsrStartup, & + ctitle, version, username, hostname, conventions, source + use mosart_data, only : ctl, Trunoff + use mosart_histfile, only : mosart_hist_restart + use mosart_fileutils, only : getfil + use mosart_timemanager, only : timemgr_restart, get_nstep, get_curr_date + use mosart_io, only : ncd_pio_createfile, ncd_enddef, ncd_pio_openfile, ncd_pio_closefile, & + ncd_defdim, ncd_putatt, ncd_defvar, ncd_io, ncd_global, ncd_double, & + ncd_getdatetime + use pio, only : file_desc_t + + implicit none + private + + ! public member functions: + public :: mosart_rest_FileName + public :: mosart_rest_FileRead + public :: mosart_rest_FileWrite + public :: mosart_rest_Getfile + public :: mosart_rest_TimeManager + public :: mosart_rest_restart + ! + ! private member functions: + private :: restFile_read_pfile + private :: restFile_write_pfile ! Writes restart pointer file + private :: restFile_dimset + + ! true => allow case name to remain the same for branch run + ! by default this is not allowed + logical, public :: brnch_retain_casename = .false. + + ! file name for local restart pointer file + character(len=CL) :: rpntfil = 'rpointer.rof' + + ! initial conditions file name + character(len=CL), public :: finidat + + ! restart data file name for branch run + character(len=CL), public :: nrevsn + +!----------------------------------------------------------------------- +contains +!----------------------------------------------------------------------- + + subroutine mosart_rest_FileWrite( file, rdate ) + + !------------------------------------- + ! Read/write MOSART restart file. + + ! Arguments: + character(len=*) , intent(in) :: file ! output netcdf restart file + character(len=*) , intent(in) :: rdate ! restart file time stamp for name + + ! Local variables + type(file_desc_t) :: ncid ! netcdf id + integer :: i ! index + logical :: ptrfile ! write out the restart pointer file + !------------------------------------- + + ! Define dimensions and variables + + if (mainproc) then + write(iulog,*) + write(iulog,*)'restFile_open: writing MOSART restart dataset ' + write(iulog,*) + end if + call ncd_pio_createfile(ncid, trim(file)) + call restFile_dimset( ncid ) + call mosart_rest_restart ( ncid, flag='define' ) + call mosart_hist_restart ( ncid, flag='define', rdate=rdate ) + call timemgr_restart( ncid, flag='define' ) + call ncd_enddef(ncid) + + ! Write restart file variables + call mosart_rest_restart( ncid, flag='write' ) + call mosart_hist_restart ( ncid, flag='write' ) + call timemgr_restart( ncid, flag='write' ) + call ncd_pio_closefile(ncid) + + if (mainproc) then + write(iulog,*) 'Successfully wrote local restart file ',trim(file) + write(iulog,'(72a1)') ("-",i=1,60) + write(iulog,*) + end if + + ! Write restart pointer file + call restFile_write_pfile( file ) + + ! Write out diagnostic info + + if (mainproc) then + write(iulog,*) 'Successfully wrote out restart data at nstep = ',get_nstep() + write(iulog,'(72a1)') ("-",i=1,60) + end if + + end subroutine mosart_rest_FileWrite + + !----------------------------------------------------------------------- + + subroutine mosart_rest_FileRead( file ) + + !------------------------------------- + ! Read a MOSART restart file. + ! + ! Arguments + character(len=*), intent(in) :: file ! output netcdf restart file + ! + ! Local variables + type(file_desc_t) :: ncid ! netcdf id + integer :: i ! index + !------------------------------------- + + ! Read file + if (mainproc) write(iulog,*) 'Reading restart dataset' + call ncd_pio_openfile (ncid, trim(file), 0) + call mosart_rest_restart(ncid, flag='read') + call mosart_hist_restart(ncid, flag='read') + call ncd_pio_closefile(ncid) + + ! Write out diagnostic info + if (mainproc) then + write(iulog,'(72a1)') ("-",i=1,60) + write(iulog,*) 'Successfully read restart data for restart run' + write(iulog,*) + end if + + end subroutine mosart_rest_FileRead + + !----------------------------------------------------------------------- + + subroutine mosart_rest_TimeManager( file ) + + !------------------------------------- + ! Read a MOSART restart file. + ! + ! Arguments + character(len=*), intent(in) :: file ! output netcdf restart file + ! + ! Local Variables: + type(file_desc_t) :: ncid ! netcdf id + integer :: i ! index + !------------------------------------- + + ! Read file + if (mainproc) write(iulog,*) 'Reading restart Timemanger' + call ncd_pio_openfile (ncid, trim(file), 0) + call timemgr_restart(ncid, flag='read') + call ncd_pio_closefile(ncid) + + ! Write out diagnostic info + if (mainproc) then + write(iulog,'(72a1)') ("-",i=1,60) + write(iulog,*) 'Successfully read restart data for restart run' + write(iulog,*) + end if + + end subroutine mosart_rest_TimeManager + + !----------------------------------------------------------------------- + + subroutine mosart_rest_Getfile( file ) + + !------------------------------------- + ! Determine and obtain netcdf restart file + + ! Arguments: + character(len=*), intent(out) :: file ! name of netcdf restart file + + ! Local variables: + integer :: status ! return status + integer :: length ! temporary + character(len=CL) :: ftest,ctest ! temporaries + character(len=CL) :: path ! full pathname of netcdf restart file + !------------------------------------- + + ! Continue run: + ! Restart file pathname is read restart pointer file + if (nsrest==nsrContinue) then + call restFile_read_pfile( path ) + call getfil( path, file, 0 ) + end if + + ! Branch run: + ! Restart file pathname is obtained from namelist "nrevsn" + if (nsrest==nsrBranch) then + length = len_trim(nrevsn) + if (nrevsn(length-2:length) == '.nc') then + path = trim(nrevsn) + else + path = trim(nrevsn) // '.nc' + end if + call getfil( path, file, 0 ) + + ! Check case name consistency (case name must be different + ! for branch run, unless brnch_retain_casename is set) + ctest = 'xx.'//trim(caseid)//'.mosart' + ftest = 'xx.'//trim(file) + status = index(trim(ftest),trim(ctest)) + if (status /= 0 .and. .not.(brnch_retain_casename)) then + write(iulog,*) 'Must change case name on branch run if ',& + 'brnch_retain_casename namelist is not set' + write(iulog,*) 'previous case filename= ',trim(file),& + ' current case = ',trim(caseid), ' ctest = ',trim(ctest), & + ' ftest = ',trim(ftest) + call shr_sys_abort() + end if + end if + + ! Initial run + if (nsrest==nsrStartup) then + call getfil( finidat, file, 0 ) + end if + + end subroutine mosart_rest_Getfile + + !----------------------------------------------------------------------- + + subroutine restFile_read_pfile( pnamer ) + + !------------------------------------- + ! Setup restart file and perform necessary consistency checks + + ! Arguments + character(len=*), intent(out) :: pnamer ! full path of restart file + + ! Local variables + integer :: nio ! restart unit + integer :: ier ! error return from fortran open + integer :: i ! index + character(len=CL) :: locfn ! Restart pointer file name + !------------------------------------- + + ! Obtain the restart file from the restart pointer file. + ! For restart runs, the restart pointer file contains the full pathname + ! of the restart file. For branch runs, the namelist variable + ! [nrevsn] contains the full pathname of the restart file. + ! New history files are always created for branch runs. + + if (mainproc) then + write(iulog,*) 'Reading restart pointer file....' + endif + locfn = './'// trim(rpntfil)//trim(inst_suffix) + open (newunit=nio, file=trim(locfn), status='unknown', form='formatted', iostat=ier) + if (ier /= 0) then + write(iulog,'(a,i8)')'(restFile_read_pfile): failed to open file '//trim(locfn)//' ierr=',ier + call shr_sys_abort() + end if + read (nio,'(a256)') pnamer + close(nio) + if (mainproc) then + write(iulog,'(a)') 'Reading restart data.....' + write(iulog,'(72a1)') ("-",i=1,60) + end if + + end subroutine restFile_read_pfile + + !----------------------------------------------------------------------- + + subroutine restFile_write_pfile( fnamer ) + + !------------------------------------- + ! Open restart pointer file. Write names of current netcdf restart file. + ! + ! Arguments + character(len=*), intent(in) :: fnamer + ! + ! Local variables + integer :: nio ! restart pointer file unit number + integer :: ier ! error return from fortran open + character(len=CL) :: filename ! local file name + !------------------------------------- + + if (mainproc) then + filename= './'// trim(rpntfil)//trim(inst_suffix) + open (newunit=nio, file=trim(filename), status='unknown', form='formatted', iostat=ier) + if (ier /= 0) then + write(iulog,'(a,i8)')'(restFile_write_pfile): failed to open file '//trim(filename)//' ierr=',ier + call shr_sys_abort() + end if + write(nio,'(a)') fnamer + close(nio) + write(iulog,*)'Successfully wrote local restart pointer file' + end if + + end subroutine restFile_write_pfile + + !----------------------------------------------------------------------- + + character(len=CL) function mosart_rest_FileName( rdate ) + + ! Arguments + character(len=*), intent(in) :: rdate ! input date for restart file name + + mosart_rest_FileName = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//".r."//trim(rdate)//".nc" + if (mainproc) then + write(iulog,*)'writing restart file ',trim(mosart_rest_FileName),' for model date = ',rdate + end if + + end function mosart_rest_FileName + + !------------------------------------------------------------------------ + + subroutine restFile_dimset( ncid ) + + !------------------------------------- + ! Read/Write initial data from/to netCDF instantaneous initial data file + + ! Arguments + type(file_desc_t), intent(inout) :: ncid + + ! Local Variables: + integer :: dimid ! netCDF dimension id + integer :: ier ! error status + character(len= 8) :: curdate ! current date + character(len= 8) :: curtime ! current time + character(len=CL) :: str + character(len=*),parameter :: subname='restFile_dimset' + !------------------------------------- + + ! Define dimensions + + call ncd_defdim(ncid, 'nlon' , ctl%nlon , dimid) + call ncd_defdim(ncid, 'nlat' , ctl%nlat , dimid) + call ncd_defdim(ncid, 'string_length', CS , dimid) + + ! Define global attributes + + call ncd_putatt(ncid, NCD_GLOBAL, 'Conventions', trim(conventions)) + call ncd_getdatetime(curdate, curtime) + str = 'created on ' // curdate // ' ' // curtime + call ncd_putatt(ncid, NCD_GLOBAL, 'history' , trim(str)) + call ncd_putatt(ncid, NCD_GLOBAL, 'username', trim(username)) + call ncd_putatt(ncid, NCD_GLOBAL, 'host' , trim(hostname)) + call ncd_putatt(ncid, NCD_GLOBAL, 'version' , trim(version)) + call ncd_putatt(ncid, NCD_GLOBAL, 'source' , trim(source)) + call ncd_putatt(ncid, NCD_GLOBAL, 'case_title' , trim(ctitle)) + call ncd_putatt(ncid, NCD_GLOBAL, 'case_id' , trim(caseid)) + call ncd_putatt(ncid, NCD_GLOBAL, 'title', & + 'MOSART Restart information, required to continue a simulation' ) + + end subroutine restFile_dimset + + !----------------------------------------------------------------------- + + subroutine mosart_rest_restart(ncid, flag) + + !------------------------------------- + ! Read/write MOSART restart data. + ! + ! Arguments: + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + + ! Local variables + logical :: readvar ! determine if variable is on initial file + integer :: n,nt,nv ! indices + integer :: nvariables + real(r8) , pointer :: dfld(:) ! temporary array + character(len=CS) :: vname,uname + character(len=CL) :: lname + !------------------------------------- + + nvariables = 7 + do nv = 1,nvariables + do nt = 1,ctl%ntracers + + if (nv == 1) then + vname = 'VOLR_'//trim(ctl%tracer_names(nt)) + lname = 'water volume in cell (volr)' + uname = 'm3' + dfld => ctl%volr(:,nt) + elseif (nv == 2) then + vname = 'RUNOFF_'//trim(ctl%tracer_names(nt)) + lname = 'runoff (runoff)' + uname = 'm3/s' + dfld => ctl%runoff(:,nt) + elseif (nv == 3) then + vname = 'DVOLRDT_'//trim(ctl%tracer_names(nt)) + lname = 'water volume change in cell (dvolrdt)' + uname = 'mm/s' + dfld => ctl%dvolrdt(:,nt) + elseif (nv == 4) then + vname = 'WH_'//trim(ctl%tracer_names(nt)) + lname = 'surface water storage at hillslopes in cell' + uname = 'm' + dfld => Trunoff%wh(:,nt) + elseif (nv == 5) then + vname = 'WT_'//trim(ctl%tracer_names(nt)) + lname = 'water storage in tributary channels in cell' + uname = 'm3' + dfld => Trunoff%wt(:,nt) + elseif (nv == 6) then + vname = 'WR_'//trim(ctl%tracer_names(nt)) + lname = 'water storage in main channel in cell' + uname = 'm3' + dfld => Trunoff%wr(:,nt) + elseif (nv == 7) then + vname = 'EROUT_'//trim(ctl%tracer_names(nt)) + lname = 'instataneous flow out of main channel in cell' + uname = 'm3/s' + dfld => Trunoff%erout(:,nt) + else + write(iulog,*) 'ERROR: illegal nv value a ',nv + call shr_sys_abort() + endif + + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=trim(vname), & + xtype=ncd_double, dim1name='nlon', dim2name='nlat', & + long_name=trim(lname), units=trim(uname), fill_value=spval) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=trim(vname), data=dfld, dim1name='allrof', & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (nsrest == nsrContinue) then + call shr_sys_abort() + else + dfld = 0._r8 + end if + end if + end if + + enddo + enddo + + if (flag == 'read') then + do n = ctl%begr,ctl%endr + do nt = 1,ctl%ntracers + if (abs(ctl%volr(n,nt)) > 1.e30) ctl%volr(n,nt) = 0. + if (abs(ctl%runoff(n,nt)) > 1.e30) ctl%runoff(n,nt) = 0. + if (abs(ctl%dvolrdt(n,nt)) > 1.e30) ctl%dvolrdt(n,nt) = 0. + if (abs(Trunoff%wh(n,nt)) > 1.e30) Trunoff%wh(n,nt) = 0. + if (abs(Trunoff%wt(n,nt)) > 1.e30) Trunoff%wt(n,nt) = 0. + if (abs(Trunoff%wr(n,nt)) > 1.e30) Trunoff%wr(n,nt) = 0. + if (abs(Trunoff%erout(n,nt)) > 1.e30) Trunoff%erout(n,nt) = 0. + end do + if (ctl%mask(n) == 1) then + do nt = 1,ctl%ntracers + ctl%runofflnd(n,nt) = ctl%runoff(n,nt) + ctl%dvolrdtlnd(n,nt)= ctl%dvolrdt(n,nt) + end do + elseif (ctl%mask(n) >= 2) then + do nt = 1,ctl%ntracers + ctl%runoffocn(n,nt) = ctl%runoff(n,nt) + ctl%dvolrdtocn(n,nt)= ctl%dvolrdt(n,nt) + enddo + endif + enddo + endif + + end subroutine mosart_rest_restart + +end module mosart_restfile diff --git a/src/riverroute/mosart_tctl_type.F90 b/src/riverroute/mosart_tctl_type.F90 new file mode 100644 index 0000000..3571086 --- /dev/null +++ b/src/riverroute/mosart_tctl_type.F90 @@ -0,0 +1,30 @@ +module mosart_tctl_type + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + + implicit none + private + + type Tctl_type + real(r8) :: DeltaT ! Time step in seconds + integer :: DLevelH2R ! The base number of channel routing sub-time-steps within one hillslope routing step. + ! Usually channel routing requires small time steps than hillslope routing. + integer :: DLevelR ! The number of channel routing sub-time-steps at a higher level within one channel routing step at a lower level. + integer :: RoutingMethod ! Flag for routing methods. 1 --> variable storage method from SWAT model + contains + procedure :: Init + end type Tctl_type + public :: Tctl_type + +contains + + subroutine Init(this) + class(Tctl_type) :: this + + this%RoutingMethod = 1 + this%DLevelH2R = 5 + this%DLevelR = 3 + + end subroutine Init + +end module mosart_tctl_type diff --git a/src/riverroute/mosart_timemanager.F90 b/src/riverroute/mosart_timemanager.F90 new file mode 100644 index 0000000..df53ba5 --- /dev/null +++ b/src/riverroute/mosart_timemanager.F90 @@ -0,0 +1,859 @@ +module mosart_timemanager + + use shr_kind_mod , only: r8 => shr_kind_r8, CS => shr_kind_CS + use shr_sys_mod , only: shr_sys_abort + use shr_string_mod , only: shr_string_toUpper + use mosart_vars , only: isecspday, iulog, nsrest, nsrContinue, mainproc + use ESMF , only: ESMF_MAXSTR, ESMF_Calendar, ESMF_Clock, ESMF_Time, ESMF_TimeInterval, & + ESMF_TimeIntervalSet, ESMF_TimeIntervalGet, ESMF_TimeSet, ESMF_TimeGet, & + ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockAdvance, & + ESMF_CalKind_Flag, ESMF_CalendarCreate, & + ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN, ESMF_SUCCESS, ESMF_KIND_I8, & + operator(==), operator(/=), operator(<), operator(<=), & + operator(>), operator(>=), operator(-) + use mosart_io , only: ncd_defvar, ncd_io, ncd_int + use pio , only: file_desc_t + + implicit none + private + + ! Public methods + + public :: timemgr_setup ! setup startup values + public :: timemgr_init ! time manager initialization + public :: timemgr_restart ! read/write time manager restart info and restart time manager + public :: advance_timestep ! increment timestep number + public :: get_step_size ! return step size in seconds + public :: get_nstep ! return timestep number + public :: get_curr_date ! return date components at end of current timestep + public :: get_prev_date ! return date components at beginning of current timestep + public :: get_start_date ! return components of the start date + public :: get_ref_date ! return components of the reference date + public :: get_curr_time ! return components of elapsed time since reference date at end of current timestep + public :: get_prev_time ! return components of elapsed time since reference date at beg of current timestep + public :: get_calendar ! return calendar + public :: is_restart ! return true if this is a restart run + + ! Calendar types + character(len=*), public, parameter :: NO_LEAP_C = 'NO_LEAP' + character(len=*), public, parameter :: GREGORIAN_C = 'GREGORIAN' + + type(ESMF_Calendar), target :: tm_cal ! calendar + type(ESMF_Clock) :: tm_clock ! model clock + + character(len=ESMF_MAXSTR) :: calendar = NO_LEAP_C ! Calendar to use in date calculations + integer, parameter :: uninit_int = -999999999 + real(r8), parameter :: uninit_r8 = -999999999.0 + + ! Input + integer :: dtime = uninit_int ! timestep in seconds + + ! Initialization data + integer :: start_ymd = uninit_int ! starting date for run in yearmmdd format + integer :: start_tod = 0 ! starting time of day for run in seconds + integer :: stop_ymd = uninit_int ! stopping date for run in yearmmdd format + integer :: stop_tod = 0 ! stopping time of day for run in seconds + integer :: ref_ymd = uninit_int ! reference date for time coordinate in yearmmdd format + integer :: ref_tod = 0 ! reference time of day for time coordinate in seconds + + ! Data required to restart time manager: + integer :: rst_step_sec = uninit_int ! timestep size seconds + integer :: rst_start_ymd = uninit_int ! start date + integer :: rst_start_tod = uninit_int ! start time of day + integer :: rst_ref_ymd = uninit_int ! reference date + integer :: rst_ref_tod = uninit_int ! reference time of day + integer :: rst_curr_ymd = uninit_int ! current date + integer :: rst_curr_tod = uninit_int ! current time of day + character(len=ESMF_MAXSTR) :: rst_calendar ! Calendar + + integer :: cal_type = uninit_int ! calendar type + logical :: timemgr_set = .false. ! true when timemgr initialized + + ! Private module methods + private :: init_calendar + private :: init_clock + private :: timemgr_print + private :: TimeGetymd + +!========================================================================================= +contains +!========================================================================================= + + subroutine timemgr_setup( calendar_in, start_ymd_in, start_tod_in, ref_ymd_in, & + ref_tod_in, stop_ymd_in, stop_tod_in) + + ! set time manager startup values + character(len=*), optional, intent(in) :: calendar_in ! Calendar type + integer , optional, intent(in) :: start_ymd_in ! Start date (YYYYMMDD) + integer , optional, intent(in) :: start_tod_in ! Start time of day (sec) + integer , optional, intent(in) :: ref_ymd_in ! Reference date (YYYYMMDD) + integer , optional, intent(in) :: ref_tod_in ! Reference time of day (sec) + integer , optional, intent(in) :: stop_ymd_in ! Stop date (YYYYMMDD) + integer , optional, intent(in) :: stop_tod_in ! Stop time of day (sec) + character(len=*), parameter :: sub = 'timemgr_setup' + + ! timemgr_set is called in timemgr_init and timemgr_restart + if ( timemgr_set ) then + call shr_sys_abort( sub//":: timemgr_init or timemgr_restart already called" ) + end if + if (present(calendar_in) ) calendar = trim(calendar_in) + if (present(start_ymd_in)) start_ymd = start_ymd_in + if (present(start_tod_in)) start_tod = start_tod_in + if (present(ref_ymd_in) ) ref_ymd = ref_ymd_in + if (present(ref_tod_in) ) ref_tod = ref_tod_in + if (present(stop_ymd_in) ) stop_ymd = stop_ymd_in + if (present(stop_tod_in) ) stop_tod = stop_tod_in + + end subroutine timemgr_setup + + !========================================================================================= + + subroutine timemgr_init( dtime_in ) + + ! Initialize the ESMF time manager from the sync clock + + ! Arguments + integer, intent(in) :: dtime_in ! Time-step (sec) + + ! Local variables + integer :: rc ! return code + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_Time) :: curr_date ! temporary date used in logic + type(ESMF_Time) :: ref_date ! reference date for time coordinate + type(ESMF_Time) :: current ! current date (from clock) + type(ESMF_TimeInterval) :: day_step_size ! day step size + type(ESMF_TimeInterval) :: step_size ! timestep size + character(len=*), parameter :: sub = 'timemgr_init' + + dtime = real(dtime_in) + + ! Initalize calendar + call init_calendar() + + ! Initalize start date. + if ( start_ymd == uninit_int ) then + write(iulog,*)sub,': start_ymd must be specified ' + call shr_sys_abort + end if + if ( start_tod == uninit_int ) then + write(iulog,*)sub,': start_tod must be specified ' + call shr_sys_abort + end if + start_date = TimeSetymd( start_ymd, start_tod, "start_date" ) + + ! Initialize current date + curr_date = start_date + + ! Initalize stop date. + stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') + if ( stop_ymd /= uninit_int ) then + current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) + if ( current < stop_date ) stop_date = current + else + call shr_sys_abort (sub//': Must specify stop_ymd') + end if + + ! Error check + if ( stop_date <= start_date ) then + write(iulog,*)sub, ': stop date must be specified later than start date: ' + call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + if ( curr_date >= stop_date ) then + write(iulog,*)sub, ': stop date must be specified later than current date: ' + call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + + ! Initalize reference date for time coordinate. + if ( ref_ymd /= uninit_int ) then + ref_date = TimeSetymd( ref_ymd, ref_tod, "ref_date" ) + else + ref_date = start_date + end if + + ! Initialize clock + call init_clock( start_date, ref_date, curr_date, stop_date ) + + ! Print configuration summary to log file (stdout). + if (mainproc) call timemgr_print() + + timemgr_set = .true. + + end subroutine timemgr_init + + !========================================================================================= + + subroutine init_clock( start_date, ref_date, curr_date, stop_date ) + + ! Initialize the clock based on the start_date, ref_date, and curr_date + ! as well as the settings from the namelist specifying the time to stop + + ! Arguments + type(ESMF_Time), intent(in) :: start_date ! start date for run + type(ESMF_Time), intent(in) :: ref_date ! reference date for time coordinate + type(ESMF_Time), intent(in) :: curr_date ! current date (equal to start_date) + type(ESMF_Time), intent(in) :: stop_date ! stop date for run + + ! Local variables + type(ESMF_TimeInterval) :: step_size ! timestep size + type(ESMF_Time) :: current ! current date (from clock) + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + integer :: rc ! return code + character(len=*), parameter :: sub = 'init_clock' + + ! Initialize the clock + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + tm_clock = ESMF_ClockCreate(name="MOSART Time-manager clock", timeStep=step_size, startTime=start_date, & + stopTime=stop_date, refTime=ref_date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockSetup') + + ! Advance clock to the current time (in case of a restart) + call ESMF_ClockGet(tm_clock, currTime=current, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + do while( curr_date > current ) + call ESMF_ClockAdvance( tm_clock, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockAdvance') + call ESMF_ClockGet(tm_clock, currTime=current ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + end do + end subroutine init_clock + + !========================================================================================= + + function TimeSetymd( ymd, tod, desc ) + + ! Set the time by an integer as YYYYMMDD and integer seconds in the day + + ! Arguments + integer , intent(in) :: ymd ! Year, month, day YYYYMMDD + integer , intent(in) :: tod ! Time of day in seconds + character(len=*) , intent(in) :: desc ! Description of time to set + + ! Return value + type(ESMF_Time) :: TimeSetymd ! Return value + + ! Local variables + integer :: yr, mon, day ! Year, month, day as integers + integer :: rc ! return code + character(len=*), parameter :: sub = 'TimeSetymd' + + if ( (ymd < 0) .or. (tod < 0) .or. (tod > isecspday) )then + write(iulog,*) sub//': error yymmdd is a negative number or time-of-day out of bounds', & + ymd, tod + call shr_sys_abort + end if + yr = ymd / 10000 + mon = (ymd - yr*10000) / 100 + day = ymd - yr*10000 - mon*100 + call ESMF_TimeSet( TimeSetymd, yy=yr, mm=mon, dd=day, s=tod, calendar=tm_cal, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeSet: setting '//trim(desc)) + end function TimeSetymd + + !========================================================================================= + + integer function TimeGetymd( date, tod ) + + ! Get the date and time of day in ymd from ESMF Time. + ! + type(ESMF_Time), intent(inout) :: date ! Input date to convert to ymd + integer, intent(out), optional :: tod ! Time of day in seconds + ! + integer :: yr, mon, day + integer :: rc ! return code + character(len=*), parameter :: sub = 'TimeGetymd' + ! + call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + TimeGetymd = yr*10000 + mon*100 + day + if ( present( tod ) )then + call ESMF_TimeGet( date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + end if + if ( yr < 0 )then + write(iulog,*) sub//': error year is less than zero', yr + call shr_sys_abort + end if + end function TimeGetymd + + !========================================================================================= + + subroutine timemgr_restart(ncid, flag) + + ! Read/Write information needed on restart to a netcdf file. + ! + type(file_desc_t), intent(inout) :: ncid ! netcdf id + character(len=*) , intent(in) :: flag ! 'read' or 'write' + ! + integer :: yr, mon, day, tod ! Year, month, day, and second as integers + logical :: readvar ! determine if variable is on initial file + integer :: rst_caltype ! calendar type + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_Time) :: ref_date ! reference date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + type(ESMF_Time) :: current ! current date (from clock) + type(ESMF_TimeInterval) :: day_step_size ! day step size + type(ESMF_TimeInterval) :: step_size ! timestep size + integer, parameter :: noleap = 1 + integer, parameter :: gregorian = 2 + character(len=CS) :: varname + character(len=len(calendar)) :: cal + integer :: rc ! return code + character(len=*), parameter :: sub = 'timemgr_restart' + ! + if (flag == 'write') then + rst_calendar = calendar + else if (flag == 'read') then + calendar = rst_calendar + end if + varname = 'timemgr_rst_type' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='calendar type', units='unitless', flag_meanings=(/ "NO_LEAP_C", "GREGORIAN" /), & + flag_values=(/ noleap, gregorian /), ifill_value=uninit_int ) + else if (flag == 'read' .or. flag == 'write') then + if (flag== 'write') then + cal = shr_string_toUpper(calendar) + if ( trim(cal) == NO_LEAP_C ) then + rst_caltype = noleap + else if ( trim(cal) == GREGORIAN_C ) then + rst_caltype = gregorian + else + call shr_sys_abort(sub//'ERROR: unrecognized calendar specified= '//trim(calendar)) + end if + end if + call ncd_io(varname=varname, data=rst_caltype, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if (flag == 'read') then + if ( rst_caltype == noleap ) then + calendar = NO_LEAP_C + else if ( rst_caltype == gregorian ) then + calendar = GREGORIAN_C + else + write(iulog,*)sub,': unrecognized calendar type in restart file: ',rst_caltype + call shr_sys_abort( sub//'ERROR: bad calendar type in restart file') + end if + end if + end if + + if (flag == 'write') then + call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, refTime=ref_date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + rst_step_sec = dtime + rst_start_ymd = TimeGetymd( start_date, tod=rst_start_tod ) + rst_ref_ymd = TimeGetymd( ref_date, tod=rst_ref_tod ) + rst_curr_ymd = TimeGetymd( curr_date, tod=rst_curr_tod ) + end if + + varname = 'timemgr_rst_step_sec' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='seconds component of timestep size', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_step_sec, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_step_sec < 0 .or. rst_step_sec > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if + + varname = 'timemgr_rst_start_ymd' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='start date', units='YYYYMMDD', ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_start_ymd, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + end if + + varname = 'timemgr_rst_start_tod' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='start time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_start_tod, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if + + varname = 'timemgr_rst_ref_ymd' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='reference date', units='YYYYMMDD', ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_ref_ymd, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + end if + + varname = 'timemgr_rst_ref_tod' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='reference time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_ref_tod, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_start_tod < 0 .or. rst_start_tod > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if + + varname = 'timemgr_rst_curr_ymd' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='current date', units='YYYYMMDD', ifill_value=uninit_int) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_curr_ymd, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + end if + + varname = 'timemgr_rst_curr_tod' + if (flag == 'define') then + call ncd_defvar(ncid=ncid, varname=varname, xtype=ncd_int, & + long_name='current time of day', units='sec', nvalid_range=(/0,isecspday/), ifill_value=uninit_int ) + else if (flag == 'read' .or. flag == 'write') then + call ncd_io(varname=varname, data=rst_curr_tod, & + ncid=ncid, flag=flag, readvar=readvar) + if (flag=='read' .and. .not. readvar) then + if (is_restart()) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' not on file') + end if + end if + if ( rst_curr_tod < 0 .or. rst_curr_tod > isecspday ) then + call shr_sys_abort( sub//'ERROR: '//trim(varname)//' out of range') + end if + end if + + + if (flag == 'read') then + + ! Initialize calendar from restart info + call init_calendar() + + ! Initialize the timestep from restart info + dtime = rst_step_sec + + ! Initialize start date from restart info + start_date = TimeSetymd( rst_start_ymd, rst_start_tod, "start_date" ) + + ! Initialize current date from restart info + curr_date = TimeSetymd( rst_curr_ymd, rst_curr_tod, "curr_date" ) + + ! Initialize stop date from sync clock or namelist input + stop_date = TimeSetymd( 99991231, stop_tod, "stop_date" ) + + call ESMF_TimeIntervalSet( step_size, s=dtime, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting step_size') + call ESMF_TimeIntervalSet( day_step_size, d=1, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalSet: setting day_step_size') + if ( stop_ymd /= uninit_int ) then + current = TimeSetymd( stop_ymd, stop_tod, "stop_date" ) + if ( current < stop_date ) stop_date = current + else + call shr_sys_abort (sub//': Must specify stop_ymd') + end if + + ! Error check + if ( stop_date <= start_date ) then + write(iulog,*)sub, ': stop date must be specified later than start date: ' + call ESMF_TimeGet( start_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Start date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + if ( curr_date >= stop_date ) then + write(iulog,*)sub, ': stop date must be specified later than current date: ' + call ESMF_TimeGet( curr_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Current date (yr, mon, day, tod): ', yr, mon, day, tod + call ESMF_TimeGet( stop_date, yy=yr, mm=mon, dd=day, s=tod ) + write(iulog,*) ' Stop date (yr, mon, day, tod): ', yr, mon, day, tod + call shr_sys_abort + end if + + ! Initialize ref date from restart info + ref_date = TimeSetymd( rst_ref_ymd, rst_ref_tod, "ref_date" ) + + ! Initialize clock + call init_clock( start_date, ref_date, curr_date, stop_date ) + + ! Print configuration summary to log file (stdout). + if (mainproc) call timemgr_print() + + timemgr_set = .true. + + end if + + end subroutine timemgr_restart + + !========================================================================================= + + subroutine init_calendar( ) + + !--------------------------------------------------------------------------------- + ! Initialize calendar + ! + ! Local variables + type(ESMF_CalKind_Flag) :: cal_type ! calendar type + character(len=len(calendar)) :: caltmp + integer :: rc ! return code + character(len=*), parameter :: sub = 'init_calendar' + !--------------------------------------------------------------------------------- + + caltmp = shr_string_toUpper(calendar) + if ( trim(caltmp) == NO_LEAP_C ) then + cal_type = ESMF_CALKIND_NOLEAP + else if ( trim(caltmp) == GREGORIAN_C ) then + cal_type = ESMF_CALKIND_GREGORIAN + else + write(iulog,*)sub,': unrecognized calendar specified: ',calendar + call shr_sys_abort + end if + tm_cal = ESMF_CalendarCreate( name=caltmp, calkindflag=cal_type, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_CalendarSet') + + end subroutine init_calendar + + !========================================================================================= + + subroutine timemgr_print() + + !--------------------------------------------------------------------------------- + integer :: rc + integer :: yr, mon, day + integer :: nstep = uninit_int ! current step number + integer :: step_sec = uninit_int ! timestep size seconds + integer :: start_yr = uninit_int ! start year + integer :: start_mon = uninit_int ! start month + integer :: start_day = uninit_int ! start day of month + integer :: start_tod = uninit_int ! start time of day + integer :: stop_yr = uninit_int ! stop year + integer :: stop_mon = uninit_int ! stop month + integer :: stop_day = uninit_int ! stop day of month + integer :: stop_tod = uninit_int ! stop time of day + integer :: ref_yr = uninit_int ! reference year + integer :: ref_mon = uninit_int ! reference month + integer :: ref_day = uninit_int ! reference day of month + integer :: ref_tod = uninit_int ! reference time of day + integer :: curr_yr = uninit_int ! current year + integer :: curr_mon = uninit_int ! current month + integer :: curr_day = uninit_int ! current day of month + integer :: curr_tod = uninit_int ! current time of day + type(ESMF_Time) :: start_date ! start date for run + type(ESMF_Time) :: stop_date ! stop date for run + type(ESMF_Time) :: curr_date ! date of data in restart file + type(ESMF_Time) :: ref_date ! reference date + type(ESMF_TimeInterval) :: step ! Time-step + integer(ESMF_KIND_I8) :: step_no + character(len=*), parameter :: sub = 'timemgr_print' + !--------------------------------------------------------------------------------- + + call ESMF_ClockGet( tm_clock, startTime=start_date, currTime=curr_date, & + refTime=ref_date, stopTime=stop_date, timeStep=step, advanceCount=step_no, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + nstep = step_no + call ESMF_TimeIntervalGet( step, s=step_sec, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') + call ESMF_TimeGet( start_date, yy=start_yr, mm=start_mon, dd=start_day, s=start_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( stop_date, yy=stop_yr, mm=stop_mon, dd=stop_day, s=stop_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( ref_date, yy=ref_yr, mm=ref_mon, dd=ref_day, s=ref_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + call ESMF_TimeGet( curr_date, yy=curr_yr, mm=curr_mon, dd=curr_day, s=curr_tod, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + write(iulog,*)' ******** Time Manager Configuration ********' + write(iulog,*)' Calendar type: ', trim(calendar) + write(iulog,*)' Timestep size (seconds): ', step_sec + write(iulog,*)' Start date (yr mon day tod): ', start_yr, start_mon, start_day, start_tod + write(iulog,*)' Stop date (yr mon day tod): ', stop_yr, stop_mon, stop_day, stop_tod + write(iulog,*)' Reference date (yr mon day tod): ', ref_yr, ref_mon, ref_day, ref_tod + write(iulog,*)' Current step number: ', nstep + write(iulog,*)' Current date (yr mon day tod): ', curr_yr, curr_mon, curr_day, curr_tod + write(iulog,*)' ************************************************' + + end subroutine timemgr_print + + !========================================================================================= + + subroutine advance_timestep() + + ! Increment the timestep number. + + integer :: rc + character(len=*), parameter :: sub = 'advance_timestep' + + call ESMF_ClockAdvance( tm_clock, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockAdvance') + + end subroutine advance_timestep + + !========================================================================================= + + integer function get_step_size() + + ! Return the step size in seconds. + + type(ESMF_TimeInterval) :: step_size ! timestep size + integer :: rc + character(len=*), parameter :: sub = 'get_step_size' + + call ESMF_ClockGet(tm_clock, timeStep=step_size, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeIntervalGet(step_size, s=get_step_size, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockTimeIntervalGet') + + end function get_step_size + + !========================================================================================= + + integer function get_nstep() + + ! Return the timestep number. + + integer :: rc + integer(ESMF_KIND_I8) :: step_no + character(len=*), parameter :: sub = 'get_nstep' + + call ESMF_ClockGet(tm_clock, advanceCount=step_no, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + + get_nstep = step_no + + end function get_nstep + + !========================================================================================= + + subroutine get_curr_date(yr, mon, day, tod) + + ! Return date components valid at end of current timestep + + integer , intent(out) :: yr ! year + integer , intent(out) :: mon ! month + integer , intent(out) :: day ! day of month + integer , intent(out) :: tod ! time of day (seconds past 0Z) + + ! Local variables + integer :: rc + type(ESMF_Time) :: date + type(ESMF_TimeInterval) :: off + character(len=*), parameter :: sub = 'get_curr_date' + + call ESMF_ClockGet( tm_clock, currTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_curr_date + + !========================================================================================= + + subroutine get_prev_date(yr, mon, day, tod) + + ! Return date components valid at beginning of current timestep. + + ! Arguments + integer, intent(out) :: yr ! year + integer, intent(out) :: mon ! month + integer, intent(out) :: day ! day of month + integer, intent(out) :: tod ! time of day (seconds past 0Z) + + ! Local variables + integer :: rc + type(ESMF_Time) :: date + character(len=*), parameter :: sub = 'get_prev_date' + + call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_prev_date + + !========================================================================================= + + subroutine get_start_date(yr, mon, day, tod) + + ! Return date components valid at beginning of initial run. + + ! Arguments + integer, intent(out) :: yr ! year + integer, intent(out) :: mon ! month + integer, intent(out) :: day ! day of month + integer, intent(out) :: tod ! time of day (seconds past 0Z) + + ! Local variables + integer :: rc + type(ESMF_Time) :: date + character(len=*), parameter :: sub = 'get_start_date' + + call ESMF_ClockGet(tm_clock, startTime=date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_start_date + + !========================================================================================= + + subroutine get_ref_date(yr, mon, day, tod) + + ! Return date components of the reference date. + + ! Arguments + integer, intent(out) :: yr ! year + integer, intent(out) :: mon ! month + integer, intent(out) :: day ! day of month + integer, intent(out) :: tod ! time of day (seconds past 0Z) + + ! Local variables + integer :: rc + type(ESMF_Time) :: date + character(len=*), parameter :: sub = 'get_ref_date' + + call ESMF_ClockGet(tm_clock, refTime=date, rc=rc) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_TimeGet(date, yy=yr, mm=mon, dd=day, s=tod, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeGet') + + end subroutine get_ref_date + + !========================================================================================= + + subroutine get_curr_time(days, seconds) + + ! Return time components valid at end of current timestep. + ! Current time is the time interval between the current date and the reference date. + + ! Arguments + integer, intent(out) :: days ! number of whole days in time interval + integer, intent(out) :: seconds ! remaining seconds in time interval + + ! Local variables + integer :: rc + type(ESMF_Time) :: cdate, rdate + type(ESMF_TimeInterval) :: diff + character(len=*), parameter :: sub = 'get_curr_time' + + call ESMF_ClockGet( tm_clock, currTime=cdate, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + call ESMF_ClockGet( tm_clock, refTime=rdate, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet') + diff = cdate - rdate + call ESMF_TimeIntervalGet(diff, d=days, s=seconds, rc=rc) + call chkrc(rc, sub//': error return from ESMF_TimeIntervalGet') + + end subroutine get_curr_time + + !========================================================================================= + + subroutine get_prev_time(days, seconds) + + ! Return time components valid at beg of current timestep. + ! prev time is the time interval between the prev date and the reference date. + + ! Arguments + integer, intent(out) :: days ! number of whole days in time interval + integer, intent(out) :: seconds ! remaining seconds in time interval + + ! Local variables + integer :: rc + type(ESMF_Time) :: date, ref_date + type(ESMF_TimeInterval) :: diff + character(len=*), parameter :: sub = 'get_prev_time' + + call ESMF_ClockGet(tm_clock, prevTime=date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet for prevTime') + call ESMF_ClockGet(tm_clock, refTime=ref_date, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_ClockGet for refTime') + diff = date - ref_date + call ESMF_TimeIntervalGet( diff, d=days, s=seconds, rc=rc ) + call chkrc(rc, sub//': error return from ESMF_TimeintervalGet') + + end subroutine get_prev_time + + !========================================================================================= + + function get_calendar() + + ! Return calendar + character(len=ESMF_MAXSTR) :: get_calendar + + get_calendar = calendar + + end function get_calendar + + !========================================================================================= + + logical function is_restart( ) + ! Determine if restart run + if (nsrest == nsrContinue) then + is_restart = .true. + else + is_restart = .false. + end if + end function is_restart + + !========================================================================================= + + subroutine chkrc(rc, mes) + integer, intent(in) :: rc ! return code from time management library + character(len=*), intent(in) :: mes ! error message + if ( rc == ESMF_SUCCESS ) return + write(iulog,*) mes + call shr_sys_abort ('CHKRC') + end subroutine chkrc + + +end module mosart_timemanager diff --git a/src/riverroute/mosart_tparameter_type.F90 b/src/riverroute/mosart_tparameter_type.F90 new file mode 100644 index 0000000..005e290 --- /dev/null +++ b/src/riverroute/mosart_tparameter_type.F90 @@ -0,0 +1,33 @@ +module mosart_tparameter_type + + ! parameters to be calibrated. Ideally, these parameters are supposed to be uniform for one region + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + + implicit none + private + + public :: Tparameter_type + type Tparameter_type + real(r8), pointer :: c_nr(:) ! coefficient to adjust the manning's roughness of channels NOT_USED + real(r8), pointer :: c_nh(:) ! coefficient to adjust the manning's roughness of overland flow across hillslopes NOT_USED + real(r8), pointer :: c_twid(:) ! coefficient to adjust the width of sub-reach channel + contains + procedure, public :: Init + end type Tparameter_type + +contains + + subroutine Init(this, begr, endr) + + ! Arguments + class(tparameter_type) :: this + integer, intent(in) :: begr, endr + + ! Initialize TPara + allocate (this%c_twid(begr:endr)) + this%c_twid = 1.0_r8 + + end subroutine Init + +end module mosart_tparameter_type diff --git a/src/riverroute/mosart_tspatialunit_type.F90 b/src/riverroute/mosart_tspatialunit_type.F90 new file mode 100644 index 0000000..f2f9c0f --- /dev/null +++ b/src/riverroute/mosart_tspatialunit_type.F90 @@ -0,0 +1,677 @@ +module mosart_tspatialunit_type + + ! Topographic and geometric properties, applicable for both grid- and subbasin-based representations + + use shr_kind_mod, only : r8=>shr_kind_r8, CL=>SHR_KIND_CL, CS=>SHR_KIND_CS + use shr_sys_mod, only : shr_sys_abort + use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max + use shr_string_mod, only : shr_string_listGetName + use mosart_io, only : ncd_pio_openfile, compDOF + use mosart_vars, only : mainproc, mpicom_rof, iulog + use nuopc_shr_methods, only : chkerr + use ESMF, only : ESMF_Field, ESMF_RouteHandle, ESMF_Mesh, ESMF_FieldCreate, & + ESMF_FieldSMMStore, ESMF_FieldGet, ESMF_FieldSMM, & + ESMF_SUCCESS, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT, ESMF_TERMORDER_SRCSEQ + use pio, only : iosystem_desc_t, var_desc_t, io_desc_t, file_desc_t, pio_seterrorhandling, & + pio_inq_varid, pio_inq_vardimid, pio_inq_dimlen, pio_initdecomp, pio_closefile, & + pio_int, pio_double, PIO_INTERNAL_ERROR, pio_read_darray, pio_freedecomp + + implicit none + private + + type Tspatialunit_type + + ! grid properties + integer , pointer :: mask(:) ! mosart mask of mosart cell, 0=null, 1=land with dnID, 2=outlet + integer , pointer :: ID0(:) + real(r8), pointer :: lat(:) ! latitude of the centroid of the cell + real(r8), pointer :: lon(:) ! longitude of the centroid of the cell + real(r8), pointer :: area(:) ! area of local cell, [m2] + real(r8), pointer :: areaTotal(:) ! total upstream drainage area, [m2] + real(r8), pointer :: areaTotal2(:)! computed total upstream drainage area, [m2] + real(r8), pointer :: rlenTotal(:) ! length of all reaches, [m] + real(r8), pointer :: Gxr(:) ! drainage density within the cell, [1/m] + real(r8), pointer :: frac(:) ! fraction of cell included in the study area, [-] + logical , pointer :: euler_calc(:) ! flag for calculating tracers in euler + + ! hillslope properties + real(r8), pointer :: nh(:) ! manning's roughness of the hillslope (channel network excluded) + real(r8), pointer :: hslp(:) ! slope of hillslope, [-] + real(r8), pointer :: hslpsqrt(:) ! sqrt of slope of hillslope, [-] + real(r8), pointer :: hlen(:) ! length of hillslope within the cell, [m] + + ! subnetwork channel properties + real(r8), pointer :: nt(:) ! manning's roughness of the subnetwork at hillslope + real(r8), pointer :: tslp(:) ! average slope of tributaries, [-] + real(r8), pointer :: tslpsqrt(:) ! sqrt of average slope of tributaries, [-] + real(r8), pointer :: tlen(:) ! length of all sub-network reach within the cell, [m] + real(r8), pointer :: twidth(:) ! bankfull width of the sub-reach, [m] + real(r8), pointer :: twidth0(:) ! unadjusted twidth + + ! main channel properties + real(r8), pointer :: nr(:) ! manning's roughness of the main reach + real(r8), pointer :: rlen(:) ! length of main river reach, [m] + real(r8), pointer :: rslp(:) ! slope of main river reach, [-] + real(r8), pointer :: rslpsqrt(:) ! sqrt of slope of main river reach, [-] + real(r8), pointer :: rwidth(:) ! bankfull width of main reach, [m] + real(r8), pointer :: rwidth0(:) ! total width of the flood plain, [m] + real(r8), pointer :: rdepth(:) ! bankfull depth of river cross section, [m] + ! + integer , pointer :: dnID(:) ! IDs of the downstream units, corresponding to the subbasin ID in the input table + integer , pointer :: iUp(:,:) ! IDs of upstream units, corresponding to the subbasin ID in the input table + integer , pointer :: nUp(:) ! number of upstream units, maximum 8 + integer , pointer :: indexDown(:) ! indices of the downstream units in the ID array. sometimes subbasins IDs may not be continuous + integer , pointer :: numDT_r(:) ! for a main reach, the number of sub-time-steps needed for numerical stability + integer , pointer :: numDT_t(:) ! for a subnetwork reach, the number of sub-time-steps needed for numerical stability + real(r8), pointer :: phi_r(:) ! the indicator used to define numDT_r + real(r8), pointer :: phi_t(:) ! the indicator used to define numDT_t + + ! mapping + type(ESMF_Field) :: srcField + type(ESMF_Field) :: dstField + type(ESMF_RouteHandle) :: rh_direct + type(ESMF_RouteHandle) :: rh_eroutUp + + contains + + procedure, public :: Init + procedure, private :: set_routehandles + procedure, private :: set_subtimesteps + procedure, private :: set_areatotal2 + + end type Tspatialunit_type + public :: Tspatialunit_type + + character(*), parameter :: u_FILE_u = & + __FILE__ + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine Init(this, begr, endr, ntracers, mosart_euler_calc, nlon, nlat, EMesh, & + frivinp, IDkey, c_twid, DLevelR, area, gindex, outletg, pio_subsystem, rc) + + ! Arguments + class(Tspatialunit_type) :: this + integer , intent(in) :: begr, endr + integer , intent(in) :: ntracers + character(len=*) , intent(in) :: mosart_euler_calc + real(r8) , intent(in) :: area(begr:endr) + integer , intent(in) :: nlon, nlat + character(len=*) , intent(in) :: frivinp + integer , intent(in) :: IDkey(:) + real(r8) , intent(in) :: c_twid(begr:endr) + integer , intent(in) :: DLevelR + type(iosystem_desc_t) , pointer :: pio_subsystem + type(ESMF_Mesh) , intent(in) :: Emesh + integer , intent(in) :: gindex(begr:endr) + integer , intent(in) :: outletg(begr:endr) + integer , intent(out) :: rc + + ! Local variables + integer :: n + integer :: ier + type(file_desc_t) :: ncid ! pio file desc + type(var_desc_t) :: vardesc ! pio variable desc + type(io_desc_t) :: iodesc_dbl ! pio io desc + type(io_desc_t) :: iodesc_int ! pio io desc + integer :: dids(2) ! variable dimension ids + integer :: dsizes(2) ! variable dimension lengths + real(r8) :: hlen_max, rlen_min + character(len=CS) :: ctemp + character(len=*),parameter :: FORMI = '(2A,2i10)' + character(len=*),parameter :: FORMR = '(2A,2g15.7)' + character(len=*),parameter :: subname = '(mosart_tspatialunit_type_init) ' + !-------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Read in routing parameters + call ncd_pio_openfile (ncid, trim(frivinp), 0) + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + + ! Setup iodesc based on frac dids + ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) + ier = pio_inq_vardimid(ncid, vardesc, dids) + ier = pio_inq_dimlen(ncid, dids(1),dsizes(1)) + ier = pio_inq_dimlen(ncid, dids(2),dsizes(2)) + call pio_initdecomp(pio_subsystem, pio_double, dsizes, compDOF, iodesc_dbl) + call pio_initdecomp(pio_subsystem, pio_int , dsizes, compDOF, iodesc_int) + + allocate(this%euler_calc(ntracers)) + do n = 1,ntracers + call shr_string_listGetName(mosart_euler_calc, n, ctemp) + if (trim(ctemp) == 'T') then + this%euler_calc = .true. + else if (trim(ctemp) == 'F') then + this%euler_calc = .false. + else + call shr_sys_abort(trim(subname)//' mosart_euler_calc can only be T or F') + end if + end do + + ! TODO: Will be reworked after addition of extra tracers + this%euler_calc = .true. + + allocate(this%frac(begr:endr)) + ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%frac, ier) + if (mainproc) then + write(iulog,FORMR) trim(subname),' read frac ',minval(this%frac),maxval(this%frac) + end if + + ! read fdir, convert to mask + ! fdir <0 ocean, 0=outlet, >0 land + ! tunit mask is 0=ocean, 1=land, 2=outlet for mosart calcs + + allocate(this%mask(begr:endr)) + ier = pio_inq_varid(ncid, name='fdir', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_int, this%mask, ier) + if (mainproc) then + write(iulog,'(2A,2i10)') trim(subname),' read fdir mask ',minval(this%mask),maxval(this%mask) + end if + + do n = begr, endr + if (this%mask(n) < 0) then + this%mask(n) = 0 + elseif (this%mask(n) == 0) then + this%mask(n) = 2 + if (abs(this%frac(n)-1.0_r8)>1.0e-9) then + write(iulog,*) subname,' ERROR frac ne 1.0',n,this%frac(n) + call shr_sys_abort(subname//' ERROR frac ne 1.0') + endif + elseif (this%mask(n) > 0) then + this%mask(n) = 1 + if (abs(this%frac(n)-1.0_r8)>1.0e-9) then + write(iulog,*) subname,' ERROR frac ne 1.0',n,this%frac(n) + call shr_sys_abort(subname//' ERROR frac ne 1.0') + endif + else + call shr_sys_abort(subname//' this mask error') + endif + enddo + + allocate(this%ID0(begr:endr)) + ier = pio_inq_varid(ncid, name='ID', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_int, this%ID0, ier) + if (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read ID0 ',minval(this%ID0),maxval(this%ID0) + + allocate(this%dnID(begr:endr)) + ier = pio_inq_varid(ncid, name='dnID', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_int, this%dnID, ier) + if (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read dnID ',minval(this%dnID),maxval(this%dnID) + + ! RESET ID0 and dnID indices using the IDkey to be consistent with standard gindex order + do n=begr, endr + this%ID0(n) = IDkey(this%ID0(n)) + if (this%dnID(n) > 0 .and. this%dnID(n) <= nlon*nlat) then + if (IDkey(this%dnID(n)) > 0 .and. IDkey(this%dnID(n)) <= nlon*nlat) then + this%dnID(n) = IDkey(this%dnID(n)) + else + write(iulog,*) subname,' ERROR bad IDkey for this%dnID',n,this%dnID(n),IDkey(this%dnID(n)) + call shr_sys_abort(subname//' ERROR bad IDkey for this%dnID') + endif + endif + enddo + + allocate(this%area(begr:endr)) + ier = pio_inq_varid(ncid, name='area', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%area, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read area ',minval(this%area),maxval(this%area) + + do n=begr, endr + if (this%area(n) < 0._r8) this%area(n) = area(n) + if (this%area(n) /= area(n)) then + write(iulog,*) subname,' ERROR area mismatch',this%area(n),area(n) + call shr_sys_abort(subname//' ERROR area mismatch') + endif + enddo + + allocate(this%areaTotal(begr:endr)) + ier = pio_inq_varid(ncid, name='areaTotal', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%areaTotal, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read areaTotal ',minval(this%areaTotal),maxval(this%areaTotal) + + allocate(this%rlenTotal(begr:endr)) + this%rlenTotal = 0._r8 + + allocate(this%nh(begr:endr)) + ier = pio_inq_varid(ncid, name='nh', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nh, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read nh ',minval(this%nh),maxval(this%nh) + + allocate(this%hslp(begr:endr)) + ier = pio_inq_varid(ncid, name='hslp', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%hslp, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read hslp ',minval(this%hslp),maxval(this%hslp) + + allocate(this%hslpsqrt(begr:endr)) + this%hslpsqrt = 0._r8 + + allocate(this%gxr(begr:endr)) + ier = pio_inq_varid(ncid, name='gxr', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%gxr, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read gxr ',minval(this%gxr),maxval(this%gxr) + + allocate(this%hlen(begr:endr)) + this%hlen = 0._r8 + + allocate(this%tslp(begr:endr)) + ier = pio_inq_varid(ncid, name='tslp', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%tslp, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read tslp ',minval(this%tslp),maxval(this%tslp) + + allocate(this%tslpsqrt(begr:endr)) + this%tslpsqrt = 0._r8 + + allocate(this%tlen(begr:endr)) + this%tlen = 0._r8 + + allocate(this%twidth(begr:endr)) + ier = pio_inq_varid(ncid, name='twid', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%twidth, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read twidth ',minval(this%twidth),maxval(this%twidth) + + ! save twidth before adjusted below + allocate(this%twidth0(begr:endr)) + this%twidth0(begr:endr)=this%twidth(begr:endr) + + allocate(this%nt(begr:endr)) + ier = pio_inq_varid(ncid, name='nt', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nt, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read nt ',minval(this%nt),maxval(this%nt) + + allocate(this%rlen(begr:endr)) + ier = pio_inq_varid(ncid, name='rlen', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rlen, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rlen ',minval(this%rlen),maxval(this%rlen) + + allocate(this%rslp(begr:endr)) + ier = pio_inq_varid(ncid, name='rslp', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rslp, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rslp ',minval(this%rslp),maxval(this%rslp) + + allocate(this%rslpsqrt(begr:endr)) + this%rslpsqrt = 0._r8 + + allocate(this%rwidth(begr:endr)) + ier = pio_inq_varid(ncid, name='rwid', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rwidth, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rwidth ',minval(this%rwidth),maxval(this%rwidth) + + allocate(this%rwidth0(begr:endr)) + ier = pio_inq_varid(ncid, name='rwid0', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rwidth0, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rwidth0 ',minval(this%rwidth0),maxval(this%rwidth0) + + allocate(this%rdepth(begr:endr)) + ier = pio_inq_varid(ncid, name='rdep', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rdepth, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read rdepth ',minval(this%rdepth),maxval(this%rdepth) + + allocate(this%nr(begr:endr)) + ier = pio_inq_varid(ncid, name='nr', vardesc=vardesc) + call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nr, ier) + if (mainproc) write(iulog,FORMR) trim(subname),' read nr ',minval(this%nr),maxval(this%nr) + + allocate(this%nUp(begr:endr)) + this%nUp = 0 + allocate(this%iUp(begr:endr,8)) + this%iUp = 0 + allocate(this%indexDown(begr:endr)) + this%indexDown = 0 + + ! control parameters and some other derived parameters + ! estimate derived input variables + + ! add minimum value to rlen (length of main channel); rlen values can + ! be too small, leading to tlen values that are too large + + do n=begr,endr + rlen_min = sqrt(this%area(n)) + if(this%rlen(n) < rlen_min) then + this%rlen(n) = rlen_min + end if + end do + + do n=begr,endr + if(this%Gxr(n) > 0._r8) then + this%rlenTotal(n) = this%area(n)*this%Gxr(n) + end if + end do + + do n=begr,endr + if(this%rlen(n) > this%rlenTotal(n)) then + this%rlenTotal(n) = this%rlen(n) + end if + end do + + do n=begr,endr + + if(this%rlen(n) > 0._r8) then + this%hlen(n) = this%area(n) / this%rlenTotal(n) / 2._r8 + + ! constrain hlen (hillslope length) values based on cell area + hlen_max = max(1000.0_r8, sqrt(this%area(n))) + if(this%hlen(n) > hlen_max) then + this%hlen(n) = hlen_max ! allievate the outlier in drainag\e density estimation. TO DO + end if + + this%tlen(n) = this%area(n) / this%rlen(n) / 2._r8 - this%hlen(n) + + if (this%twidth(n) < 0._r8) then + this%twidth(n) = 0._r8 + end if + if ( this%tlen(n) > 0._r8 .and. & + (this%rlenTotal(n)-this%rlen(n))/this%tlen(n) > 1._r8 ) then + this%twidth(n) = c_twid(n)*this%twidth(n) * & + ((this%rlenTotal(n)-this%rlen(n))/this%tlen(n)) + end if + if (this%tlen(n) > 0._r8 .and. this%twidth(n) <= 0._r8) then + this%twidth(n) = 0._r8 + end if + else + this%hlen(n) = 0._r8 + this%tlen(n) = 0._r8 + this%twidth(n) = 0._r8 + end if + if(this%rslp(n) <= 0._r8) then + this%rslp(n) = 0.0001_r8 + end if + if(this%tslp(n) <= 0._r8) then + this%tslp(n) = 0.0001_r8 + end if + if(this%hslp(n) <= 0._r8) then + this%hslp(n) = 0.005_r8 + end if + + this%rslpsqrt(n) = sqrt(this%rslp(n)) + this%tslpsqrt(n) = sqrt(this%tslp(n)) + this%hslpsqrt(n) = sqrt(this%hslp(n)) + end do + + call pio_freedecomp(ncid, iodesc_dbl) + call pio_freedecomp(ncid, iodesc_int) + call pio_closefile(ncid) + + ! Create srcfield and dstfield - needed for mapping + this%srcfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLBound=(/1/), ungriddedUBound=(/ntracers/), gridToFieldMap=(/2/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + this%dstfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLBound=(/1/), ungriddedUBound=(/ntracers/), gridToFieldMap=(/2/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create route handles + call this%set_routehandles(begr, endr, gindex, outletg, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Compute areatotal2 + ! this basically advects upstream areas downstream and + ! adds them up as it goes until all upstream areas are accounted for + allocate(this%areatotal2(begr:endr)) + call this%set_areatotal2(begr, endr, nlon, nlat, area, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Determine subcycling time steps + allocate(this%numDT_r(begr:endr)) + allocate(this%numDT_t(begr:endr)) + allocate(this%phi_r(begr:endr)) + allocate(this%phi_t(begr:endr)) + call this%set_subtimesteps(begr, endr, DLevelR) + + end subroutine Init + + !----------------------------------------------------------------------- + + subroutine set_routehandles(this, begr, endr, gindex, outletg, rc) + + ! Arguments + class(Tspatialunit_type) :: this + integer , intent(in) :: begr, endr + integer , intent(in) :: gindex(begr:endr) + integer , intent(in) :: outletg(begr:endr) + integer , intent(out) :: rc + + ! Local variables + integer :: nn, n, cnt, nr, nt + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) + real(r8), pointer :: src_eroutUp(:,:) + real(r8), pointer :: dst_eroutUp(:,:) + real(r8), allocatable :: factorList(:) + integer , allocatable :: factorIndexList(:,:) + integer :: srcTermProcessing_Value = 0 + !-------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! --------------------------------------- + ! Calculate map for direct to outlet mapping + ! --------------------------------------- + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(this%srcfield, farrayPtr=src_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(this%dstfield, farrayPtr=dst_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + ! The route handle rh_direct will then be used in mosart_run + cnt = endr - begr + 1 + allocate(factorList(cnt)) + allocate(factorIndexList(2,cnt)) + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + if (outletg(nr) > 0) then + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = gindex(nr) + factorIndexList(2,cnt) = outletg(nr) + else + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = gindex(nr) + factorIndexList(2,cnt) = gindex(nr) + endif + enddo + + call ESMF_FieldSMMStore(this%srcField, this%dstField, this%rh_direct, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(factorList) + deallocate(factorIndexList) + + if (mainproc) write(iulog,*) " Done initializing rh_direct " + + ! --------------------------------------- + ! Compute map rh_eroutUp + ! --------------------------------------- + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(this%srcfield, farrayPtr=src_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(this%dstfield, farrayPtr=dst_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_eroutUp(:,:) = 0._r8 + dst_eroutUp(:,:) = 0._r8 + + cnt = 0 + do nr = begr,endr + if (this%dnID(nr) > 0) then + cnt = cnt + 1 + end if + end do + allocate(factorList(cnt)) + allocate(factorIndexList(2,cnt)) + cnt = 0 + do nr = begr,endr + if (this%dnID(nr) > 0) then + cnt = cnt + 1 + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = this%ID0(nr) + factorIndexList(2,cnt) = this%dnID(nr) + endif + enddo + if (mainproc) write(iulog,*) " Done initializing rh_eroutUp" + + call ESMF_FieldSMMStore(this%srcfield, this%dstfield, this%rh_eroutUp, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(factorList) + deallocate(factorIndexList) + + end subroutine set_routehandles + + !----------------------------------------------------------------------- + + subroutine set_areatotal2(this, begr, endr, nlon, nlat, area, rc) + + ! Arguments + class(Tspatialunit_type) :: this + integer , intent(in) :: begr, endr + integer , intent(in) :: nlon,nlat + real(r8) , intent(in) :: area(begr:endr) + integer , intent(out) :: rc + + ! Local variables + integer :: nr, cnt, tcnt ! indices + real(r8) :: areatot_prev, areatot_tmp, areatot_new + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) + real(r8), pointer :: src_eroutUp(:,:) + real(r8), pointer :: dst_eroutUp(:,:) + character(len=*),parameter :: subname = '(mosart_tspatialunit_type_set_areatotal2) ' + ! -------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! --------------------------------------- + ! compute areatot from area using dnID + ! --------------------------------------- + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(this%srcfield, farrayPtr=src_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(this%dstfield, farrayPtr=dst_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_eroutUp(:,:) = 0._r8 + dst_eroutUp(:,:) = 0._r8 + + ! this basically advects upstream areas downstream and + ! adds them up as it goes until all upstream areas are accounted for + + this%areatotal2(:) = 0._r8 + + ! initialize dst_eroutUp to local area and add that to areatotal2 + cnt = 0 + dst_eroutUp(:,:) = 0._r8 + do nr = begr,endr + cnt = cnt + 1 + dst_eroutUp(1,cnt) = area(nr) + this%areatotal2(nr) = area(nr) + enddo + + tcnt = 0 + areatot_prev = -99._r8 + areatot_new = -50._r8 + do while (areatot_new /= areatot_prev .and. tcnt < nlon*nlat) + + tcnt = tcnt + 1 + + ! copy dst_eroutUp to src_eroutUp for next downstream step + src_eroutUp(:,:) = 0._r8 + cnt = 0 + do nr = begr,endr + cnt = cnt + 1 + src_eroutUp(1,cnt) = dst_eroutUp(1,cnt) + enddo + + dst_eroutUp(:,:) = 0._r8 + call ESMF_FieldSMM(this%srcfield, this%dstField, this%rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! add dst_eroutUp to areatot and compute new global sum + cnt = 0 + areatot_prev = areatot_new + areatot_tmp = 0._r8 + do nr = begr,endr + cnt = cnt + 1 + this%areatotal2(nr) = this%areatotal2(nr) + dst_eroutUp(1,cnt) + areatot_tmp = areatot_tmp + this%areatotal2(nr) + enddo + call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) + + if (mainproc) then + write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new + endif + enddo + + if (areatot_new /= areatot_prev) then + write(iulog,*) trim(subname),' MOSART ERROR: areatot incorrect ',areatot_new, areatot_prev + call shr_sys_abort(trim(subname)//' MOSART ERROR areatot incorrect') + endif + + end subroutine set_areatotal2 + + !----------------------------------------------------------------------- + + subroutine set_subtimesteps(this, begr, endr, DLevelR) + + ! Set the sub-time-steps for channel routing + + ! Arguments + class(Tspatialunit_type) :: this + integer, intent(in) :: begr, endr + integer, intent(in) :: DLevelR + + ! Local variables + integer :: nr !local index + integer :: numDT_r, numDT_t + character(len=*),parameter :: subname = '(mosart_tspatialunit_type_subtimestep) ' + ! -------------------------------------------------------------- + + this%numDT_r(:) = 1 + this%numDT_t(:) = 1 + this%phi_r(:) = 0._r8 + this%phi_t(:) = 0._r8 + + do nr = begr,endr + if (this%mask(nr) > 0 .and. this%rlen(nr) > 0._r8) then + this%phi_r(nr) = this%areaTotal2(nr)*sqrt(this%rslp(nr))/(this%rlen(nr)*this%rwidth(nr)) + if (this%phi_r(nr) >= 10._r8) then + this%numDT_r(nr) = (this%numDT_r(nr)*log10(this%phi_r(nr))*DLevelR) + 1 + else + this%numDT_r(nr) = this%numDT_r(nr)*1.0_r8*DLevelR + 1 + end if + end if + if (this%numDT_r(nr) < 1) this%numDT_r(nr) = 1 + + if (this%tlen(nr) > 0._r8) then + this%phi_t(nr) = this%area(nr)*sqrt(this%tslp(nr))/(this%tlen(nr)*this%twidth(nr)) + if (this%phi_t(nr) >= 10._r8) then + this%numDT_t(nr) = (this%numDT_t(nr)*log10(this%phi_t(nr))*DLevelR) + 1 + else + this%numDT_t(nr) = (this%numDT_t(nr)*1.0*DLevelR) + 1 + end if + end if + if (this%numDT_t(nr) < 1) this%numDT_t(nr) = 1 + end do + + call shr_mpi_max(maxval(this%numDT_r),numDT_r,mpicom_rof,'numDT_r',all=.false.) + call shr_mpi_max(maxval(this%numDT_t),numDT_t,mpicom_rof,'numDT_t',all=.false.) + if (mainproc) then + write(iulog,*) subname,' DLevelR = ',DlevelR + write(iulog,*) subname,' numDT_r = ',minval(this%numDT_r),maxval(this%numDT_r) + write(iulog,*) subname,' numDT_r max = ',numDT_r + write(iulog,*) subname,' numDT_t = ',minval(this%numDT_t),maxval(this%numDT_t) + write(iulog,*) subname,' numDT_t max = ',numDT_t + endif + + end subroutine set_subtimesteps + +end module mosart_tspatialunit_type diff --git a/src/riverroute/mosart_tstatusflux_type.F90 b/src/riverroute/mosart_tstatusflux_type.F90 new file mode 100644 index 0000000..1b478fd --- /dev/null +++ b/src/riverroute/mosart_tstatusflux_type.F90 @@ -0,0 +1,162 @@ +module mosart_tstatusflux_type + + ! status and flux variables + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL + + implicit none + private + + public :: TstatusFlux_type + type TstatusFlux_type + ! hillsloope + !! states + real(r8), pointer :: wh(:,:) ! storage of surface water, [m] + real(r8), pointer :: dwh(:,:) ! change of water storage, [m/s] + real(r8), pointer :: yh(:,:) ! depth of surface water, [m] + real(r8), pointer :: wsat(:,:) ! storage of surface water within saturated area at hillslope [m] + real(r8), pointer :: wunsat(:,:) ! storage of surface water within unsaturated area at hillslope [m] + real(r8), pointer :: qhorton(:,:) ! Infiltration excess runoff generated from hillslope, [m/s] NOT_USED + real(r8), pointer :: qdunne(:,:) ! Saturation excess runoff generated from hillslope, [m/s] NOT_USED + real(r8), pointer :: qsur(:,:) ! Surface runoff generated from hillslope, [m/s] + real(r8), pointer :: qsub(:,:) ! Subsurface runoff generated from hillslope, [m/s] + real(r8), pointer :: qgwl(:,:) ! gwl runoff term from glacier, wetlands and lakes, [m/s] + !! fluxes + real(r8), pointer :: ehout(:,:) ! overland flow from hillslope into the sub-channel, [m/s] + real(r8), pointer :: asat(:,:) ! saturated area fraction from hillslope, [-] + real(r8), pointer :: esat(:,:) ! evaporation from saturated area fraction at hillslope, [m/s] + + ! subnetwork channel + !! states + real(r8), pointer :: tarea(:,:) ! area of channel water surface, [m2] + real(r8), pointer :: wt(:,:) ! storage of surface water, [m3] + real(r8), pointer :: dwt(:,:) ! change of water storage, [m3] + real(r8), pointer :: yt(:,:) ! water depth, [m] + real(r8), pointer :: mt(:,:) ! cross section area, [m2] + real(r8), pointer :: rt(:,:) ! hydraulic radii, [m] + real(r8), pointer :: pt(:,:) ! wetness perimeter, [m] + real(r8), pointer :: vt(:,:) ! flow velocity, [m/s] + real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] NOT_USED + !! fluxes + real(r8), pointer :: etin(:,:) ! lateral inflow from hillslope, including surface and subsurface runoff generation components, [m3/s] + real(r8), pointer :: etout(:,:) ! discharge from sub-network into the main reach, [m3/s] + + ! main channel + !! states + real(r8), pointer :: rarea(:,:) ! area of channel water surface, [m2] + real(r8), pointer :: wr(:,:) ! storage of surface water, [m3] + real(r8), pointer :: dwr(:,:) ! change of water storage, [m3] + real(r8), pointer :: yr(:,:) ! water depth. [m] + real(r8), pointer :: mr(:,:) ! cross section area, [m2] + real(r8), pointer :: rr(:,:) ! hydraulic radius, [m] + real(r8), pointer :: pr(:,:) ! wetness perimeter, [m] + real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] + real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] NOT_USED + !! exchange fluxes + real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] + real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] + real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] + real(r8), pointer :: erout_prev(:,:) ! outflow into downstream links from previous timestep, [m3/s] + real(r8), pointer :: eroutUp(:,:) ! outflow sum of upstream gridcells, instantaneous (m3/s) + real(r8), pointer :: eroutUp_avg(:,:) ! outflow sum of upstream gridcells, average [m3/s] + real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] + real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] + real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] NOT_USED + real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] NOT_USED + real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] NOT_USED + + !! for Runge-Kutta algorithm NOT_USED + real(r8), pointer :: wrtemp(:,:) ! temporary storage item, for 4th order Runge-Kutta algorithm; + real(r8), pointer :: erintemp(:,:) + real(r8), pointer :: erouttemp(:,:) + real(r8), pointer :: k1(:,:) + real(r8), pointer :: k2(:,:) + real(r8), pointer :: k3(:,:) + real(r8), pointer :: k4(:,:) + contains + procedure, public :: Init + end type TstatusFlux_type + +contains + + subroutine Init(this, begr, endr, ntracers) + class(TstatusFlux_type) :: this + integer, intent(in) :: begr, endr, ntracers + + ! Initialize water states and fluxes + allocate (this%wh(begr:endr,ntracers)) + this%wh = 0._r8 + allocate (this%dwh(begr:endr,ntracers)) + this%dwh = 0._r8 + allocate (this%yh(begr:endr,ntracers)) + this%yh = 0._r8 + allocate (this%qsur(begr:endr,ntracers)) + this%qsur = 0._r8 + allocate (this%qsub(begr:endr,ntracers)) + this%qsub = 0._r8 + allocate (this%qgwl(begr:endr,ntracers)) + this%qgwl = 0._r8 + allocate (this%ehout(begr:endr,ntracers)) + this%ehout = 0._r8 + allocate (this%tarea(begr:endr,ntracers)) + this%tarea = 0._r8 + allocate (this%wt(begr:endr,ntracers)) + this%wt= 0._r8 + allocate (this%dwt(begr:endr,ntracers)) + this%dwt = 0._r8 + allocate (this%yt(begr:endr,ntracers)) + this%yt = 0._r8 + allocate (this%mt(begr:endr,ntracers)) + this%mt = 0._r8 + allocate (this%rt(begr:endr,ntracers)) + this%rt = 0._r8 + allocate (this%pt(begr:endr,ntracers)) + this%pt = 0._r8 + allocate (this%vt(begr:endr,ntracers)) + this%vt = 0._r8 + allocate (this%tt(begr:endr,ntracers)) + this%tt = 0._r8 + allocate (this%etin(begr:endr,ntracers)) + this%etin = 0._r8 + allocate (this%etout(begr:endr,ntracers)) + this%etout = 0._r8 + allocate (this%rarea(begr:endr,ntracers)) + this%rarea = 0._r8 + allocate (this%wr(begr:endr,ntracers)) + this%wr = 0._r8 + allocate (this%dwr(begr:endr,ntracers)) + this%dwr = 0._r8 + allocate (this%yr(begr:endr,ntracers)) + this%yr = 0._r8 + allocate (this%mr(begr:endr,ntracers)) + this%mr = 0._r8 + allocate (this%rr(begr:endr,ntracers)) + this%rr = 0._r8 + allocate (this%pr(begr:endr,ntracers)) + this%pr = 0._r8 + allocate (this%vr(begr:endr,ntracers)) + this%vr = 0._r8 + allocate (this%tr(begr:endr,ntracers)) + this%tr = 0._r8 + allocate (this%erlateral(begr:endr,ntracers)) + this%erlateral = 0._r8 + allocate (this%erin(begr:endr,ntracers)) + this%erin = 0._r8 + allocate (this%erout(begr:endr,ntracers)) + this%erout = 0._r8 + allocate (this%erout_prev(begr:endr,ntracers)) + this%erout_prev = 0._r8 + allocate (this%eroutUp(begr:endr,ntracers)) + this%eroutUp = 0._r8 + allocate (this%eroutUp_avg(begr:endr,ntracers)) + this%eroutUp_avg = 0._r8 + allocate (this%erlat_avg(begr:endr,ntracers)) + this%erlat_avg = 0._r8 + allocate (this%ergwl(begr:endr,ntracers)) + this%ergwl = 0._r8 + allocate (this%flow(begr:endr,ntracers)) + this%flow = 0._r8 + + end subroutine Init + +end module mosart_tstatusflux_type diff --git a/src/riverroute/mosart_vars.F90 b/src/riverroute/mosart_vars.F90 new file mode 100644 index 0000000..6712c4d --- /dev/null +++ b/src/riverroute/mosart_vars.F90 @@ -0,0 +1,61 @@ +module mosart_vars + + use shr_kind_mod , only : r8 => shr_kind_r8, CL => SHR_KIND_CL, CS => shr_kind_CS + use shr_const_mod , only : SHR_CONST_CDAY,SHR_CONST_REARTH + use shr_sys_mod , only : shr_sys_abort + use ESMF , only : ESMF_VM + + implicit none + public + + ! MPI + logical :: mainproc ! proc 0 logical for printing msgs + integer :: iam ! processor number + integer :: npes ! number of processors for mosart + integer :: mpicom_rof ! communicator group for mosart + logical :: barrier_timers = .false. ! barrier timers + type(ESMF_VM) :: vm ! ESMF VM + + ! Constants + integer , parameter :: iundef = -9999999 + integer , parameter :: rundef = -9999999._r8 + real(r8) , parameter :: secspday = SHR_CONST_CDAY ! Seconds per day + integer , parameter :: isecspday = secspday ! Integer seconds per day + real(r8) , parameter :: spval = 1.e36_r8 ! special value for real data + integer , parameter :: ispval = -9999 ! special value for int data + + real(r8) :: re = SHR_CONST_REARTH*0.001_r8 ! radius of earth (km) + + ! Run startup + integer , parameter :: nsrStartup = 0 ! Startup from initial conditions + integer , parameter :: nsrContinue = 1 ! Continue from restart files + integer , parameter :: nsrBranch = 2 ! Branch from restart files + integer :: nsrest = iundef ! Type of run + + ! Namelist variables + character(len=CL) :: frivinp ! MOSART input data file name + logical :: ice_runoff ! true => runoff is split into liquid and ice, otherwise just liquid + character(len=CS) :: decomp_option ! decomp option + character(len=CS) :: bypass_routing_option ! bypass routing model method + character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff + integer :: budget_frq = -24 ! budget check frequency + + ! Metadata variables used in history and restart generation + character(len=CL) :: caseid = ' ' ! case id + character(len=CL) :: ctitle = ' ' ! case title + character(len=CL) :: hostname = ' ' ! Hostname of machine running on + character(len=CL) :: username = ' ' ! username of user running program + character(len=CL) :: version = " " ! version of program + character(len=CL) :: conventions = "CF-1.0" ! dataset conventions + character(len=CL) :: model_doi_url ! Web address of the Digital Object Identifier (DOI) for this model version + character(len=CL) :: source = "Model for Scale Adaptive River Transport MOSART1.0" ! description of this source + + ! Stdout + integer :: iulog = 6 ! "stdout" log file unit number, default is 6 + + ! Instance control + integer :: inst_index + character(len=CS) :: inst_name + character(len=CS) :: inst_suffix + +end module mosart_vars