diff --git a/cime_config/namelist_definition_mosart.xml b/cime_config/namelist_definition_mosart.xml index 5ea8bd0..f8843ef 100644 --- a/cime_config/namelist_definition_mosart.xml +++ b/cime_config/namelist_definition_mosart.xml @@ -61,20 +61,6 @@ - - char - mosart - mosart_inparm - opt,Xonly,Yonly - - Xonly - - - sparse matrix mct setting. Xonly is bfb on different pe counts, - opt and Yonly might involve partial sums - - - char mosart diff --git a/cime_config/testdefs/testlist_mosart.xml b/cime_config/testdefs/testlist_mosart.xml index b70990a..1605952 100644 --- a/cime_config/testdefs/testlist_mosart.xml +++ b/cime_config/testdefs/testlist_mosart.xml @@ -1,74 +1,68 @@ - + - - + + - + - + - + + + - + - - + + - - + - + + - + - + - + + - + - + + - - - - - - - - - - - + @@ -76,18 +70,10 @@ - - - - - - - - - - + + @@ -96,7 +82,8 @@ - + + @@ -105,7 +92,8 @@ - + + @@ -113,7 +101,8 @@ - + + @@ -122,7 +111,8 @@ - + + 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..dc506e3 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. +rtmhist_ndens = 1,1,1 +rtmhist_nhtfrq =-24,-8 +rtmhist_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/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/docs/ChangeLog b/docs/ChangeLog index d1ce81d..670f9b2 100644 --- a/docs/ChangeLog +++ b/docs/ChangeLog @@ -1,3 +1,51 @@ +=============================================================== +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..d97d2b7 100644 --- a/src/cpl/nuopc/rof_comp_nuopc.F90 +++ b/src/cpl/nuopc/rof_comp_nuopc.F90 @@ -18,19 +18,21 @@ module rof_comp_nuopc 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 : rtmlon, rtmlat, iulog, nt_rtm 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 RtmVar , only : srcfield, dstfield + use RtmSpmd , only : RtmSpmdInit, mainproc, mpicom_rof, ROFID, iam, npes use RunoffMod , only : rtmCTL - use RtmMod , only : Rtminit_namelist, Rtmini, Rtmrun + use RtmMod , only : MOSART_read_namelist, MOSART_init1, MOSART_init2, MOSART_run 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 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 + implicit none private ! except @@ -54,9 +56,8 @@ module rof_comp_nuopc integer :: flds_scalar_index_ny = 0 integer :: flds_scalar_index_nextsw_cday = 0._r8 - logical :: do_rtmflood + logical :: do_rtmflood ! If flooding is active integer :: nthrds - integer , parameter :: debug = 1 character(*), parameter :: modName = "(rof_comp_nuopc)" character(*), parameter :: u_FILE_u = & @@ -201,7 +202,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! The following call initializees the module variable mpicom_rof in RtmSpmd call RtmSpmdInit(mpicom) - ! Set ROFID - needed for the mosart code that requires MCT + ! Set ROFID 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 @@ -219,7 +220,7 @@ 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 !---------------------------------------------------------------------------- @@ -280,7 +281,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 to determine if do_flood is true in order to ! get the advertise phase correct !---------------------- @@ -366,7 +367,7 @@ 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 @@ -414,7 +415,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! - 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(do_rtmflood) !---------------------------------------------------------------------------- ! Now advertise fields @@ -490,12 +491,15 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !$ 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() + + ! Call first phase of MOSART initialization (set decomp, grid) + call MOSART_init1() + !-------------------------------- ! generate the mesh and realize fields !-------------------------------- @@ -517,7 +521,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! 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 @@ -531,6 +535,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 + !------------------------------------------------------- + ! create srcfield and dstfield - needed for mapping + !------------------------------------------------------- + + srcfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLBound=(/1/), ungriddedUBound=(/nt_rtm/), gridToFieldMap=(/2/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + dstfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLBound=(/1/), ungriddedUBound=(/nt_rtm/), gridToFieldMap=(/2/), rc=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(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosarti_mosart_init') + !-------------------------------- ! Create MOSART export state !-------------------------------- @@ -564,7 +591,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) @@ -617,7 +644,7 @@ subroutine ModelAdvance(gcomp, rc) !$ call omp_set_num_threads(nthrds) #if (defined _MEMTRACE) - if(masterproc) then + if(mainproc) then lbnum=1 call memmon_dump_fort('memmon.out','mosart_comp_nuopc_ModelAdvance:start::',lbnum) endif @@ -691,7 +718,8 @@ subroutine ModelAdvance(gcomp, rc) ! Advance mosart time step then run MOSART (export data is in rtmCTL and Trunoff data types) call advance_timestep() - call Rtmrun(rstwr, nlend, rdate) + call MOSART_run(rstwr, nlend, rdate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- ! Pack export state to mediator @@ -699,14 +727,12 @@ subroutine ModelAdvance(gcomp, rc) ! (input is rtmCTL%runoff, output is r2x) call t_startf ('lc_rof_export') - call export_fields(gcomp, 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 +744,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 !-------------------------------- @@ -743,7 +769,7 @@ subroutine ModelAdvance(gcomp, rc) call shr_file_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 +922,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..fd66a67 100644 --- a/src/cpl/nuopc/rof_import_export.F90 +++ b/src/cpl/nuopc/rof_import_export.F90 @@ -9,10 +9,9 @@ module rof_import_export 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 RtmSpmd , only : mainproc, mpicom_rof use RtmTimeManager , only : get_nstep use nuopc_shr_methods , only : chkerr @@ -59,7 +58,7 @@ subroutine advertise_fields(gcomp, flds_scalar_name, do_rtmflood, rc) ! input/output variables type(ESMF_GridComp) :: gcomp character(len=*) , intent(in) :: flds_scalar_name - logical , intent(in) :: do_rtmflood + logical , intent(in) :: do_rtmflood ! Flooding is active integer , intent(out) :: rc ! local variables @@ -220,7 +219,7 @@ 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 ',& @@ -348,7 +347,7 @@ subroutine export_fields (gcomp, rc) endif 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 @@ -432,7 +431,7 @@ 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 + if (debug > 0 .and. mainproc .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) diff --git a/src/riverroute/MOSART_physics_mod.F90 b/src/riverroute/MOSART_physics_mod.F90 index a2d327f..f9099f8 100644 --- a/src/riverroute/MOSART_physics_mod.F90 +++ b/src/riverroute/MOSART_physics_mod.F90 @@ -1,710 +1,671 @@ -!----------------------------------------------------------------------- -! -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 +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 RtmSpmd , only : mpicom_rof + use RtmVar , only : iulog, barrier_timers, nt_rtm, rtm_tracers, & + srcfield, dstfield, rh_eroutUp, bypass_routing_option + use RunoffMod , only : Tctl, TUnit, TRunoff, TPara, rtmCTL + 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 + + 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)) + character(*), parameter :: u_FILE_u = & + __FILE__ + + public :: Euler + public :: updatestate_hillslope + public :: updatestate_subnetwork + public :: updatestate_mainchannel + public :: hillsloperouting + public :: subnetworkrouting + public :: mainchannelrouting + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine Euler(rc) + + ! solve the ODEs with Euler algorithm + integer, intent(out) :: rc + + ! Local variables + integer :: iunit, 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,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') + + call ESMF_FieldGet(srcfield, farrayPtr=src_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(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,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') + + !--- copy erout into src_eroutUp --- + TRunoff%eroutUp = 0._r8 + src_eroutUp(:,:) = 0._r8 + cnt = 0 + do iunit = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + do nt = 1,nt_rtm + src_eroutUp(nt,cnt) = TRunoff%erout(iunit,nt) + enddo + enddo + + ! --- map src_eroutUp to dst_eroutUp + call ESMF_FieldSMM(srcfield, dstField, rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !--- copy mapped eroutUp to TRunoff --- + cnt = 0 + do iunit = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + do nt = 1,nt_rtm + TRunoff%eroutUp(iunit,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,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 + call UpdateState_mainchannel(iunit,nt) + ! erout here might be inflow to some downstream subbasin, so treat it differently than erlateral + temp_erout = temp_erout + TRunoff%erout(iunit,nt) + 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) + ! Hillslope routing considering uniform runoff generation across hillslope + + ! Arguments + integer, intent(in) :: iunit, nt + real(r8), intent(in) :: theDeltaT + + 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) + ! subnetwork channel routing + + ! Arguments + integer, intent(in) :: iunit,nt + real(r8), intent(in) :: theDeltaT + + 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_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) + + end subroutine subnetworkRouting + + !----------------------------------------------------------------------- + + subroutine mainchannelRouting(iunit, nt, theDeltaT) + ! main channel routing + + ! Arguments + 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) + ! classic kinematic wave routing method + + use RtmVar , only : bypass_routing_option + ! Arguments + 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 + 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_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 .and. (trim(bypass_routing_option) /= 'none') ) 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,*) ' ' + endif + + end subroutine Routing_KW + + !----------------------------------------------------------------------- + + subroutine Routing_MC(iunit, nt, theDeltaT) + ! Muskingum-Cunge routing method + + ! Arguments + integer, intent(in) :: iunit, nt + real(r8), intent(in) :: theDeltaT + + end subroutine Routing_MC + + !----------------------------------------------------------------------- + + subroutine Routing_THREW(iunit, nt, theDeltaT) + ! kinematic wave routing method from THREW model + + ! Arguments + integer, intent(in) :: iunit, nt + real(r8), intent(in) :: theDeltaT + + end subroutine Routing_THREW + + !----------------------------------------------------------------------- + + subroutine Routing_DW(iunit, nt, theDeltaT) + ! classic diffusion wave routing method + + ! Arguments + integer, intent(in) :: iunit, nt + real(r8), intent(in) :: theDeltaT + + end subroutine Routing_DW + + !----------------------------------------------------------------------- + + subroutine updateState_hillslope(iunit,nt) + ! update the state variables at hillslope + + ! Arguments + 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) + ! update the state variables in subnetwork channel + + ! Arguments + 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) + ! update the state variables in main channel + + ! Arguments + 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. + + ! Arguments + 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 + v_ = ((rr_*rr_)**(1._r8/3._r8)) * sqrt(slp_) / n_ + end if + end function CRVRMAN + + !----------------------------------------------------------------------- + + 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 + + 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(hslp_, nh_, Gxr_, yh_) result(eht_) + ! Function for overland from hillslope into the sub-network channels + + ! Arguments + 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 + + ! 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_ + return + 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_ + return + 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 + return + 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 + return + 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 + 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 + + ! Arguments + 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_*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 + + 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_)/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) + ! create a new file. if a file with the same name exists, delete it then create a new one + + ! Arguments + 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 + integer :: ios + logical :: filefound + character(len=1000) :: cmd + inquire (file=fname, exist=filefound) + if(filefound) then + 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) + ! output the simulation results into external files + + ! Arguments + 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) + + end subroutine printTest + +end module MOSART_physics_mod diff --git a/src/riverroute/RtmDateTime.F90 b/src/riverroute/RtmDateTime.F90 index 7e41a02..0afd6f7 100644 --- a/src/riverroute/RtmDateTime.F90 +++ b/src/riverroute/RtmDateTime.F90 @@ -1,58 +1,49 @@ module RtmDateTime + implicit none + public + 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 + !----------------------------------------------------------------------- + subroutine getdatetime (cdate, ctime) + ! + ! A generic Date and Time routine + ! + use RtmSpmd, only : mpicom_rof, mainproc + use mpi + ! + ! Arguments + character(len=8), intent(out) :: cdate !current date + character(len=8), 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, dimension(8) :: values !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 getdatetime end module RtmDateTime diff --git a/src/riverroute/RtmFileUtils.F90 b/src/riverroute/RtmFileUtils.F90 index 3a01acf..3f645d3 100644 --- a/src/riverroute/RtmFileUtils.F90 +++ b/src/riverroute/RtmFileUtils.F90 @@ -1,181 +1,99 @@ 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 -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! Module containing file I/O utilities + ! + ! !USES: + use shr_sys_mod , only : shr_sys_abort + use RtmSpmd , only : mainproc + use RtmVar , only : iulog + ! + ! !PUBLIC TYPES: + implicit none + private + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: get_filename !Returns filename given full pathname + public :: getfil !Obtain local copy of file + ! + !----------------------------------------------------------------------- contains -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + character(len=256) function get_filename (fulpath) - character(len=256) function get_filename (fulpath) + ! !DESCRIPTION: + ! 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 + !---------------------------------------------------------- - ! !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) - 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 - 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 + ! !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 + 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 -!------------------------------------------------------------------------ - - 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 index cfd190e..6ae4245 100644 --- a/src/riverroute/RtmHistFile.F90 +++ b/src/riverroute/RtmHistFile.F90 @@ -17,14 +17,12 @@ module RtmHistFile 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 RtmSpmd , only : mainproc use RtmIO use RtmDateTime implicit none - save private - ! ! !PUBLIC TYPES: ! @@ -196,7 +194,7 @@ subroutine RtmHistPrintflds() integer nf character(len=*),parameter :: subname = 'RTM_hist_printflds' - if (masterproc) then + if (mainproc) then write(iulog,*) trim(subname),' : number of master fields = ',nfmaster write(iulog,*)' ******* MASTER FIELD LIST *******' do nf = 1,nfmaster @@ -227,7 +225,7 @@ subroutine RtmHistHtapesBuild () character(len=*),parameter :: subname = 'hist_htapes_build' !---------------------------------------------------------- - if (masterproc) then + if (mainproc) then write(iulog,*) trim(subname),' Initializing MOSART history files' write(iulog,'(72a1)') ("-",i=1,60) call shr_sys_flush(iulog) @@ -293,7 +291,7 @@ subroutine RtmHistHtapesBuild () tape(t)%begtime = day + sec/secspday end do - if (masterproc) then + if (mainproc) then write(iulog,*) trim(subname),' Successfully initialized MOSART history files' write(iulog,'(72a1)') ("-",i=1,60) call shr_sys_flush(iulog) @@ -410,7 +408,7 @@ subroutine htapes_fieldlist() end do end do - if (masterproc) then + if (mainproc) then if (tape(t)%nflds > 0) then write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds end if @@ -449,7 +447,7 @@ subroutine htapes_fieldlist() call shr_sys_abort() end if - if (masterproc) then + if (mainproc) then write(iulog,*) 'There will be a total of ',ntapes,'MOSART history tapes' do t=1,ntapes write(iulog,*) @@ -669,7 +667,7 @@ subroutine htape_create (t, histrest) ! Create new netCDF file. It will be in define mode if ( .not. lhistrest )then - if (masterproc) then + if (mainproc) then write(iulog,*) trim(subname),' : Opening netcdf htape ', & trim(locfnh(t)) call shr_sys_flush(iulog) @@ -679,7 +677,7 @@ subroutine htape_create (t, histrest) call ncd_putatt(lnfid, ncd_global, 'comment', & "NOTE: None of the variables are weighted by land fraction!" ) else - if (masterproc) then + if (mainproc) then write(iulog,*) trim(subname),' : Opening netcdf rhtape ', & trim(locfnhr(t)) call shr_sys_flush(iulog) @@ -750,13 +748,13 @@ subroutine htape_create (t, histrest) 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 + if (mainproc)then write(iulog,*) trim(subname), & ' : Successfully defined netcdf history file ',t call shr_sys_flush(iulog) end if else - if (masterproc)then + if (mainproc)then write(iulog,*) trim(subname), & ' : Successfully defined netcdf restart history file ',t call shr_sys_flush(iulog) @@ -1024,7 +1022,7 @@ subroutine RtmHistHtapesWrapup( rstwr, nlend ) 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 + 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 @@ -1070,7 +1068,7 @@ subroutine RtmHistHtapesWrapup( rstwr, nlend ) ! Write time constant history variables call htape_timeconst(t, mode='write') - if (masterproc) then + if (mainproc) then write(iulog,*) write(iulog,*) trim(subname),' : Writing current time sample to local history file ', & trim(locfnh(t)),' at nstep = ',get_nstep(), & @@ -1120,7 +1118,7 @@ subroutine RtmHistHtapesWrapup( rstwr, nlend ) endif if (if_close(t)) then if (tape(t)%ntimes /= 0) then - if (masterproc) then + if (mainproc) then write(iulog,*) write(iulog,*) trim(subname),' : Closing local history file ',& trim(locfnh(t)),' at nstep = ', get_nstep() @@ -1131,7 +1129,7 @@ subroutine RtmHistHtapesWrapup( rstwr, nlend ) call ncd_pio_openfile (nfid(t), trim(locfnh(t)), ncd_write) end if else - if (masterproc) then + if (mainproc) then write(iulog,*) trim(subname),' : history tape ',t,': no open file to close' end if endif diff --git a/src/riverroute/RtmIO.F90 b/src/riverroute/RtmIO.F90 index 3e676ba..2dab656 100644 --- a/src/riverroute/RtmIO.F90 +++ b/src/riverroute/RtmIO.F90 @@ -12,18 +12,15 @@ module RtmIO 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 RtmSpmd , only : mainproc, 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: ! @@ -64,13 +61,8 @@ module RtmIO public file_desc_t public var_desc_t public io_desc_t -! -! !REVISION HISTORY: -! -! -! !PRIVATE MEMBER FUNCTIONS: -! + ! !PRIVATE MEMBER FUNCTIONS: interface ncd_putatt module procedure ncd_putatt_int module procedure ncd_putatt_real @@ -178,7 +170,7 @@ subroutine ncd_pio_openfile(file, 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 + else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then write(iulog,*) 'Opened existing file ', trim(fname), file%fh end if @@ -227,7 +219,7 @@ subroutine ncd_pio_createfile(file, fname) 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 + else if(pio_iotask_rank(pio_subsystem)==0 .and. mainproc) then write(iulog,*) 'Opened file ', trim(fname), ' to write', file%fh end if @@ -265,7 +257,7 @@ subroutine check_var(ncid, varname, vardesc, readvar, print_err ) ret = PIO_inq_varid (ncid, varname, vardesc) if (ret /= PIO_noerr) then readvar = .false. - if (masterproc .and. log_err) & + if (mainproc .and. log_err) & write(iulog,*) subname//': variable ',trim(varname),' is not on dataset' end if call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) @@ -485,7 +477,7 @@ subroutine ncd_inqvid(ncid,name,varid,vardesc,readvar) 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' + if (mainproc) write(iulog,*) subname//': variable ',trim(name),' is not on dataset' readvar = .false. else readvar = .true. @@ -730,7 +722,7 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & else lxtype = xtype end if - if (masterproc .and. debug > 1) then + 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 @@ -746,7 +738,6 @@ subroutine ncd_defvar_bynf(ncid, varname, xtype, ndims, dimid, varid, & status = PIO_def_var(ncid,trim(varname),lxtype,dimid0 ,vardesc) endif varid = vardesc%varid - ! ! Add attributes ! @@ -1538,7 +1529,7 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) character(len=*),parameter :: subname='ncd_io_int_var1' ! subroutine name !----------------------------------------------------------------------- - if (masterproc .and. debug > 1) then + if (mainproc .and. debug > 1) then write(iulog,*) subname//' ',trim(flag),' ',trim(varname),' ',trim(dim1name) end if @@ -1593,7 +1584,7 @@ subroutine ncd_io_int_var1(varname, data, dim1name, flag, ncid, nt, readvar) else - if (masterproc) then + if (mainproc) then write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) call shr_sys_abort() endif @@ -1641,7 +1632,7 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & character(len=*),parameter :: subname='ncd_io_log_var1' ! subroutine name !----------------------------------------------------------------------- - if (masterproc .and. debug > 1) then + if (mainproc .and. debug > 1) then write(iulog,*) subname//' ',trim(flag),' ',trim(varname) end if @@ -1709,7 +1700,7 @@ subroutine ncd_io_log_var1(varname, data, dim1name, & else - if (masterproc) then + if (mainproc) then write(iulog,*) subname//' ERROR: unsupported flag ',trim(flag) call shr_sys_abort() endif @@ -1756,7 +1747,7 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & character(len=*),parameter :: subname='ncd_io_real_var1' ! subroutine name !----------------------------------------------------------------------- - if (masterproc .and. debug > 1) then + if (mainproc .and. debug > 1) then write(iulog,*) trim(subname),' ',trim(flag),' ',trim(varname) endif @@ -1814,7 +1805,7 @@ subroutine ncd_io_real_var1(varname, data, dim1name, & endif else - if (masterproc) then + if (mainproc) then write(iulog,*) subname,' error: unsupported flag ',trim(flag) call shr_sys_abort() endif @@ -1904,7 +1895,7 @@ subroutine ncd_getiodesc(ncid, ndims, dims, dimids, xtype, iodnum) call shr_sys_abort() endif iodnum = num_iodesc - if (masterproc .and. debug > 1) then + 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 diff --git a/src/riverroute/RtmMod.F90 b/src/riverroute/RtmMod.F90 index c597256..b435b2a 100644 --- a/src/riverroute/RtmMod.F90 +++ b/src/riverroute/RtmMod.F90 @@ -1,2844 +1,2266 @@ 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 -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! Mosart Routing Model + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + use shr_mpi_mod , only : shr_mpi_sum, shr_mpi_max + use shr_const_mod , only : SHR_CONST_PI, SHR_CONST_CDAY + use RtmSpmd , only : mainproc, npes, iam, mpicom_rof, ROFID + use RtmVar , only : nt_rtm, rtm_tracers, & + re, spval, rtmlon, rtmlat, iulog, ice_runoff, & + frivinp_rtm, finidat_rtm, nrevsn_rtm, & + nsrContinue, nsrBranch, nsrStartup, nsrest, & + inst_index, inst_suffix, inst_name, decomp_option, & + bypass_routing_option, qgwl_runoff_option, barrier_timers, & + srcfield, dstfield, rh_direct, rh_eroutUp + use RtmFileUtils , only : getfil + 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 + use MOSART_physics_mod , 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 + use RtmIO + use pio + 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 + ! + ! !PRIVATE MEMBER FUNCTIONS: + private :: MOSART_SubTimestep + + ! MOSART tracers + character(len=256) :: rtm_trstr ! tracer string + + ! MOSART namelists + integer :: coupling_period ! mosart coupling period + integer :: 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), pointer :: evel(:,:) ! effective tracer velocity (m/s) + real(r8), pointer :: flow(:,:) ! mosart flow (m3/s) + real(r8), pointer :: erout_prev(:,:) ! erout previous timestep (m3/s) + real(r8), pointer :: eroutup_avg(:,:)! eroutup average over coupling period (m3/s) + real(r8), pointer :: erlat_avg(:,:) ! erlateral average over coupling period (m3/s) + + ! global MOSART grid + real(r8),pointer :: rlatc(:) ! latitude of center of 1d grid cell (deg) + real(r8),pointer :: rlonc(:) ! longitude of center 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 ! Turn flooding on + + character(len=256) :: nlfilename_rof = 'mosart_in' + character(len=256) :: fnamer ! name of netcdf restart file + character(*), parameter :: u_FILE_u = & + __FILE__ + !----------------------------------------------------------------------- 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 + !----------------------------------------------------------------------- + subroutine MOSART_read_namelist(flood_active) + ! Read and distribute mosart namelist + ! + logical, intent(out) :: flood_active + ! + ! 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= 7) :: runtyp(4) ! run type + character(len=*),parameter :: subname = '(MOSART_read_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, & + delt_mosart + + ! Preset values + 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' + + 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 (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 (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 (mainproc) then + write(iulog,*) 'define run:' + write(iulog,*) ' run type = ',runtyp(nsrest+1) + 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) + 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 (mainproc) 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 & + 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 (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 MOSART_read_namelist + + !----------------------------------------------------------------------- + + subroutine MOSART_init1() + + !------------------------------------------------- + ! Initialize MOSART grid, mask, decomp + ! + ! 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 + real(r8) :: deg2rad ! pi/180 + integer :: g, n, i, j, nr, nt ! iterators + integer :: nl,nloops ! used for decomp search + 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 :: 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 + 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 + 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 + character(len=*),parameter :: subname = '(MOSART_init1) ' + !------------------------------------------------- + + !------------------------------------------------------- + ! Intiialize MOSART pio + !------------------------------------------------------- + + call ncd_pio_init() + + !------------------------------------------------------- + ! Initialize MOSART time manager + !------------------------------------------------------- + + ! 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 (mainproc) 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 (mainproc) then + write(iulog,*) 'Read in MOSART file name: ',trim(frivinp_rtm) + 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 (mainproc) then + write(iulog,*) 'Values for rtmlon/rtmlat: ',rtmlon,rtmlat + write(iulog,*) 'Successfully read MOSART dimensions' + 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 (mainproc) 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 ( 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, 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 (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(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 - 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 + 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 (mainproc) 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 + ! 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 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 - 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 + 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 (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) + + !------------------------------------------------------- + !--- 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), nrs(0:npes-1)) !global mosart array + 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 (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 + + call t_stopf('mosarti_decomp') + + !------------------------------------------------------- + !--- Write per-processor runoff bounds depending on dbug level + !------------------------------------------------------- + + call t_startf('mosarti_print') + + if (mainproc) then + write(iulog,*) 'total runoff cells numr = ',rtmCTL%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) + 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 mpi_barrier(mpicom_rof,ier) + enddo + + call t_stopf('mosarti_print') + + !------------------------------------------------------- + ! Allocate local flux variables + !------------------------------------------------------- + + 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') + 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 + 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 + rtmCTL%dsig(nr) = dnID_global(n) + endif + enddo + 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 + + deallocate(gmask) + deallocate(rglo2gdc) + deallocate(rgdc2glo) + deallocate(dnID_global) + deallocate(area_global) + deallocate(idxocn) + + call shr_mpi_sum(lrtmarea, rtmCTL%totarea, mpicom_rof, 'mosart totarea', all=.true.) + if (mainproc) then + write(iulog,*) subname,' earth area ',4.0_r8*shr_const_pi*1.0e6_r8*re*re + write(iulog,*) subname,' MOSART area ',rtmCTL%totarea + end if + + end subroutine MOSART_init1 + + !----------------------------------------------------------------------- + + subroutine MOSART_init2(rc) + + ! Second phyas of MOSART initialization, including ESMF Mapping + ! Author: Hongyi Li + ! + ! Arguments + integer, intent(out) :: rc + ! + ! Local variables + 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 + integer :: iunit, nn, n, cnt, nr, nt + integer :: numDT_r, numDT_t + real(r8) :: areatot_prev, areatot_tmp, areatot_new + real(r8) :: hlen_max, rlen_min + integer :: tcnt + 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 + character(len=*),parameter :: FORMI = '(2A,2i10)' + character(len=*),parameter :: FORMR = '(2A,2g15.7)' + character(len=*),parameter :: subname = '(MOSART_init2)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(srcfield, farrayPtr=src_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(dstfield, farrayPtr=dst_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + ! Calculate map for direct to outlet mapping + ! The route handle rh_direct will then be used in MOSART_run + cnt = rtmCTL%endr - rtmCTL%begr + 1 + allocate(factorList(cnt)) + allocate(factorIndexList(2,cnt)) + cnt = 0 + do nr = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + if (rtmCTL%outletg(nr) > 0) then + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = rtmCTL%gindex(nr) + factorIndexList(2,cnt) = rtmCTL%outletg(nr) + else + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = rtmCTL%gindex(nr) + factorIndexList(2,cnt) = rtmCTL%gindex(nr) + endif + enddo + + call ESMF_FieldSMMStore(srcField, dstField, 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,*) subname," Done initializing rh_direct " + + ! --------------------------------------- + ! Read in data from frivinp_rtm + ! --------------------------------------- + + 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) + + 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 (mainproc) then + write(iulog,FORMR) trim(subname),' read frac ',minval(Tunit%frac),maxval(Tunit%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(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 (mainproc) then + write(iulog,'(2A,2i10)') trim(subname),' read fdir mask ',minval(Tunit%mask),maxval(Tunit%mask) + end if + + 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 (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read ID0 ',minval(Tunit%ID0),maxval(Tunit%ID0) + + 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 (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read dnID ',minval(Tunit%dnID),maxval(Tunit%dnID) + + !------------------------------------------------------- + ! RESET ID0 and dnID indices using the IDkey to be consistent + ! with standard gindex order + !------------------------------------------------------- + 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 (mainproc) write(iulog,FORMR) trim(subname),' read area ',minval(Tunit%area),maxval(Tunit%area) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read areaTotal ',minval(Tunit%areaTotal),maxval(Tunit%areaTotal) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read nh ',minval(Tunit%nh),maxval(Tunit%nh) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read hslp ',minval(Tunit%hslp),maxval(Tunit%hslp) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read gxr ',minval(Tunit%gxr),maxval(Tunit%gxr) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read tslp ',minval(Tunit%tslp),maxval(Tunit%tslp) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read twidth ',minval(Tunit%twidth),maxval(Tunit%twidth) + + ! 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 (mainproc) write(iulog,FORMR) trim(subname),' read nt ',minval(Tunit%nt),maxval(Tunit%nt) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read rlen ',minval(Tunit%rlen),maxval(Tunit%rlen) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read rslp ',minval(Tunit%rslp),maxval(Tunit%rslp) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read rwidth ',minval(Tunit%rwidth),maxval(Tunit%rwidth) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read rwidth0 ',minval(Tunit%rwidth0),maxval(Tunit%rwidth0) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read rdepth ',minval(Tunit%rdepth),maxval(Tunit%rdepth) + + 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 (mainproc) write(iulog,FORMR) trim(subname),' read nr ',minval(Tunit%nr),maxval(Tunit%nr) + + 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 + + cnt = 0 + do iunit=rtmCTL%begr,rtmCTL%endr + if(TUnit%dnID(iunit) > 0) cnt = cnt + 1 + enddo + + end if ! endr >= begr + + ! Set up pointer arrays into srcfield and dstfield + call ESMF_FieldGet(srcfield, farrayPtr=src_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(dstfield, farrayPtr=dst_eroutUp, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + src_eroutUp(:,:) = 0._r8 + dst_eroutUp(:,:) = 0._r8 + + ! Compute route handle rh_eroutUp + cnt = 0 + do iunit = rtmCTL%begr,rtmCTL%endr + if (TUnit%dnID(iunit) > 0) then + cnt = cnt + 1 + end if + end do + allocate(factorList(cnt)) + allocate(factorIndexList(2,cnt)) + cnt = 0 + do iunit = rtmCTL%begr,rtmCTL%endr + if (TUnit%dnID(iunit) > 0) then + cnt = cnt + 1 + factorList(cnt) = 1.0_r8 + factorIndexList(1,cnt) = TUnit%ID0(iunit) + factorIndexList(2,cnt) = TUnit%dnID(iunit) + endif + enddo + if (mainproc) write(iulog,*) subname," Done initializing rh_eroutUp" + + call ESMF_FieldSMMStore(srcfield, dstfield, rh_eroutUp, factorList, factorIndexList, & + ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(factorList) + deallocate(factorIndexList) + + !--- 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 dst_eroutUp to local area and add that to areatotal2 + cnt = 0 + dst_eroutUp(:,:) = 0._r8 + do nr = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + dst_eroutUp(1,cnt) = rtmCTL%area(nr) + Tunit%areatotal2(nr) = rtmCTL%area(nr) + 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 dst_eroutUp to src_eroutUp for next downstream step + src_eroutUp(:,:) = 0._r8 + cnt = 0 + do nr = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + src_eroutUp(1,cnt) = dst_eroutUp(1,cnt) + enddo + + dst_eroutUp(:,:) = 0._r8 + call ESMF_FieldSMM(srcfield, dstField, 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 = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + Tunit%areatotal2(nr) = Tunit%areatotal2(nr) + dst_eroutUp(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 (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)//' ERROR areatot incorrect') + endif + + ! control parameters + Tctl%RoutingMethod = 1 + Tctl%DLevelH2R = 5 + Tctl%DLevelR = 3 + call MOSART_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 (mainproc) 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 + + !------------------------------------------------------- + ! Read restart/initial info + !------------------------------------------------------- + + call t_startf('mosarti_restart') + if ((nsrest == nsrStartup .and. finidat_rtm /= ' ') .or. & + (nsrest == nsrContinue) .or. & + (nsrest == nsrBranch )) then + call RtmRestFileRead( file=fnamer ) + TRunoff%wh = rtmCTL%wh + TRunoff%wt = rtmCTL%wt + TRunoff%wr = rtmCTL%wr + TRunoff%erout= rtmCTL%erout + 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') + call RtmHistFldsInit() + if (nsrest==nsrStartup .or. nsrest==nsrBranch) then + call RtmHistHtapesBuild() + end if + call RtmHistFldsSet() + if (mainproc) write(iulog,*) subname,' done' + call t_stopf('mosarti_histinit') + + end subroutine MOSART_init2 + + !----------------------------------------------------------------------- + + subroutine MOSART_run(rstwr, nlend, rdate, rc) + + ! Run MOSART river routing model + ! + ! Arguments + 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 + 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 + real(r8) :: 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),parameter :: budget_tolerance = 1.0e-6 ! budget tolerance, m3/day + 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 + 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 + real(r8), pointer :: src_direct(:,:) + real(r8), pointer :: dst_direct(:,:) + + ! 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 = ' (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 .and. mainproc) 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 (mainproc) 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) + 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') + + ! 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 + + ! 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 + + 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 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(srcfield, farrayPtr=src_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(dstfield, farrayPtr=dst_direct, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !----------------------------------------------------- + !--- all frozen runoff passed direct to outlet + !----------------------------------------------------- + + nt = 2 + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + ! set euler_calc = false for frozen runoff + TUnit%euler_calc(nt) = .false. + + cnt = 0 + do nr = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + src_direct(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 ESMF_FieldSMM(srcfield, dstfield, 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 = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + dst_direct(nt,cnt) + enddo + + !----------------------------------------------------- + !--- direct to outlet qgwl + !----------------------------------------------------- + + !-- liquid runoff components + if (trim(bypass_routing_option) == 'direct_to_outlet') then + + nt = 1 + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + !--- copy direct transfer fields, convert kg/m2s to m3/s + cnt = 0 + do nr = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + if (trim(qgwl_runoff_option) == 'all') then + src_direct(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 + src_direct(nt,cnt) = TRunoff%qgwl(nr,nt) + TRunoff%qgwl(nr,nt) = 0._r8 + endif + endif + enddo + + call ESMF_FieldSMM(srcfield, dstfield, 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 = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + rtmCTL%direct(nr,nt) = rtmCTL%direct(nr,nt) + dst_direct(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 - allocate (TRunoff%wt(begr:endr,nt_rtm)) - TRunoff%wt= 0._r8 + endif - allocate (TRunoff%dwt(begr:endr,nt_rtm)) - TRunoff%dwt = 0._r8 + !------------------------------------------------------- + !--- add other direct terms, e.g. inputs outside of + !--- mosart mask, negative qsur + !------------------------------------------------------- - allocate (TRunoff%yt(begr:endr,nt_rtm)) - TRunoff%yt = 0._r8 + if (trim(bypass_routing_option) == 'direct_in_place') then + do nt = 1,nt_rtm + do nr = rtmCTL%begr,rtmCTL%endr - allocate (TRunoff%mt(begr:endr,nt_rtm)) - TRunoff%mt = 0._r8 + 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 - allocate (TRunoff%rt(begr:endr,nt_rtm)) - TRunoff%rt = 0._r8 + 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 - allocate (TRunoff%pt(begr:endr,nt_rtm)) - TRunoff%pt = 0._r8 + 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 + + src_direct(:,:) = 0._r8 + dst_direct(:,:) = 0._r8 + + 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 + src_direct(nt,cnt) = src_direct(nt,cnt) + TRunoff%qsub(nr,nt) + TRunoff%qsub(nr,nt) = 0._r8 + endif - allocate (TRunoff%vt(begr:endr,nt_rtm)) - TRunoff%vt = 0._r8 + !---- 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 - allocate (TRunoff%tt(begr:endr,nt_rtm)) - TRunoff%tt = 0._r8 + !---- water outside the basin --- + !---- *** DO NOT TURN THIS ONE OFF, conservation will fail *** --- + if (TUnit%mask(nr) > 0) then + ! mosart euler + else + 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 + endif + enddo + enddo + + call ESMF_FieldSMM(srcfield, dstfield, 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 = rtmCTL%begr,rtmCTL%endr + cnt = cnt + 1 + do nt = 1,nt_rtm + rtmCTL%direct(nr,nt) = rtmCTL%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,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 (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 + !----------------------------------- + + 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') + + ! convert TRunoff fields from m3/s to m/s before calling Euler + 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(rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call t_stopf('mosartr_euler') + + !----------------------------------- + ! 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 + + 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 (mainproc) 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),' 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),' 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),' 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,i4,f22.6)') trim(subname),' net (dv-i+o) = ',nt,budget_total + write(iulog,'(2a,i4,f22.6)') trim(subname),' eul erout lag = ',nt,budget_eroutlag + 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 - allocate (TRunoff%etin(begr:endr,nt_rtm)) - TRunoff%etin = 0._r8 + call t_stopf('mosartr_budget') + endif ! budget_check - allocate (TRunoff%etout(begr:endr,nt_rtm)) - TRunoff%etout = 0._r8 + !----------------------------------- + ! Write out MOSART history file + !----------------------------------- - allocate (TRunoff%rarea(begr:endr,nt_rtm)) - TRunoff%rarea = 0._r8 + call t_startf('mosartr_hbuf') + call RtmHistFldsSet() + call RtmHistUpdateHbuf() + call t_stopf('mosartr_hbuf') - allocate (TRunoff%wr(begr:endr,nt_rtm)) - TRunoff%wr = 0._r8 + call t_startf('mosartr_htapes') + call RtmHistHtapesWrapup( rstwr, nlend ) + call t_stopf('mosartr_htapes') - allocate (TRunoff%dwr(begr:endr,nt_rtm)) - TRunoff%dwr = 0._r8 + !----------------------------------- + ! Write out MOSART restart file + !----------------------------------- - allocate (TRunoff%yr(begr:endr,nt_rtm)) - TRunoff%yr = 0._r8 + if (rstwr) then + call t_startf('mosartr_rest') + filer = RtmRestFileName(rdate=rdate) + call RtmRestFileWrite( filer, rdate=rdate ) + call t_stopf('mosartr_rest') + end if - allocate (TRunoff%mr(begr:endr,nt_rtm)) - TRunoff%mr = 0._r8 + !----------------------------------- + ! Done + !----------------------------------- - allocate (TRunoff%rr(begr:endr,nt_rtm)) - TRunoff%rr = 0._r8 + first_call = .false. - allocate (TRunoff%pr(begr:endr,nt_rtm)) - TRunoff%pr = 0._r8 + call t_stopf('mosartr_tot') - allocate (TRunoff%vr(begr:endr,nt_rtm)) - TRunoff%vr = 0._r8 + end subroutine MOSART_run - allocate (TRunoff%tr(begr:endr,nt_rtm)) - TRunoff%tr = 0._r8 + !---------------------------------------------------------------------------- - allocate (TRunoff%erlg(begr:endr,nt_rtm)) - TRunoff%erlg = 0._r8 + subroutine MOSART_SubTimestep() - allocate (TRunoff%erlateral(begr:endr,nt_rtm)) - TRunoff%erlateral = 0._r8 + ! predescribe the sub-time-steps for channel routing - allocate (TRunoff%erin(begr:endr,nt_rtm)) - TRunoff%erin = 0._r8 + ! Local variables + integer :: iunit !local index + character(len=*),parameter :: subname = '(MOSART_SubTimestep)' - allocate (TRunoff%erout(begr:endr,nt_rtm)) - TRunoff%erout = 0._r8 + allocate(TUnit%numDT_r(rtmCTL%begr:rtmCTL%endr),TUnit%numDT_t(rtmCTL%begr:rtmCTL%endr)) + TUnit%numDT_r = 1 + TUnit%numDT_t = 1 - allocate (TRunoff%erout_prev(begr:endr,nt_rtm)) - TRunoff%erout_prev = 0._r8 + 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 - allocate (TRunoff%eroutUp(begr:endr,nt_rtm)) - TRunoff%eroutUp = 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 - allocate (TRunoff%eroutUp_avg(begr:endr,nt_rtm)) - TRunoff%eroutUp_avg = 0._r8 + 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 - 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 subroutine MOSART_SubTimestep end module RtmMod - diff --git a/src/riverroute/RtmRestFile.F90 b/src/riverroute/RtmRestFile.F90 index 19c593c..8139272 100644 --- a/src/riverroute/RtmRestFile.F90 +++ b/src/riverroute/RtmRestFile.F90 @@ -1,471 +1,450 @@ 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 - -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! Read from and write 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 : mainproc + 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 : 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 + private + ! + ! !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 + !----------------------------------------------------------------------- + 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 + + !----------------------------------------------------------------------- + subroutine RtmRestFileWrite( 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 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 (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 RtmRestFileWrite + + !----------------------------------------------------------------------- + + subroutine RtmRestFileRead( 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 RtmRestart( ncid, flag='read' ) + call RtmHistRestart(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 RtmRestFileRead + + !----------------------------------------------------------------------- + + subroutine RtmRestTimeManager( 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 RtmRestTimeManager + + !----------------------------------------------------------------------- + + subroutine RtmRestGetfile( file, path ) + + !------------------------------------- + ! Determine and obtain netcdf restart file + + ! Arguments: + 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 ) + + !------------------------------------- + ! 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=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 (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=256) :: 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=256) function RtmRestFileName( rdate ) + + ! Arguments + character(len=*), intent(in) :: rdate ! input date for restart file name + + RtmRestFileName = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//".r."//trim(rdate)//".nc" + if (mainproc) then + write(iulog,*)'writing restart file ',trim(RtmRestFileName),' for model date = ',rdate + end if + + end function RtmRestFileName + + !------------------------------------------------------------------------ + + 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=256) :: str + character(len=*),parameter :: subname='restFile_dimset' + !------------------------------------- + + ! 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) + + !------------------------------------- + ! 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 :: 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 index 99a0938..2be21a9 100644 --- a/src/riverroute/RtmSpmd.F90 +++ b/src/riverroute/RtmSpmd.F90 @@ -1,92 +1,53 @@ - 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 + ! SPMD initialization - ! Default settings valid even if there is no spmd + implicit none + private - 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 + ! Default settings valid even if there is no mpi - ! - ! Public methods - ! - public :: RtmSpmdInit ! Initialization + logical, public :: mainproc ! 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 ! component id needed for PIO - ! - ! 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 + ! Public methods + public :: RtmSpmdInit ! Initialization 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 + !----------------------------------------------------------------------- + + subroutine RtmSpmdInit(mpicom) + + !----------------------------------------------------------------------- + ! MPI initialization (number of processes, etc) + ! + ! Arguments + integer, intent(in) :: mpicom + ! + ! Local variables + integer :: ier ! return error status + integer :: maintask + !----------------------------------------------------------------------- + + ! Initialize mpi communicator group + mpicom_rof = mpicom + + ! Get my processor id + call mpi_comm_rank(mpicom_rof, iam, ier) + maintask = 0 + if (iam == maintask) then + mainproc = .true. + else + mainproc = .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 index 45e24ba..a19c52f 100644 --- a/src/riverroute/RtmTimeManager.F90 +++ b/src/riverroute/RtmTimeManager.F90 @@ -2,16 +2,16 @@ 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 RtmSpmd , only: mpicom_rof, mainproc use RtmVar , only: isecspday, iulog, nsrest, nsrContinue use RtmIO use ESMF - + use mpi implicit none private -! Public methods + ! Public methods public ::& timemgr_setup, &! setup startup values @@ -39,7 +39,6 @@ module RtmTimeManager character(len=*), public, parameter :: NO_LEAP_C = 'NO_LEAP' character(len=*), public, parameter :: GREGORIAN_C = 'GREGORIAN' - ! Private module data ! Private data for input @@ -64,7 +63,7 @@ module RtmTimeManager type(ESMF_Calendar), target, save :: & tm_cal ! calendar type(ESMF_Clock), save :: & - tm_clock ! model clock + 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 @@ -146,7 +145,7 @@ subroutine timemgr_init( dtime_in ) dtime = real(dtime_in) call timemgr_spmdbcast( ) - ! Initalize calendar + ! Initalize calendar call init_calendar() ! Initalize start date. @@ -190,7 +189,7 @@ subroutine timemgr_init( dtime_in ) call shr_sys_abort (sub//': Must specify stop_ymd or nelapse') end if - ! Error check + ! 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 ) @@ -214,12 +213,12 @@ subroutine timemgr_init( dtime_in ) 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() + if (mainproc) call timemgr_print() timemgr_set = .true. @@ -324,7 +323,7 @@ end function TimeGetymd subroutine timemgr_restart(ncid, flag) - ! Read/Write information needed on restart to a netcdf file. + ! 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' @@ -395,7 +394,7 @@ subroutine timemgr_restart(ncid, flag) 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, & @@ -511,28 +510,28 @@ subroutine timemgr_restart(ncid, flag) ! 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 @@ -549,7 +548,7 @@ subroutine timemgr_restart(ncid, flag) 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: ' @@ -567,18 +566,18 @@ subroutine timemgr_restart(ncid, flag) 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 + + ! 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() + if (mainproc) call timemgr_print() timemgr_set = .true. @@ -698,12 +697,12 @@ subroutine advance_timestep() 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 !========================================================================================= @@ -733,17 +732,17 @@ 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 !========================================================================================= @@ -770,7 +769,7 @@ 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 @@ -778,7 +777,7 @@ subroutine get_curr_date(yr, mon, day, tod, offset) tod ! time of day (seconds past 0Z) integer, optional, intent(in) :: offset ! Offset from current time in seconds. - ! Positive for future times, negative + ! Positive for future times, negative ! for previous times. character(len=*), parameter :: sub = 'rtm::get_curr_date' @@ -958,7 +957,7 @@ function get_calendar() end function get_calendar !========================================================================================= - + function is_end_curr_day() ! Return true if current timestep is last timestep in current day. @@ -1057,14 +1056,14 @@ function to_upper(str) 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 !========================================================================================= diff --git a/src/riverroute/RtmVar.F90 b/src/riverroute/RtmVar.F90 index 744cf01..75dc480 100644 --- a/src/riverroute/RtmVar.F90 +++ b/src/riverroute/RtmVar.F90 @@ -3,7 +3,8 @@ 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 + use RtmSpmd , only : mainproc + use ESMF implicit none @@ -32,13 +33,9 @@ module RtmVar 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=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=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 @@ -58,8 +55,8 @@ module RtmVar 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 + 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) @@ -68,6 +65,12 @@ module RtmVar logical, private :: RtmVar_isset = .false. + 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 + !================================================================================ contains !================================================================================ @@ -108,7 +111,7 @@ end subroutine RtmVarSet !================================================================================ subroutine RtmVarInit( ) - if (masterproc) then + if (mainproc) then if (nsrest == iundef) then call shr_sys_abort( 'RtmVarInit ERROR:: must set nsrest' ) end if @@ -124,7 +127,7 @@ subroutine RtmVarInit( ) 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 + endif RtmVar_isset = .true. end subroutine RtmVarInit diff --git a/src/riverroute/RunoffMod.F90 b/src/riverroute/RunoffMod.F90 index 995be6c..a404bff 100644 --- a/src/riverroute/RunoffMod.F90 +++ b/src/riverroute/RunoffMod.F90 @@ -10,27 +10,13 @@ module RunoffMod ! ! !USES: use shr_kind_mod, only : r8 => shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort 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 @@ -41,7 +27,7 @@ module RunoffMod integer , pointer :: dsig(:) ! downstream index, global index integer , pointer :: outletg(:) ! outlet index, global index - ! - global + ! - 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 @@ -103,12 +89,11 @@ module RunoffMod real(r8), pointer :: qsub_nt2(:) real(r8), pointer :: qgwl_nt1(:) real(r8), pointer :: qgwl_nt2(:) - end type runoff_flow - + !== Hongyi - ! constrol information + ! 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 @@ -116,17 +101,17 @@ module RunoffMod 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, + 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. + 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 :: 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 @@ -137,16 +122,16 @@ module RunoffMod 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), 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(:) + 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] @@ -157,25 +142,24 @@ module RunoffMod 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 :: 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] + 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 :: 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 + 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 :: 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] @@ -183,9 +167,9 @@ module RunoffMod 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 @@ -230,7 +214,7 @@ module RunoffMod ! main channel !! states - real(r8), pointer :: rarea(:,:) ! area of channel water surface, [m2] + 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] @@ -263,14 +247,14 @@ module RunoffMod 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 + end type Tparameter !== Hongyi type (Tcontrol) , public :: Tctl @@ -334,7 +318,7 @@ subroutine RunoffInit(begr, endr, numr) 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%qsur(begr:endr,nt_rtm), & rtmCTL%qsub(begr:endr,nt_rtm), & rtmCTL%qgwl(begr:endr,nt_rtm), & rtmCTL%qirrig(begr:endr), &